pkg/fizhi/fizhi_init_vegsurftiles.F

C $Header: /u/gcmpack/MITgcm/pkg/fizhi/fizhi_init_vegsurftiles.F,v 1.8 2007/06/21 22:11:57 molod Exp $
C $Name:  $

#include "FIZHI_OPTIONS.h"
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP
C     !ROUTINE: FIZHI_INIT_VEGSURFTILES
C     !INTERFACE:
      subroutine fizhi_init_vegsurftiles(nymd,nhms,prec,myThid)

C     !DESCRIPTION:
C      Read in grid space values of the land state 
C      and then convert to vegetation tile space

C     !USES:
C      Calls routine grd2msc to do grid to tile space for each bi bj
      implicit none
#include "SIZE.h"
#include "fizhi_SIZE.h"
#include "fizhi_land_SIZE.h"
#include "fizhi_coms.h"
#include "fizhi_land_coms.h"
#include "fizhi_earth_coms.h"
#include "EEPARAMS.h"
#include "PARAMS.h"
#ifdef ALLOW_EXCH2
#include "W2_EXCH2_TOPOLOGY.h"
#include "W2_EXCH2_PARAMS.h"
#endif /* ALLOW_EXCH2 */

C     !INPUT/OUTPUT PARAMETERS:
      CHARACTER*1 prec
      INTEGER nhms,nymd
      INTEGER myThid

      EXTERNAL ILNBLNK
      INTEGER ILNBLNK
      INTEGER MDS_RECLEN
CEOP
C     !LOCAL VARIABLES:
      CHARACTER*80 fn
      integer ihour
      integer i,j,n
      integer bislot,bjslot,iunit
      integer recl
      integer bi,bj,fileprec
      integer xsize, ysize
#if defined(ALLOW_EXCH2)
       PARAMETER ( xsize = exch2_domain_nxt * sNx )
       PARAMETER ( ysize = exch2_domain_nyt * sNy )
#else
       PARAMETER ( xsize = Nx )
       PARAMETER ( ysize = Ny )
#endif
      Real*8 globalarr(xsize,ysize,8)
      _RL tempgrid(sNx,sNy)
      _RL temptile(nchp)
      _RL fracland(sNx,sNy,Nsx,Nsy)

      ihour = nhms/10000
      if(xsize.eq.192) then
      WRITE(fn,'(a,I8,a,I2.2,a)')'vegtiles_cs32.d',nymd,'z',ihour,'.bin'
      elseif(xsize.eq.612) then
      WRITE(fn,'(a,I8,a,I2.2,a)')'vegtiles_cs102.d',nymd,'z',ihour,'.bin'
      else
      print *,' xsize is ',xsize
      stop 'do not seem to have correct vegtiles data '
      endif
      fileprec = 64

      call MDSFINDUNIT( iunit, mythid )
      recl=MDS_RECLEN( fileprec, Nx*Ny*8, mythid )

C Only do I/O if I am the master thread
      _BEGIN_MASTER( myThid )

      open(iUnit,file=fn,status='old',access='direct',recl=recl)
      read(iunit,rec=1) globalarr
      close( iunit )
      _END_MASTER( myThid )


#ifdef _BYTESWAPIO
       call MDS_BYTESWAPR8( Nx*Ny*8, globalarr )
#endif

      DO bj = myByLo(myThid), myByHi(myThid)
      DO bi = myBxLo(myThid), myBxHi(myThid)

#if defined(ALLOW_EXCH2)
       bislot = exch2_txglobalo(W2_myTileList(bi))-1
       bjslot = exch2_tyglobalo(W2_myTileList(bi))-1
#else
       bislot = myXGlobalLo-1+(bi-1)*sNx
       bjslot = myYGlobalLo-1+(bj-1)*sNy
