pkg/fizhi/fizhi_init_vegsurftiles.F

C $Header: /u/gcmpack/MITgcm/pkg/fizhi/fizhi_init_vegsurftiles.F,v 1.5 2005/08/13 20:50:50 jmc 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,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,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,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,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,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,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,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,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.6	C $Header: /u/gcmpack/MITgcm/pkg/fizhi/fizhi_init_vegsurftiles.F,v 1.5 2005/08/13 20:50:50 jmc 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			call grd2msc(tempgrid,sNx,sNy,igrd,temptile,nchp,nchptot(bi,bj))
100			do n = 1,nchp
101			tcanopy(n,bi,bj) = temptile(n)
102			enddo
103
104	molod	1.3	do j = 1,sNy
105	molod	1.1	do i = 1,sNx
106			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,2)
107	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
108			. tempgrid(i,j) = globalarr(i+bislot,j+bjslot,1) - 0.5
109	molod	1.1	enddo
110			enddo
111			call grd2msc(tempgrid,sNx,sNy,igrd,temptile,nchp,nchptot(bi,bj))
112			do n = 1,nchp
113			tdeep(n,bi,bj) = temptile(n)
114			enddo
115
116	molod	1.3	do j = 1,sNy
117	molod	1.1	do i = 1,sNx
118			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,3)
119	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
120			. tempgrid(i,j) = 0.01
121	molod	1.1	enddo
122			enddo
123			call grd2msc(tempgrid,sNx,sNy,igrd,temptile,nchp,nchptot(bi,bj))
124			do n = 1,nchp
125			ecanopy(n,bi,bj) = temptile(n)
126			enddo
127
128	molod	1.3	do j = 1,sNy
129	molod	1.1	do i = 1,sNx
130			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,4)
131	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
132			. tempgrid(i,j) = 0.7
133	molod	1.1	enddo
134			enddo
135			call grd2msc(tempgrid,sNx,sNy,igrd,temptile,nchp,nchptot(bi,bj))
136			do n = 1,nchp
137			swetshal(n,bi,bj) = temptile(n)
138			enddo
139
140	molod	1.3	do j = 1,sNy
141	molod	1.1	do i = 1,sNx
142			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,5)
143	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
144			. tempgrid(i,j) = 0.5
145	molod	1.1	enddo
146			enddo
147			call grd2msc(tempgrid,sNx,sNy,igrd,temptile,nchp,nchptot(bi,bj))
148			do n = 1,nchp
149			swetroot(n,bi,bj) = temptile(n)
150			enddo
151
152	molod	1.3	do j = 1,sNy
153	molod	1.1	do i = 1,sNx
154			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,6)
155	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
156			. tempgrid(i,j) = 0.3
157	molod	1.1	enddo
158			enddo
159			call grd2msc(tempgrid,sNx,sNy,igrd,temptile,nchp,nchptot(bi,bj))
160			do n = 1,nchp
161			swetdeep(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,7)
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.
169	molod	1.1	enddo
170			enddo
171			call grd2msc(tempgrid,sNx,sNy,igrd,temptile,nchp,nchptot(bi,bj))
172			do n = 1,nchp
173			snodep(n,bi,bj) = temptile(n)
174			enddo
175
176	molod	1.3	do j = 1,sNy
177	molod	1.1	do i = 1,sNx
178			tempgrid(i,j) = globalarr(i+bislot,j+bjslot,8)
179	molod	1.4	if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
180			. tempgrid(i,j) = 0.
181	molod	1.1	enddo
182			enddo
183			call grd2msc(tempgrid,sNx,sNy,igrd,temptile,nchp,nchptot(bi,bj))
184			do n = 1,nchp
185			capac(n,bi,bj) = temptile(n)
186			enddo
187
188			close(iunit)
189
190			C End of bi bj loop
191			enddo
192			enddo
193
194			RETURN
195			END