program writeveg REAL*4 FPAR1(2500,1250) REAL TPH0D,TLM0D,DLMD,DPHD,WBD,SBD,DT INTEGER KPDS(200),KGDS(200),JPDS(200),JGDS(200),KF,KNUM INTEGER i LOGICAL BITMAP(2500,1250) INCLUDE "parmeta" PARAMETER (IMJM = IM*JM - JM/2, L0=2500*1250) REAL*4 VEGFRM(imjm) ! monthly veg greeness DIMENSION SM(IMJM),SICE(IMJM) Chou Chou included undef and icethreshold to create sea-land-ice mask P A R A M E T E R & (undef=-999., ziceth=270.2) Chou P A R A M E T E R & (ITB=076,JTB=134,ITBQ=152,JTBQ=440) P A R A M E T E R & (IM2=IM-2,JM1=JM-1,JM2=JM-2,JM3=JM-3,JM4=JM-4,JM5=JM-5 &, JAM=6+2*(JM-10) &, KHN=IM-1,KHS=-IM &, KNE=IM ,KNW=IM-1 ,KSW=-IM ,KSE=-IM+1 &, KHL00=1 ,KHH00=IM*JM-JM/2 ) C----------------------------------------------------------------------- D I M E N S I O N & KHL0 (JM),KHH0 (JM),KVL0 (JM),KVH0 (JM) &,KHL1 (JM),KHH1 (JM),KVL1 (JM),KVH1 (JM) &,KHL3 (JM),KHH3 (JM),KVL3 (JM),KVH3 (JM) &,KHL4 (JM),KHH4 (JM),KVL4 (JM),KVH4 (JM) &,KHL5 (JM),KHH5 (JM),KVL5 (JM),KVH5 (JM) &,KHL6 (JM),KHH6 (JM),KVL6 (JM),KVH6 (JM) &,DXJ (JM),WPDARJ(JM),CPGFUJ(JM),CURVJ (JM),FCPJ (JM) &,FDIVJ (JM),EMJ (JM),EMTJ (JM),FADJ (JM) &,DDMPUJ(JM),DDMPVJ(JM),HDACJ (JM) D I M E N S I O N & KHLA (JAM),KHHA (JAM),KVLA (JAM),KVHA (JAM) &,KHL2 (JM),KHH2 (JM),KVL2 (JM),KVH2 (JM) &,GLAT(IMJM), GLON(IMJM) D I M E N S I O N & RDETA (LM),F4Q2 (LM) &,EM (JAM),EMT (JAM) c TPH0D=-19.5 c TLM0D=-54.5 c DLMD=.2777777770000 c DPHD=.2631578940000 c WBD=-32.7777776860000 c SBD=-32.6315788560000 c DT=90. TLM0D=-60.0 TPH0D=-16.0 DLMD=.28846153850000000000 DPHD=.26923076950000000000 WBD=-65.19231 SBD=-47.11539 DT=90. C--------------DERIVED GEOMETRICAL CONSTANTS---------------------------- DTR=3.1415/180. TPH0=TPH0D*DTR WB=WBD*DTR SB=SBD*DTR DLM=DLMD*DTR DPH=DPHD*DTR TDLM=DLM+DLM TDPH=DPH+DPH RDLM=1./DLM RDPH=1./DPH C WBI=WB+TDLM SBI=SB+TDPH EBI=WB+IM2*TDLM ANBI=SB+JM3*DPH C STPH0=SIN(TPH0) CTPH0=COS(TPH0) C---------------TIME STEPPING RELATED CONSTANTS------------------------- TSPH=3600./DT NDDAMP=TDDAMP*TSPH+.5 C DTAD=IDTAD DTCF=IDTCF C--------------DERIVED HORIZONTAL GRID CONSTANTS------------------------ DY=A*DPH CPGFV=-DT/(48.*DY) EN= DT/( 4.*DY)*DTAD ENT=DT/(16.*DY)*DTAD C TPH=SB-DPH DO 140 J=1,JM C KHL0(J)=IM*(J-1)-(J-1)/2+1 KVL1(J)=IM*(J-1)-(J-1)/2+1 KHL2(J)=IM*(J-1)-(J-1)/2+2 KVL3(J)=IM*(J-1)-(J-1)/2+2 KHL4(J)=IM*(J-1)-(J-1)/2+3 KVL5(J)=IM*(J-1)-(J-1)/2+3 KHL6(J)=IM*(J-1)-(J-1)/2+4 C KVL0(J)=IM*(J-1)-J/2+1 KHL1(J)=IM*(J-1)-J/2+2 KVL2(J)=IM*(J-1)-J/2+2 KHL3(J)=IM*(J-1)-J/2+3 KVL4(J)=IM*(J-1)-J/2+3 KHL5(J)=IM*(J-1)-J/2+4 KVL6(J)=IM*(J-1)-J/2+4 C KHH0(J)=IM*J-J/2 KHH2(J)=IM*J-J/2-1 KVH1(J)=IM*J-J/2-1 KHH4(J)=IM*J-J/2-2 KVH3(J)=IM*J-J/2-2 KHH6(J)=IM*J-J/2-3 KVH5(J)=IM*J-J/2-3 C KHH1(J)=IM*J-(J+1)/2 KVH0(J)=IM*J-(J+1)/2 KHH3(J)=IM*J-(J+1)/2-1 KVH2(J)=IM*J-(J+1)/2-1 KHH5(J)=IM*J-(J+1)/2-2 KVH4(J)=IM*J-(J+1)/2-2 KVH6(J)=IM*J-(J+1)/2-3 C TPH=TPH+DPH DXP=A*DLM*COS(TPH) DXJ(J)=DXP CVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV C WPDARJ(J)=-DT*W*100000./(32.*DXP*DY) WPDARJ(J)=-W*((A*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+DY**2) 2 /(DT*32.*DXP*DY)*.88 C 2 /(DT*32.*DXP*DY) CAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA CPGFUJ(J)=-DT/(48.*DXP) CURVJ(J)=.5*DT*TAN(TPH)/A FCPJ(J)=DT/(CP*192.*DXP*DY) FDIVJ(J)=1./(12.*DXP*DY) EMJ(J)= DT/( 4.*DXP)*DTAD EMTJ(J)=DT/(16.*DXP)*DTAD FADJ(J)=-DT/(48.*DXP*DY)*DTAD CVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV C ACDT=COAC*DT*DTCF C ACDT=COAC*DT C 2 *SQRT((A*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+DY**2) ACDT=DT 2 *SQRT((A*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+DY**2) CAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA C CDDAMP=CODAMP*ACDT CDDAMP=0.04*CODAMP*ACDT C HDACJ(J)=ACDT/(4.*DXP*DY) HDACJ(J)=COAC*ACDT/(4.*DXP*DY) DDMPUJ(J)=CDDAMP/DXP DDMPVJ(J)=CDDAMP/DY 140 CONTINUE C--------------SPREADING OF UPSTREAM HEIGHT-POINT ADVECTION FACTOR------ JA=0 DO 161 J=3,5 JA=JA+1 KHLA(JA)=KHL2(J) KHHA(JA)=KHH2(J) 161 EMT(JA)=EMTJ(J) DO 162 J=JM4,JM2 JA=JA+1 KHLA(JA)=KHL2(J) KHHA(JA)=KHH2(J) 162 EMT(JA)=EMTJ(J) DO 163 J=6,JM5 JA=JA+1 KHLA(JA)=KHL2(J) KHHA(JA)=KHL3(J) 163 EMT(JA)=EMTJ(J) DO 164 J=6,JM5 JA=JA+1 KHLA(JA)=KHH3(J) KHHA(JA)=KHH2(J) 164 EMT(JA)=EMTJ(J) C--------------SPREADING OF UPSTREAM VELOCITY-POINT ADVECTION FACTOR---- JA=0 DO 171 J=3,5 JA=JA+1 KVLA(JA)=KVL2(J) KVHA(JA)=KVH2(J) 171 EM(JA)=EMJ(J) DO 172 J=JM4,JM2 JA=JA+1 KVLA(JA)=KVL2(J) KVHA(JA)=KVH2(J) 172 EM(JA)=EMJ(J) DO 173 J=6,JM5 JA=JA+1 KVLA(JA)=KVL2(J) KVHA(JA)=KVL3(J) 173 EM(JA)=EMJ(J) DO 174 J=6,JM5 JA=JA+1 KVLA(JA)=KVH3(J) KVHA(JA)=KVH2(J) 174 EM(JA)=EMJ(J) C--------------CORIOLIS PARAMETER IN TLL SYSTEM & RELATED CONSTANTS----- TPH=SB-DPH DO 180 J=1,JM KVL=KVL0(J) KVH=KVH0(J) C TLM=WB-TDLM+MOD(J,2)*DLM TPH=TPH+DPH STPH=SIN(TPH) CTPH=COS(TPH) C DO 180 K=KVL,KVH TLM=TLM+TDLM FP=TWOM*(CTPH0*STPH+STPH0*CTPH*COS(TLM)) 180 continue C--------------GEOGRAPHIC LAT AND LONG OF TLL GRID POINTS----------- TPH=SB-DPH DO 183 J=1,JM KHL=KHL0(J) KHH=KHH0(J) C TLM=WB-TDLM+MOD(J+1,2)*DLM TPH=TPH+DPH STPH=SIN(TPH) CTPH=COS(TPH) C DO 183 K=KHL,KHH TLM=TLM+TDLM SINPHI=CTPH0*STPH+STPH0*CTPH*COS(TLM) GLAT(K)=ASIN(SINPHI) COSLAM=CTPH*COS(TLM)/(COS(GLAT(K))*CTPH0)-TAN(GLAT(K))* 1 TAN(TPH0) IF(COSLAM.GT.H1)COSLAM=H1 IF(COSLAM.LT.-1.)COSLAM=-1. FACT=H1 IF(TLM.GT.D00)FACT=HM1 GLON(K)=-TLM0D*DTR+FACT*ACOS(COSLAM) 183 CONTINUE CALL BAOPEN(38,'veg.eta.grb',IERR) JPDS = -1 WRITE(6,*) KPDS OPEN(80,file='VEG_12.bin',form='unformatted', & status='unknown') OPEN(83,file='VGREEN_greta_12mo.dat',form='unformatted', & status='unknown') do i=1,12 CALL GETGB(38,0,2500*1250,i-1,JPDS,JGDS,KF,KNUM, & KPDS,KGDS,BITMAP,FPAR1,IERR) WRITE(13,*) i, KPDS, KGDS, JGDS, KF, KNUM WRITE(13,*) 'AFTER GETGB FOR MONTH ', i,' IRET=', IERR WRITE(80) FPAR1 C interpolate to Egrid. CALL PUTVEG(TLM0D,TPH0D,DLMD,DPHD,glat,glon, & FPAR1,SM,SICE,vegfrm) write(83) vegfrm enddo END