pkg/fizhi/fizhi_init_veg.F

C $Header: /u/gcmpack/MITgcm/pkg/fizhi/fizhi_init_veg.F,v 1.18 2004/10/22 19:20:55 molod Exp $
C $Name:  $

#include "FIZHI_OPTIONS.h"

      subroutine fizhi_init_veg(mythid,vegdata,im,jm,Nsx,Nsy,Nxg,Nyg,
     . maxtyp,nchp,nchptot,nchpland,lons,lats,surftype,tilefrac,
     . igrd,ityp,chfr,chlt,chlon)
C***********************************************************************
C Subroutine fizhi_init_veg - routine to read in the land surface types,
C      interpolate to the models grid, and set up tile space for use by 
C      the land surface model, the albedo calculation and the surface 
C      roughness calculation.
C
C INPUT:
C 
C mythid   - thread number (processor number)
C vegdata  - Character*40 Vegetation Dataset name
C im       - longitude dimension
C jm       - latitude dimension (number of lat. points)
C Nsx      - Number of processors in x-direction
C Nsy      - Number of processors in y-direction
C maxtyp   - maximum allowable number of land surface types per grid box
C nchp     - integer per-processor number of tiles in tile space
C lons     - longitude in degrees [im,jm,nSx,nSy]
C lats     - latitude in degrees [im,jm,nSx,nSy]
C
C OUTPUT:
C
C surftype - integer array of land surface types [im,jm,maxtyp,Nsx,Nsy]
C tilefrac - real array of corresponding land surface type fractions 
C            [im,jm,maxtyp,Nsx,Nsy]
C igrd     - integer array in tile space of grid point number for each 
C            tile [nchp,Nsx,Nsy]
C ityp     - integer array in tile space of land surface type for each 
C            tile [nchp,Nsx,Nsy]
C chfr     - real array in tile space of land surface type fraction for 
C            each tile [nchp,Nsx,Nsy]
C
C NOTES:
C       Vegetation type as follows:
C                  1:  BROADLEAF EVERGREEN TREES
C                  2:  BROADLEAF DECIDUOUS TREES
C                  3:  NEEDLELEAF TREES
C                  4:  GROUND COVER
C                  5:  BROADLEAF SHRUBS
C                  6:  DWARF TREES (TUNDRA)
C                  7:  BARE SOIL
C                  8:  DESERT    
C                  9:  GLACIER
C                 10:  DARK DESERT
C                100:  OCEAN
C***********************************************************************
      implicit none
#include "EEPARAMS.h"

      integer mythid,im,jm,maxtyp,nchp,Nsx,Nsy,Nxg,Nyg
      integer nchptot(Nsx,Nsy), nchpland(Nsx,Nsy)
      integer surftype(im,jm,maxtyp,Nsx,Nsy)
      integer igrd(nchp,Nsx,Nsy),ityp(nchp,Nsx,Nsy)
      _RL tilefrac(im,jm,maxtyp,Nsx,Nsy)
      _RL lats(im,jm,nSx,nSy), lons(im,jm,nSx,nSy)
      _RL chfr(nchp,Nsx,Nsy),chlt(nchp,Nsx,Nsy),chlon(nchp,Nsx,Nsy)
      character*40 vegdata
      integer imdata,jmdata,Nxgdata,Nygdata
      integer biglobal,bjglobal

      integer*4 im_32, jm_32, Nxg_32, Nyg_32
      integer*4 iveg_32(im,jm,maxtyp,Nxg,Nyg)
         real*4  veg_32(im,jm,maxtyp,Nxg,Nyg)

      integer i,j,k,bi,bj,ierr1,kveg

#ifdef ALLOW_MNC
      character*(MAX_LEN_FNAM) fizhi_veg_bn
#endif

