pkg/fizhi/fizhi_init_vegsurftiles.F

C $Header: /u/gcmpack/MITgcm/pkg/fizhi/fizhi_init_vegsurftiles.F,v 1.3 2005/05/07 14:15:09 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
      Real*8 globalarr(Nx,Ny,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)

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