pkg/fizhi/fizhi_init_vegsurftiles.F

9017c2b82c Andr*0001 #include "FIZHI_OPTIONS.h"
                0002 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0003 CBOP
                0004 C     !ROUTINE: FIZHI_INIT_VEGSURFTILES
                0005 C     !INTERFACE:
a6b4f97600 Jean*0006       subroutine fizhi_init_vegsurftiles(globalArr,xsize,ysize,
                0007      &                                   nymd,nhms,prec,myThid)
9017c2b82c Andr*0008
                0009 C     !DESCRIPTION:
a6b4f97600 Jean*0010 C      Read in grid space values of the land state
9017c2b82c Andr*0011 C      and then convert to vegetation tile space
                0012
                0013 C     !USES:
                0014 C      Calls routine grd2msc to do grid to tile space for each bi bj
                0015       implicit none
                0016 #include "SIZE.h"
                0017 #include "fizhi_SIZE.h"
                0018 #include "fizhi_land_SIZE.h"
                0019 #include "fizhi_coms.h"
                0020 #include "fizhi_land_coms.h"
                0021 #include "fizhi_earth_coms.h"
                0022 #include "EEPARAMS.h"
                0023 #include "PARAMS.h"
                0024 #ifdef ALLOW_EXCH2
f9f661930b Jean*0025 #include "W2_EXCH2_SIZE.h"
9017c2b82c Andr*0026 #include "W2_EXCH2_TOPOLOGY.h"
                0027 #endif /* ALLOW_EXCH2 */
                0028
                0029 C     !INPUT/OUTPUT PARAMETERS:
a6b4f97600 Jean*0030       integer xsize, ysize
                0031       Real*8 globalArr(xsize,ysize,8)
9017c2b82c Andr*0032       CHARACTER*1 prec
                0033       INTEGER nhms,nymd
                0034       INTEGER myThid
                0035
                0036       EXTERNAL ILNBLNK
                0037       INTEGER ILNBLNK
                0038       INTEGER MDS_RECLEN
                0039 CEOP
                0040 C     !LOCAL VARIABLES:
de57a2ec4b Mart*0041       CHARACTER(MAX_LEN_FNAM) fn
9017c2b82c Andr*0042       integer ihour
                0043       integer i,j,n
                0044       integer bislot,bjslot,iunit
                0045       integer recl
                0046       integer bi,bj,fileprec
                0047       _RL tempgrid(sNx,sNy)
                0048       _RL temptile(nchp)
a14118e8be Andr*0049       _RL fracland(sNx,sNy,Nsx,Nsy)
9017c2b82c Andr*0050
                0051       ihour = nhms/10000
f1edb8ebdb Andr*0052       if(xsize.eq.192) then
7de3ff73f6 Andr*0053       WRITE(fn,'(a,I8,a,I2.2,a)')
                0054      .            'vegtiles_cs32.d',nymd,'z',ihour,'.bin'
f1edb8ebdb Andr*0055       elseif(xsize.eq.612) then
7de3ff73f6 Andr*0056       WRITE(fn,'(a,I8,a,I2.2,a)')
                0057      .            'vegtiles_cs102.d',nymd,'z',ihour,'.bin'
f1edb8ebdb Andr*0058       else
                0059       print *,' xsize is ',xsize
                0060       stop 'do not seem to have correct vegtiles data '
                0061       endif
9017c2b82c Andr*0062       fileprec = 64
                0063
                0064       call MDSFINDUNIT( iunit, mythid )
                0065       recl=MDS_RECLEN( fileprec, Nx*Ny*8, mythid )
                0066
                0067 C Only do I/O if I am the master thread
                0068       _BEGIN_MASTER( myThid )
                0069
                0070       open(iUnit,file=fn,status='old',access='direct',recl=recl)
                0071       read(iunit,rec=1) globalarr
                0072       close( iunit )
                0073       _END_MASTER( myThid )
                0074
                0075
                0076 #ifdef _BYTESWAPIO
                0077        call MDS_BYTESWAPR8( Nx*Ny*8, globalarr )
                0078 #endif
                0079
                0080       DO bj = myByLo(myThid), myByHi(myThid)
                0081       DO bi = myBxLo(myThid), myBxHi(myThid)
                0082
                0083 #if defined(ALLOW_EXCH2)
c424ee7cc7 Jean*0084        bislot = exch2_txglobalo(W2_myTileList(bi,bj))-1
                0085        bjslot = exch2_tyglobalo(W2_myTileList(bi,bj))-1
9017c2b82c Andr*0086 #else
                0087        bislot = myXGlobalLo-1+(bi-1)*sNx
                0088        bjslot = myYGlobalLo-1+(bj-1)*sNy
                0089 #endif /* ALLOW_EXCH2 */
                0090
a14118e8be Andr*0091       call get_landfrac(sNx,sNy,Nsx,Nsy,bi,bj,maxtyp,
c6535bf231 Jean*0092      .        surftype,tilefrac,fracland(1,1,bi,bj))
a14118e8be Andr*0093
9345b1f2b1 Andr*0094        do j = 1,sNy
9017c2b82c Andr*0095        do i = 1,sNx
                0096         tempgrid(i,j) = globalarr(i+bislot,j+bjslot,1)
                0097        enddo
                0098        enddo