C     Allow for MDSIO format if someday needed
#ifdef ALLOW_MDSIO
      IF ( .FALSE. ) THEN

      call mdsfindunit( kveg, myThid )
      close(kveg)
      open(kveg,file=vegdata,form='unformatted',access='sequential', 
     .                      iostat=ierr1)
      if( ierr1.eq.0 ) then
          read(kveg)im_32,jm_32,Nxg_32,Nyg_32,IVEG_32,VEG_32
      else
       print *
       print *, 'Veg Dataset: ',vegdata,' not found!'
       print *
       call exit(101)
      endif
      close(kveg)

      IF (myThid.eq.1) THEN
      imdata = im_32
      jmdata = jm_32
      Nxgdata = Nxg_32
      Nygdata = Nyg_32
      if( (imdata.ne.im) .or. (jmdata.ne.jm) .or. 
     .                     (Nxgdata.ne.Nxg) .or. (Nygdata.ne.Nyg) ) then
       print *
       print *, 'Veg Data Resolution is Incorrect! '
       print *,' Model Res: ',im,'x',jm,' Data Res: ',imdata,'x',jmdata
       print *,' Model Nxg Nyg: ',Nxg,' ',Nyg,' Data Nxg Nyg: ',Nxgdata,
     .                    ' ',Nygdata
       print *
       call exit(102)
      ENDIF
      ENDIF

      DO BJ = myByLo(myThid), myByHi(myThid)
      DO BI = myBxLo(myThid), myBxHi(myThid)

      biglobal=bi+(myXGlobalLo-1)/im
      bjglobal=bj+(myYGlobalLo-1)/jm
#if defined( _BYTESWAPIO ) && defined( ALLOW_MDSIO )
      call MDS_BYTESWAPR4(im*jm*maxtyp,veg_32(1,1,1,biglobal,bjglobal))
#endif
      do k = 1,maxtyp
      do j = 1,jm
      do i = 1,im
       surftype(i,j,k,bi,bj) = iveg_32(i,j,k,biglobal,bjglobal) 
       tilefrac(i,j,k,bi,bj) = veg_32(i,j,k,biglobal,bjglobal)
      enddo
      enddo
      enddo

      ENDDO
      ENDDO

      ENDIF
#endif

#ifdef ALLOW_MNC
      IF (useMNC) THEN
        _BEGIN_MASTER( myThid )
      
        do i = 1,MAX_LEN_FNAM
          fizhi_veg_bn(i:i) = ' '
        enddo
      
C       The following base name should be handled by some sort of input
C       name parameter in FIZHI_READPARMS() plus a possible size.
      
C       Set the base name     1234567890
        fizhi_veg_bn(1:10) = 'fizhi_veg '
      
        CALL MNC_CW_I_R('I', fizhi_veg_bn, 0,0, 
     &       'surftype',surftype,myThid)
        CALL MNC_CW_RL_R('R', fizhi_veg_bn, 0,0,
     &       'tilefrac', tilefrac, myThid)
      
        _END_MASTER( myThid )
      ENDIF
#endif

c     create chip arrays for :
c      igrd :  grid index
c      ityp :  veg. type
c      chfr :  vegetation fraction
c      chlon:  chip longitude
c      chlt :  chip latitude

c     nchpland<=nchptot is the actual number of land chips

      DO BJ = myByLo(myThid), myByHi(myThid)
        DO BI = myBxLo(myThid), myBxHi(myThid)

c         land points
c         -----------
          nchpland(bi,bj) = 0
          do k=1,maxtyp
            do j=1,jm
              do i=1,im
                if(surftype(i,j,k,bi,bj).lt.100 .and.
     .               tilefrac(i,j,k,bi,bj).gt.0.) then
                  nchpland(bi,bj)  = nchpland(bi,bj) + 1
                  igrd (nchpland(bi,bj),bi,bj) = i + (j-1)*im
                  ityp (nchpland(bi,bj),bi,bj) = surftype(i,j,k,bi,bj)
                  chfr (nchpland(bi,bj),bi,bj) = tilefrac(i,j,k,bi,bj)
                  chlon(nchpland(bi,bj),bi,bj) = lons(i,j,bi,bj)
                  chlt (nchpland(bi,bj),bi,bj) = lats(i,j,bi,bj)
                endif
              enddo
            enddo
          enddo
          