#endif /* ALLOW_EXCH2 */

      call get_landfrac(sNx,sNy,Nsx,Nsy,bi,bj,maxtyp,
     .        surftype,tilefrac,fracland(1,1,bi,bj))

       do j = 1,sNy
       do i = 1,sNx
        tempgrid(i,j) = globalarr(i+bislot,j+bjslot,1)
       enddo
       enddo
       call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
     .                 temptile,nchp,nchptot(bi,bj))
       do n = 1,nchp
        tcanopy(n,bi,bj) = temptile(n)
       enddo

       do j = 1,sNy
       do i = 1,sNx
        tempgrid(i,j) = globalarr(i+bislot,j+bjslot,2)
        if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
     .    tempgrid(i,j) = globalarr(i+bislot,j+bjslot,1) - 0.5
       enddo
       enddo
       call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
     .                    temptile,nchp,nchptot(bi,bj))
       do n = 1,nchp
        tdeep(n,bi,bj) = temptile(n)
       enddo

       do j = 1,sNy
       do i = 1,sNx
        tempgrid(i,j) = globalarr(i+bislot,j+bjslot,3)
        if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
     .    tempgrid(i,j) = 0.01
       enddo
       enddo
       call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
     .                    temptile,nchp,nchptot(bi,bj))
       do n = 1,nchp
        ecanopy(n,bi,bj) = temptile(n)
       enddo

       do j = 1,sNy
       do i = 1,sNx
        tempgrid(i,j) = globalarr(i+bislot,j+bjslot,4)
        if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
     .    tempgrid(i,j) = 0.7
       enddo
       enddo
       call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
     .                    temptile,nchp,nchptot(bi,bj))
       do n = 1,nchp
        swetshal(n,bi,bj) = temptile(n)
       enddo

       do j = 1,sNy
       do i = 1,sNx
        tempgrid(i,j) = globalarr(i+bislot,j+bjslot,5)
        if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
     .    tempgrid(i,j) = 0.5
       enddo
       enddo
       call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
     .                    temptile,nchp,nchptot(bi,bj))
       do n = 1,nchp
        swetroot(n,bi,bj) = temptile(n)
       enddo

       do j = 1,sNy
       do i = 1,sNx
        tempgrid(i,j) = globalarr(i+bislot,j+bjslot,6)
        if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
     .    tempgrid(i,j) = 0.3
       enddo
       enddo
       call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
     .                    temptile,nchp,nchptot(bi,bj))
       do n = 1,nchp
        swetdeep(n,bi,bj) = temptile(n)
       enddo

       do j = 1,sNy
       do i = 1,sNx
        tempgrid(i,j) = globalarr(i+bislot,j+bjslot,7)
        if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
     .    tempgrid(i,j) = 0.
       enddo
       enddo
       call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
     .                    temptile,nchp,nchptot(bi,bj))
       do n = 1,nchp
        snodep(n,bi,bj) = temptile(n)
       enddo

       do j = 1,sNy
       do i = 1,sNx
        tempgrid(i,j) = globalarr(i+bislot,j+bjslot,8)
        if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
     .    tempgrid(i,j) = 0.
       enddo
       enddo
       call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
     .                    temptile,nchp,nchptot(bi,bj))
       do n = 1,nchp
        capac(n,bi,bj) = temptile(n)
       enddo

       close(iunit)

C End of bi bj loop
      enddo
      enddo

      RETURN
      END
