pkg/fizhi/fizhi_init_vegsurftiles.F

C $Header: /u/gcmpack/MITgcm/pkg/fizhi/fizhi_init_vegsurftiles.F,v 1.6 2005/08/23 18:25:33 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
      WRITE(fn,'(a,I8,a,I2.2,a)')'vegtiles_cs32.d',nymd,'z',ihour,'.bin'
      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.7	C $Header: /u/gcmpack/MITgcm/pkg/fizhi/fizhi_init_vegsurftiles.F,v 1.6 2005/08/23 18:25:33 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.2	WRITE(fn,'(a,I8,a,I2.2,a)')'vegtiles_cs32.d',nymd,'z',ihour,'.bin'
62	molod	1.1	fileprec = 64
63
64			call MDSFINDUNIT( iunit, mythid )
65			recl=MDS_RECLEN( fileprec, NxNy8, mythid )
66
67			C Only do I/O if I am the master thread
68			_BEGIN_MASTER( myThid )
69
70			open(iUnit,file=fn,status='old',access='direct',recl=recl)
71			read(iunit,rec=1) globalarr
72			close( iunit )
73			_END_MASTER( myThid )
74
75
76			#ifdef _BYTESWAPIO
77			call MDS_BYTESWAPR8( NxNy8, globalarr )
78			#endif
79
80			DO bj = myByLo(myThid), myByHi(myThid)
81			DO bi = myBxLo(myThid), myBxHi(myThid)
82
83			#if defined(ALLOW_EXCH2)
84			bislot = exch2_txglobalo(W2_myTileList(bi))-1
85			bjslot = exch2_tyglobalo(W2_myTileList(bi))-1
86			#else
87			bislot = myXGlobalLo-1+(bi-1)*sNx
88			bjslot = myYGlobalLo-1+(bj-1)*sNy
89			#endif /* ALLOW_EXCH2 */
90
91	molod	1.4	call get_landfrac(sNx,sNy,Nsx,Nsy,bi,bj,maxtyp,
92	jmc	1.5	. surftype,tilefrac,fracland(1,1,bi,bj))
93	molod	1.4
94	molod	1.3	do j = 1,sNy
95	molod	1.1	do i = 1,sNx
96			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,1)
97			enddo
98			enddo
99	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
100			. temptile,nchp,nchptot(bi,bj))
101	molod	1.1	do n = 1,nchp
102			tcanopy(n,bi,bj) = temptile(n)
103			enddo
104
105	molod	1.3	do j = 1,sNy
106	molod	1.1	do i = 1,sNx
107			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,2)
108	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
109			. tempgrid(i,j) = globalarr(i+bislot,j+bjslot,1) - 0.5
110	molod	1.1	enddo
111			enddo
112	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
113			. temptile,nchp,nchptot(bi,bj))
114	molod	1.1	do n = 1,nchp
115			tdeep(n,bi,bj) = temptile(n)
116			enddo
117
118	molod	1.3	do j = 1,sNy
119	molod	1.1	do i = 1,sNx
120			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,3)
121	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
122			. tempgrid(i,j) = 0.01
123	molod	1.1	enddo
124			enddo
125	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
126			. temptile,nchp,nchptot(bi,bj))
127	molod	1.1	do n = 1,nchp
128			ecanopy(n,bi,bj) = temptile(n)
129			enddo
130
131	molod	1.3	do j = 1,sNy
132	molod	1.1	do i = 1,sNx
133			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,4)
134	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
135			. tempgrid(i,j) = 0.7
136	molod	1.1	enddo
137			enddo
138	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
139			. temptile,nchp,nchptot(bi,bj))
140	molod	1.1	do n = 1,nchp
141			swetshal(n,bi,bj) = temptile(n)
142			enddo
143
144	molod	1.3	do j = 1,sNy
145	molod	1.1	do i = 1,sNx
146			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,5)
147	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
148			. tempgrid(i,j) = 0.5
149	molod	1.1	enddo
150			enddo
151	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
152			. temptile,nchp,nchptot(bi,bj))
153	molod	1.1	do n = 1,nchp
154			swetroot(n,bi,bj) = temptile(n)
155			enddo
156
157	molod	1.3	do j = 1,sNy
158	molod	1.1	do i = 1,sNx
159			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,6)
160	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
161			. tempgrid(i,j) = 0.3
162	molod	1.1	enddo
163			enddo
164	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
165			. temptile,nchp,nchptot(bi,bj))
166	molod	1.1	do n = 1,nchp
167			swetdeep(n,bi,bj) = temptile(n)
168			enddo
169
170	molod	1.3	do j = 1,sNy
171	molod	1.1	do i = 1,sNx
172			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,7)
173	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
174			. tempgrid(i,j) = 0.
175	molod	1.1	enddo
176			enddo
177	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
178			. temptile,nchp,nchptot(bi,bj))
179	molod	1.1	do n = 1,nchp
180			snodep(n,bi,bj) = temptile(n)
181			enddo
182
183	molod	1.3	do j = 1,sNy
184	molod	1.1	do i = 1,sNx
185			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,8)
186	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
187			. tempgrid(i,j) = 0.
188	molod	1.1	enddo
189			enddo
190	molod	1.7	call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
191			. temptile,nchp,nchptot(bi,bj))
192	molod	1.1	do n = 1,nchp
193			capac(n,bi,bj) = temptile(n)
194			enddo
195
196			close(iunit)
197
198			C End of bi bj loop
199			enddo
200			enddo
201
202			RETURN
203			END