c         ocean points
c         ------------
          nchptot(bi,bj) = nchpland(bi,bj)
          
          do k=1,maxtyp
            do j=1,jm
              do i=1,im
                if(surftype(i,j,k,bi,bj).ge.100 .and. 
     .               tilefrac(i,j,k,bi,bj).gt.0.) then
                  nchptot(bi,bj)  = nchptot(bi,bj) + 1
                  igrd (nchptot(bi,bj),bi,bj) = i + (j-1)*im
                  ityp (nchptot(bi,bj),bi,bj) = surftype(i,j,k,bi,bj)
                  chfr (nchptot(bi,bj),bi,bj) = tilefrac(i,j,k,bi,bj)
                  chlon(nchptot(bi,bj),bi,bj) = lons(i,j,bi,bj)
                  chlt (nchptot(bi,bj),bi,bj) = lats(i,j,bi,bj)
                endif
              enddo
            enddo
          enddo
          
          print *,'Number of Total Tiles for bi=',bi,': ',nchptot(bi,bj)
          print *,'Number of Land  Tiles for bi=',bi,': ',nchpland(bi,bj)

        ENDDO
      ENDDO
      
      RETURN
      END
1	molod	1.19	C $Header: /u/gcmpack/MITgcm/pkg/fizhi/fizhi_init_veg.F,v 1.18 2004/10/22 19:20:55 molod Exp $
2	molod	1.1	C $Name: $
3
4	edhill	1.14	#include "FIZHI_OPTIONS.h"
5
6	molod	1.6	subroutine fizhi_init_veg(mythid,vegdata,im,jm,Nsx,Nsy,Nxg,Nyg,
7	molod	1.15	. maxtyp,nchp,nchptot,nchpland,lons,lats,surftype,tilefrac,
8			. igrd,ityp,chfr,chlt,chlon)
9	molod	1.1	C***********************************************************************
10	molod	1.2	C Subroutine fizhi_init_veg - routine to read in the land surface types,
11			C interpolate to the models grid, and set up tile space for use by
12			C the land surface model, the albedo calculation and the surface
13			C roughness calculation.
14	molod	1.1	C
15			C INPUT:
16			C
17			C mythid - thread number (processor number)
18	molod	1.2	C vegdata - Character*40 Vegetation Dataset name
19	molod	1.7	C im - longitude dimension
20			C jm - latitude dimension (number of lat. points)
21	molod	1.4	C Nsx - Number of processors in x-direction
22			C Nsy - Number of processors in y-direction
23	molod	1.1	C maxtyp - maximum allowable number of land surface types per grid box
24	molod	1.6	C nchp - integer per-processor number of tiles in tile space
25	molod	1.7	C lons - longitude in degrees [im,jm,nSx,nSy]
26			C lats - latitude in degrees [im,jm,nSx,nSy]
27	molod	1.1	C
28			C OUTPUT:
29			C
30	molod	1.4	C surftype - integer array of land surface types [im,jm,maxtyp,Nsx,Nsy]
31	molod	1.1	C tilefrac - real array of corresponding land surface type fractions
32	molod	1.4	C [im,jm,maxtyp,Nsx,Nsy]
33	molod	1.1	C igrd - integer array in tile space of grid point number for each
34	molod	1.4	C tile [nchp,Nsx,Nsy]
35	molod	1.1	C ityp - integer array in tile space of land surface type for each
36	molod	1.4	C tile [nchp,Nsx,Nsy]
37	molod	1.1	C chfr - real array in tile space of land surface type fraction for
38	molod	1.4	C each tile [nchp,Nsx,Nsy]
39	molod	1.1	C
40			C NOTES:
41			C Vegetation type as follows:
42			C 1: BROADLEAF EVERGREEN TREES
43			C 2: BROADLEAF DECIDUOUS TREES
44			C 3: NEEDLELEAF TREES
45			C 4: GROUND COVER
46			C 5: BROADLEAF SHRUBS
47			C 6: DWARF TREES (TUNDRA)
48			C 7: BARE SOIL
49			C 8: DESERT
50			C 9: GLACIER
51			C 10: DARK DESERT
52			C 100: OCEAN
53			C***********************************************************************
54			implicit none
55	molod	1.5	#include "EEPARAMS.h"
56	molod	1.1
57	molod	1.18	integer mythid,im,jm,maxtyp,nchp,Nsx,Nsy,Nxg,Nyg
58			integer nchptot(Nsx,Nsy), nchpland(Nsx,Nsy)
59	molod	1.4	integer surftype(im,jm,maxtyp,Nsx,Nsy)
60	molod	1.6	integer igrd(nchp,Nsx,Nsy),ityp(nchp,Nsx,Nsy)
61	molod	1.10	_RL tilefrac(im,jm,maxtyp,Nsx,Nsy)
62			_RL lats(im,jm,nSx,nSy), lons(im,jm,nSx,nSy)
63			_RL chfr(nchp,Nsx,Nsy),chlt(nchp,Nsx,Nsy),chlon(nchp,Nsx,Nsy)
64	molod	1.1	character*40 vegdata
65	molod	1.6	integer imdata,jmdata,Nxgdata,Nygdata
66	molod	1.15	integer biglobal,bjglobal
67	molod	1.1
68	molod	1.6	integer*4 im_32, jm_32, Nxg_32, Nyg_32
69			integer*4 iveg_32(im,jm,maxtyp,Nxg,Nyg)
70			real*4 veg_32(im,jm,maxtyp,Nxg,Nyg)
71	molod	1.1
72	molod	1.3	integer i,j,k,bi,bj,ierr1,kveg
73	molod	1.1
74	edhill	1.14	#ifdef ALLOW_MNC
75			character*(MAX_LEN_FNAM) fizhi_veg_bn
76			#endif
77
78			C Allow for MDSIO format if someday needed
79			#ifdef ALLOW_MDSIO
80			IF ( .FALSE. ) THEN
81
82	molod	1.1	call mdsfindunit( kveg, myThid )
83	molod	1.2	close(kveg)
84			open(kveg,file=vegdata,form='unformatted',access='sequential',
85			. iostat=ierr1)
86	molod	1.1	if( ierr1.eq.0 ) then
87	molod	1.6	read(kveg)im_32,jm_32,Nxg_32,Nyg_32,IVEG_32,VEG_32
88	molod	1.1	else
89			print *
90			print *, 'Veg Dataset: ',vegdata,' not found!'
91			print *
92	molod	1.2	call exit(101)
93	molod	1.1	endif
94	molod	1.2	close(kveg)
95	edhill	1.14
96	molod	1.3	IF (myThid.eq.1) THEN
97	molod	1.2	imdata = im_32
98			jmdata = jm_32
99	molod	1.6	Nxgdata = Nxg_32
100			Nygdata = Nyg_32
101	molod	1.2	if( (imdata.ne.im) .or. (jmdata.ne.jm) .or.
102	molod	1.6	. (Nxgdata.ne.Nxg) .or. (Nygdata.ne.Nyg) ) then
103	molod	1.2	print *
104			print *, 'Veg Data Resolution is Incorrect! '
105			print *,' Model Res: ',im,'x',jm,' Data Res: ',imdata,'x',jmdata
106	molod	1.6	print *,' Model Nxg Nyg: ',Nxg,' ',Nyg,' Data Nxg Nyg: ',Nxgdata,
107			. ' ',Nygdata
108	molod	1.2	print *
109			call exit(102)
110	molod	1.1	ENDIF
111	molod	1.12	ENDIF
112
113	molod	1.5	DO BJ = myByLo(myThid), myByHi(myThid)
114			DO BI = myBxLo(myThid), myBxHi(myThid)
115
116			biglobal=bi+(myXGlobalLo-1)/im
117			bjglobal=bj+(myYGlobalLo-1)/jm
118	edhill	1.14	#if defined( _BYTESWAPIO ) && defined( ALLOW_MDSIO )
119	molod	1.13	call MDS_BYTESWAPR4(imjmmaxtyp,veg_32(1,1,1,biglobal,bjglobal))
120			#endif
121	molod	1.2	do k = 1,maxtyp
122	molod	1.4	do j = 1,jm
123			do i = 1,im
124	molod	1.5	surftype(i,j,k,bi,bj) = iveg_32(i,j,k,biglobal,bjglobal)
125			tilefrac(i,j,k,bi,bj) = veg_32(i,j,k,biglobal,bjglobal)
126	molod	1.2	enddo
127	molod	1.1	enddo
128			enddo
129
130	edhill	1.14	ENDDO
131			ENDDO
132
133			ENDIF
134			#endif
135
136			#ifdef ALLOW_MNC
137	edhill	1.16	IF (useMNC) THEN
138			_BEGIN_MASTER( myThid )
139	edhill	1.14
140	edhill	1.16	do i = 1,MAX_LEN_FNAM
141			fizhi_veg_bn(i:i) = ' '
142			enddo
143	edhill	1.14
144	edhill	1.16	C The following base name should be handled by some sort of input
145			C name parameter in FIZHI_READPARMS() plus a possible size.
146	edhill	1.14
147	edhill	1.16	C Set the base name 1234567890
148			fizhi_veg_bn(1:10) = 'fizhi_veg '
149	edhill	1.14
150	edhill	1.16	CALL MNC_CW_I_R('I', fizhi_veg_bn, 0,0,
151			& 'surftype',surftype,myThid)
152			CALL MNC_CW_RL_R('R', fizhi_veg_bn, 0,0,
153			& 'tilefrac', tilefrac, myThid)
154	edhill	1.14
155	edhill	1.16	_END_MASTER( myThid )
156			ENDIF
157	edhill	1.14	#endif
158
159			c create chip arrays for :
160	molod	1.1	c igrd : grid index
161			c ityp : veg. type
162			c chfr : vegetation fraction
163	molod	1.7	c chlon: chip longitude
164			c chlt : chip latitude
165	molod	1.1
166	molod	1.15	c nchpland<=nchptot is the actual number of land chips
167	molod	1.1
168	edhill	1.14	DO BJ = myByLo(myThid), myByHi(myThid)
169			DO BI = myBxLo(myThid), myBxHi(myThid)
170	molod	1.1
171	edhill	1.14	c land points
172			c -----------
173	molod	1.18	nchpland(bi,bj) = 0
174	edhill	1.14	do k=1,maxtyp
175			do j=1,jm
176			do i=1,im
177			if(surftype(i,j,k,bi,bj).lt.100 .and.
178			. tilefrac(i,j,k,bi,bj).gt.0.) then
179	molod	1.18	nchpland(bi,bj) = nchpland(bi,bj) + 1
180			igrd (nchpland(bi,bj),bi,bj) = i + (j-1)*im
181			ityp (nchpland(bi,bj),bi,bj) = surftype(i,j,k,bi,bj)
182			chfr (nchpland(bi,bj),bi,bj) = tilefrac(i,j,k,bi,bj)
183			chlon(nchpland(bi,bj),bi,bj) = lons(i,j,bi,bj)
184			chlt (nchpland(bi,bj),bi,bj) = lats(i,j,bi,bj)
185	edhill	1.14	endif
186			enddo
187			enddo
188			enddo
189
190			c ocean points
191			c ------------
192	molod	1.18	nchptot(bi,bj) = nchpland(bi,bj)
193	edhill	1.14
194			do k=1,maxtyp
195			do j=1,jm
196			do i=1,im
197			if(surftype(i,j,k,bi,bj).ge.100 .and.
198			. tilefrac(i,j,k,bi,bj).gt.0.) then
199	molod	1.18	nchptot(bi,bj) = nchptot(bi,bj) + 1
200			igrd (nchptot(bi,bj),bi,bj) = i + (j-1)*im
201			ityp (nchptot(bi,bj),bi,bj) = surftype(i,j,k,bi,bj)
202			chfr (nchptot(bi,bj),bi,bj) = tilefrac(i,j,k,bi,bj)
203			chlon(nchptot(bi,bj),bi,bj) = lons(i,j,bi,bj)
204			chlt (nchptot(bi,bj),bi,bj) = lats(i,j,bi,bj)
205	edhill	1.14	endif
206			enddo
207			enddo
208			enddo
209
210	molod	1.18	print *,'Number of Total Tiles for bi=',bi,': ',nchptot(bi,bj)
211			print *,'Number of Land Tiles for bi=',bi,': ',nchpland(bi,bj)
212
213	edhill	1.14	ENDDO
214	molod	1.2	ENDDO
215	edhill	1.14
216	molod	1.1	RETURN
217			END