1	molod	1.9	C $Header: /u/gcmpack/MITgcm/pkg/fizhi/fizhi_init_vegsurftiles.F,v 1.8 2007/06/21 22:11:57 molod Exp $
2	molod	1.1	C $Name: $
3
4			#include "FIZHI_OPTIONS.h"
5			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
6			CBOP
7			C !ROUTINE: FIZHI_INIT_VEGSURFTILES
8			C !INTERFACE:
9			subroutine fizhi_init_vegsurftiles(nymd,nhms,prec,myThid)
10
11			C !DESCRIPTION:
12			C Read in grid space values of the land state
13			C and then convert to vegetation tile space
14
15			C !USES:
16			C Calls routine grd2msc to do grid to tile space for each bi bj
17			implicit none
18			#include "SIZE.h"
19			#include "fizhi_SIZE.h"
20			#include "fizhi_land_SIZE.h"
21			#include "fizhi_coms.h"
22			#include "fizhi_land_coms.h"
23			#include "fizhi_earth_coms.h"
24			#include "EEPARAMS.h"
25			#include "PARAMS.h"
26			#ifdef ALLOW_EXCH2
27			#include "W2_EXCH2_TOPOLOGY.h"
28			#include "W2_EXCH2_PARAMS.h"
29			#endif /* ALLOW_EXCH2 */
30
31			C !INPUT/OUTPUT PARAMETERS:
32			CHARACTER*1 prec
33			INTEGER nhms,nymd
34			INTEGER myThid
35
36			EXTERNAL ILNBLNK
37			INTEGER ILNBLNK
38			INTEGER MDS_RECLEN
39			CEOP
40			C !LOCAL VARIABLES:
41			CHARACTER*80 fn
42			integer ihour
43			integer i,j,n
44			integer bislot,bjslot,iunit
45			integer recl
46			integer bi,bj,fileprec
47	molod	1.6	integer xsize, ysize
48			#if defined(ALLOW_EXCH2)
49			PARAMETER ( xsize = exch2_domain_nxt * sNx )
50			PARAMETER ( ysize = exch2_domain_nyt * sNy )
51			#else
52			PARAMETER ( xsize = Nx )
53			PARAMETER ( ysize = Ny )
54			#endif
55			Real*8 globalarr(xsize,ysize,8)
56	molod	1.1	_RL tempgrid(sNx,sNy)
57			_RL temptile(nchp)
58	molod	1.4	_RL fracland(sNx,sNy,Nsx,Nsy)
59	molod	1.1
60			ihour = nhms/10000
61	molod	1.8	if(xsize.eq.192) then
62	molod	1.2	WRITE(fn,'(a,I8,a,I2.2,a)')'vegtiles_cs32.d',nymd,'z',ihour,'.bin'
63	molod	1.8	elseif(xsize.eq.612) then
64	molod	1.9	WRITE(fn,'(a,I8,a,I2.2,a)')'vegtiles_cs102.d',nymd,'z',ihour,'.bin'
65	molod	1.8	else
66			print *,' xsize is ',xsize
67			stop 'do not seem to have correct vegtiles data '
68			endif
69	molod	1.1	fileprec = 64
70
71			call MDSFINDUNIT( iunit, mythid )
72			recl=MDS_RECLEN( fileprec, NxNy8, mythid )
73
74			C Only do I/O if I am the master thread
75			_BEGIN_MASTER( myThid )
76
77			open(iUnit,file=fn,status='old',access='direct',recl=recl)
78			read(iunit,rec=1) globalarr
79			close( iunit )
80			_END_MASTER( myThid )
81
82
83			#ifdef _BYTESWAPIO
84			call MDS_BYTESWAPR8( NxNy8, globalarr )
85			#endif
86
87			DO bj = myByLo(myThid), myByHi(myThid)
88			DO bi = myBxLo(myThid), myBxHi(myThid)
89
90			#if defined(ALLOW_EXCH2)
91			bislot = exch2_txglobalo(W2_myTileList(bi))-1
92			bjslot = exch2_tyglobalo(W2_myTileList(bi))-1
93			#else
94			bislot = myXGlobalLo-1+(bi-1)*sNx
95			bjslot = myYGlobalLo-1+(bj-1)*sNy
96			#endif /* ALLOW_EXCH2 */
97
98	molod	1.4	call get_landfrac(sNx,sNy,Nsx,Nsy,bi,bj,maxtyp,
99	jmc	1.5	. surftype,tilefrac,fracland(1,1,bi,bj))
100	molod	1.4
101	molod	1.3	do j = 1,sNy
102	molod	1.1	do i = 1,sNx
103			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,1)
104			enddo
105			enddo
106	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
107			. temptile,nchp,nchptot(bi,bj))
108	molod	1.1	do n = 1,nchp
109			tcanopy(n,bi,bj) = temptile(n)
110			enddo
111
112	molod	1.3	do j = 1,sNy
113	molod	1.1	do i = 1,sNx
114			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,2)
115	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
116			. tempgrid(i,j) = globalarr(i+bislot,j+bjslot,1) - 0.5
117	molod	1.1	enddo
118			enddo
119	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
120			. temptile,nchp,nchptot(bi,bj))
121	molod	1.1	do n = 1,nchp
122			tdeep(n,bi,bj) = temptile(n)
123			enddo
124
125	molod	1.3	do j = 1,sNy
126	molod	1.1	do i = 1,sNx
127			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,3)
128	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
129			. tempgrid(i,j) = 0.01
130	molod	1.1	enddo
131			enddo
132	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
133			. temptile,nchp,nchptot(bi,bj))
134	molod	1.1	do n = 1,nchp
135			ecanopy(n,bi,bj) = temptile(n)
136			enddo
137
138	molod	1.3	do j = 1,sNy
139	molod	1.1	do i = 1,sNx
140			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,4)
141	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
142			. tempgrid(i,j) = 0.7
143	molod	1.1	enddo
144			enddo
145	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
146			. temptile,nchp,nchptot(bi,bj))
147	molod	1.1	do n = 1,nchp
148			swetshal(n,bi,bj) = temptile(n)
149			enddo
150
151	molod	1.3	do j = 1,sNy
152	molod	1.1	do i = 1,sNx
153			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,5)
154	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
155			. tempgrid(i,j) = 0.5
156	molod	1.1	enddo
157			enddo
158	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
159			. temptile,nchp,nchptot(bi,bj))
160	molod	1.1	do n = 1,nchp
161			swetroot(n,bi,bj) = temptile(n)
162			enddo
163
164	molod	1.3	do j = 1,sNy
165	molod	1.1	do i = 1,sNx
166			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,6)
167	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
168			. tempgrid(i,j) = 0.3
169	molod	1.1	enddo
170			enddo
171	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
172			. temptile,nchp,nchptot(bi,bj))
173	molod	1.1	do n = 1,nchp
174			swetdeep(n,bi,bj) = temptile(n)
175			enddo
176
177	molod	1.3	do j = 1,sNy
178	molod	1.1	do i = 1,sNx
179			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,7)
180	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
181			. tempgrid(i,j) = 0.
182	molod	1.1	enddo
183			enddo
184	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
185			. temptile,nchp,nchptot(bi,bj))
186	molod	1.1	do n = 1,nchp
187			snodep(n,bi,bj) = temptile(n)
188			enddo
189
190	molod	1.3	do j = 1,sNy
191	molod	1.1	do i = 1,sNx
192			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,8)
193	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
194			. tempgrid(i,j) = 0.
195	molod	1.1	enddo
196			enddo
197	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
198			. temptile,nchp,nchptot(bi,bj))
199	molod	1.1	do n = 1,nchp
200			capac(n,bi,bj) = temptile(n)
201			enddo
202
203			close(iunit)
204
205			C End of bi bj loop
206			enddo
207			enddo
208
209			RETURN
210			END