cf27339f26 Andr*0099        call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
                0100      .                 temptile,nchp,nchptot(bi,bj))
9017c2b82c Andr*0101        do n = 1,nchp
                0102         tcanopy(n,bi,bj) = temptile(n)
                0103        enddo
                0104
9345b1f2b1 Andr*0105        do j = 1,sNy
9017c2b82c Andr*0106        do i = 1,sNx
                0107         tempgrid(i,j) = globalarr(i+bislot,j+bjslot,2)
a14118e8be Andr*0108         if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
                0109      .    tempgrid(i,j) = globalarr(i+bislot,j+bjslot,1) - 0.5
9017c2b82c Andr*0110        enddo
                0111        enddo
cf27339f26 Andr*0112        call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
                0113      .                    temptile,nchp,nchptot(bi,bj))
9017c2b82c Andr*0114        do n = 1,nchp
                0115         tdeep(n,bi,bj) = temptile(n)
                0116        enddo
                0117
9345b1f2b1 Andr*0118        do j = 1,sNy
9017c2b82c Andr*0119        do i = 1,sNx
                0120         tempgrid(i,j) = globalarr(i+bislot,j+bjslot,3)
a14118e8be Andr*0121         if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
                0122      .    tempgrid(i,j) = 0.01
9017c2b82c Andr*0123        enddo
                0124        enddo
cf27339f26 Andr*0125        call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
                0126      .                    temptile,nchp,nchptot(bi,bj))
9017c2b82c Andr*0127        do n = 1,nchp
                0128         ecanopy(n,bi,bj) = temptile(n)
                0129        enddo
                0130
9345b1f2b1 Andr*0131        do j = 1,sNy
9017c2b82c Andr*0132        do i = 1,sNx
                0133         tempgrid(i,j) = globalarr(i+bislot,j+bjslot,4)
a14118e8be Andr*0134         if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
                0135      .    tempgrid(i,j) = 0.7
9017c2b82c Andr*0136        enddo
                0137        enddo
cf27339f26 Andr*0138        call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
                0139      .                    temptile,nchp,nchptot(bi,bj))
9017c2b82c Andr*0140        do n = 1,nchp
                0141         swetshal(n,bi,bj) = temptile(n)
                0142        enddo
                0143
9345b1f2b1 Andr*0144        do j = 1,sNy
9017c2b82c Andr*0145        do i = 1,sNx
                0146         tempgrid(i,j) = globalarr(i+bislot,j+bjslot,5)
a14118e8be Andr*0147         if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
                0148      .    tempgrid(i,j) = 0.5
9017c2b82c Andr*0149        enddo
                0150        enddo
cf27339f26 Andr*0151        call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
                0152      .                    temptile,nchp,nchptot(bi,bj))
9017c2b82c Andr*0153        do n = 1,nchp
                0154         swetroot(n,bi,bj) = temptile(n)
                0155        enddo
                0156
9345b1f2b1 Andr*0157        do j = 1,sNy
9017c2b82c Andr*0158        do i = 1,sNx
                0159         tempgrid(i,j) = globalarr(i+bislot,j+bjslot,6)
a14118e8be Andr*0160         if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
                0161      .    tempgrid(i,j) = 0.3
9017c2b82c Andr*0162        enddo
                0163        enddo
cf27339f26 Andr*0164        call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
                0165      .                    temptile,nchp,nchptot(bi,bj))
9017c2b82c Andr*0166        do n = 1,nchp
                0167         swetdeep(n,bi,bj) = temptile(n)
                0168        enddo
                0169
9345b1f2b1 Andr*0170        do j = 1,sNy
9017c2b82c Andr*0171        do i = 1,sNx
                0172         tempgrid(i,j) = globalarr(i+bislot,j+bjslot,7)
a14118e8be Andr*0173         if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
                0174      .    tempgrid(i,j) = 0.
9017c2b82c Andr*0175        enddo
                0176        enddo
cf27339f26 Andr*0177        call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
                0178      .                    temptile,nchp,nchptot(bi,bj))
9017c2b82c Andr*0179        do n = 1,nchp
                0180         snodep(n,bi,bj) = temptile(n)
                0181        enddo
                0182
9345b1f2b1 Andr*0183        do j = 1,sNy
9017c2b82c Andr*0184        do i = 1,sNx
                0185         tempgrid(i,j) = globalarr(i+bislot,j+bjslot,8)
a14118e8be Andr*0186         if (tempgrid(i,j).gt.1.e14 .and. fracland(i,j,bi,bj).gt.0.0001)
                0187      .    tempgrid(i,j) = 0.
9017c2b82c Andr*0188        enddo
                0189        enddo
cf27339f26 Andr*0190        call grd2msc(tempgrid,sNx,sNy,igrd(1,bi,bj),
                0191      .                    temptile,nchp,nchptot(bi,bj))
9017c2b82c Andr*0192        do n = 1,nchp
                0193         capac(n,bi,bj) = temptile(n)
                0194        enddo
                0195
                0196        close(iunit)
                0197
                0198 C End of bi bj loop
                0199       enddo
                0200       enddo
                0201
                0202       RETURN
                0203       END