! ! ### ####### ! # # # ##### # # ##### # # # # ##### ##### # # ##### ! # ## # # # # # # # # # # # # # # # # ! # # # # # # # # # # # # # # # # # # # ! # # # # ##### # # # # # # # # ##### # # # ! # # ## # # # # # # # # # # # # # ! ### # # # #### # ####### #### # # #### # ! ! $Author: pkubota $ ! $Date: 2008/09/23 17:51:54 $ ! $Revision: 1.9 $ ! MODULE InputOutput USE Constants, Only: & r8,r4,i4, & i8 USE IOLowLevel, Only: & ReadGetSLM USE Utils, Only: & AveBoxIJtoIBJB,IJtoIBJB USE Options, Only: & labelsi,labelsj,monl,yrl IMPLICIT NONE PUBLIC :: getsbc INTERFACE getsbc MODULE PROCEDURE getsbc_CPL, getsbc_OFFLINE END INTERFACE CONTAINS SUBROUTINE InitInputOutput () END SUBROUTINE InitInputOutput ! ! getsbc :read surface/atmosphere boundary conditions. ! SUBROUTINE getsbc_CPL (imax,jmax,kmax,galb ,gsst ,gndvi,gslm,gsnw,gozo,wsib3d,& ifday,tod,idate,idatec,& ifalb,ifsst,ifndvi,ifslm,ifslmSib2,ifsnw,ifozone,& sstlag,intsst,intndvi,fint,tice,& yrl ,monl,ibMax,jbMax,ibMaxPerJB) IMPLICIT NONE ! ! INPUT/OUTPUT VARIABLES ! ! Real size of the grid INTEGER, INTENT(in ) :: imax INTEGER, INTENT(in ) :: jmax INTEGER, INTENT(in ) :: kmax ! Size of block divided grid INTEGER, INTENT(in ) :: ibMax INTEGER, INTENT(in ) :: jbMax INTEGER, INTENT(in ) :: ibMaxPerJB(:) ! Boundary fields output REAL(KIND=r8), INTENT(out ) :: galb (ibMax,jbMax) ! albedo REAL(KIND=r8), INTENT(out ) :: gndvi (ibMax,jbMax) ! ndvi REAL(KIND=r8), INTENT(out ) :: gsst (ibMax,jbMax) ! sst REAL(KIND=r8), INTENT(out ) :: gslm (ibMax,jbMax) ! soil moisture REAL(KIND=r8), INTENT(out ) :: gsnw (ibMax,jbMax) ! snow REAL(KIND=r8), INTENT(out ) :: wsib3d(ibMax,jbMax,3) ! moisture !hmjb o ozonio nao pode ser apenas 'out' pois, no caso de usar a antiga ! getoz(), ele sairia daqui com valores indefinidos... Com inout, ! ele entra e, se nao for alterado, sai como entrou REAL(KIND=r8), INTENT(inout) :: gozo(ibMax,kMax,jbMax) ! ozone ! Options for reading boundary fields INTEGER, INTENT(inout) :: ifalb INTEGER, INTENT(inout) :: ifsst INTEGER, INTENT(inout) :: ifndvi INTEGER, INTENT(inout) :: ifslm INTEGER, INTENT(inout) :: ifsnw INTEGER, INTENT(inout) :: ifslmSib2 INTEGER, INTENT(inout) :: ifozone ! Time INTEGER, INTENT(in ) :: ifday REAL(KIND=r8), INTENT(in ) :: tod INTEGER, INTENT(in ) :: idate(4) INTEGER, INTENT(in ) :: idatec(4) REAL(KIND=r8), INTENT(in ) :: sstlag INTEGER, INTENT(in ) :: intsst INTEGER, INTENT(in ) :: intndvi REAL(KIND=r8), INTENT(in ) :: fint REAL(KIND=r8), INTENT(in ) :: tice REAL(KIND=r8), INTENT(in ) :: yrl INTEGER, INTENT(in ) :: monl(12) ! ! LOCAL VARIABLES ! REAL(KIND=r8) :: xndvi (ibMax,jbMax) REAL(KIND=r8) :: xsst (ibMax,jbMax) REAL(KIND=r8) :: bfr_in (imax,jmax) REAL(KIND=r8) :: bfrw_in (imax,jmax,3) REAL(KIND=r8) :: bfrw_out (ibmax,jbmax,3) REAL(KIND=r4) :: rbrfw3d (iMax,jMax,3) REAL(KIND=r8) :: bfr_in3 (imax,kmax,jmax) REAL(KIND=r8) :: bfr_out (ibMax,jbMax) REAL(KIND=r8) :: bfr_out3(ibMax,kmax,jbMax) REAL(KIND=r4) :: rbrf (iMax,jMax) REAL(KIND=r4) :: rbrf3 (iMax,kmax,jMax) ! ! INTEGER :: lrecl,LRecIn REAL(KIND=r8) :: fhr INTEGER :: mf INTEGER :: mn INTEGER :: mf_ndvi INTEGER :: mn_ndvi INTEGER :: month INTEGER :: mm INTEGER :: i INTEGER :: j INTEGER :: k INTEGER :: irec INTEGER :: irec_ndvi REAL(KIND=r8) :: f1 REAL(KIND=r8) :: f2 REAL(KIND=r8) :: f1_ndvi REAL(KIND=r8) :: f2_ndvi REAL(KIND=r8) :: gmax REAL(KIND=r8) :: gmin REAL(KIND=r8) :: fsst REAL(KIND=r8) :: fndvi REAL(KIND=r8) :: fisst REAL(KIND=r8) :: findvi REAL(KIND=r8) :: xx1 REAL(KIND=r8) :: xx2 REAL(KIND=r8) :: xday INTEGER :: ierr galb =0.0_r8 gndvi =0.0_r8 gsst =0.0_r8 gslm =0.0_r8 gsnw =0.0_r8 wsib3d =0.0_r8 END SUBROUTINE getsbc_CPL SUBROUTINE getsbc_OFFLINE(iMax,jMax,ibMax,jbMax,ibMaxPerJB,idate,idatec,tod,ifday,ifsst,& ifslm,nfslm,nfslmtp,intsst,nfprt,nfctrl,fNameSoilms,fNameSoilmsWkl,reducedGrid,fint,gslm,wsib3d) IMPLICIT NONE INTEGER , INTENT(in ) :: iMax INTEGER , INTENT(in ) :: jMax INTEGER , INTENT(in ) :: ibMax INTEGER , INTENT(in ) :: jbMax INTEGER, INTENT(in ) :: ibMaxPerJB(:) INTEGER , INTENT(in ) :: idate(:) INTEGER , INTENT(in ) :: idatec(:) REAL(KIND=r8), INTENT(in ) :: tod INTEGER , INTENT(in ) :: ifday INTEGER , INTENT(in ) :: ifsst INTEGER , INTENT(inout) :: ifslm INTEGER , INTENT(in ) :: intsst INTEGER , INTENT(in ) :: nfslm INTEGER , INTENT(in ) :: nfslmtp INTEGER , INTENT(in ) :: nfprt INTEGER , INTENT(in ) :: nfctrl(:) CHARACTER(LEN=*), INTENT(in ) :: fNameSoilms CHARACTER(LEN=*), INTENT(in ) :: fNameSoilmsWkl LOGICAL , INTENT(in ) :: reducedGrid REAL(KIND=r8), INTENT(in ) :: fint REAL(KIND=r8), INTENT(out ) :: gslm(ibMax,jbMax) ! soil moisture REAL(KIND=r8), INTENT(out ) :: wsib3d(ibMax,jbMax,50) ! moisture INTEGER :: lrecl INTEGER :: LRecIn INTEGER :: ierr INTEGER :: irec INTEGER :: mf INTEGER :: mn INTEGER :: i INTEGER :: j REAL(KIND=r8) :: fhr REAL(KIND=r4) :: rbrf (iMax,jMax) REAL(KIND=r8) :: bfr_in (imax,jmax) REAL(KIND=r8) :: bfr_out (ibMax,jbMax) REAL(KIND=r8) :: gmax REAL(KIND=r8) :: gmin REAL(KIND=r8) :: f1 REAL(KIND=r8) :: f2 IF (ifsst == 4 .AND. intsst <= 0) THEN CALL GetRecWgtMonthlySST & (idate, idatec, tod, labelsi, labelsj, & irec, f1, f2, mf, mn,monl) !!$ WRITE (UNIT=nfprt, FMT='(A)') ' GetRecWgtMonthlySST' !!$ WRITE (UNIT=nfprt, FMT='(/,4(A,I5),/)') & !!$ ' reci = ', irec, ' recf = ', irec+1, & !!$ ' mra = ', mf, ' mrb = ', mf+1 !!$ WRITE (UNIT=nfprt, FMT=*) ' fa (*mra) = ', f1, ' fb (*mrb) = ', f2 ELSE CALL GetWeightsOld(yrl,monl,idatec, tod, f1, f2,mf) !!$ WRITE (UNIT=nfprt, FMT=*) ' fa (*mra) = ', f1, ' fb (*mrb) = ', f2 END IF ! ! process soil moisture file ! IF (ifslm /= 0) THEN IF (ifslm == 1) THEN ! ifxxx=1 xxx is set to month=idatec(2) in the first call, ! but not processed from the subsequent calls. ! ifxxx is set to zero after interpolation INQUIRE (IOLENGTH=LRecIn) rbrf !--------------------------- OPEN (UNIT=nfslm,FILE=TRIM(fNameSoilmsWkl),FORM='UNFORMATTED', ACCESS='DIRECT', & ACTION='read', RECL=LRecIn, STATUS='OLD', IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameSoilmsWkl), ierr STOP "**(ERROR)**" END IF ! irec correspond the record by soil layer DO irec=1,8 CALL ReadGetSLM(nfslm,irec,bfr_in) IF (reducedGrid) THEN CALL AveBoxIJtoIBJB(bfr_in,gslm) ELSE CALL IJtoIBJB(bfr_in,gslm) END IF DO j=1,jbMax DO i=1,ibMaxPerJB(j) wsib3d(i,j,8+1-irec)=gslm(i,j) END DO END DO END DO CLOSE(UNIT=nfslm) !--------------------------- INQUIRE (IOLENGTH=LRecIn) rbrf OPEN (UNIT=nfslm,FILE=TRIM(fNameSoilms),FORM='UNFORMATTED', ACCESS='DIRECT', & ACTION='read', RECL=LRecIn, STATUS='OLD', IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameSoilms), ierr STOP "**(ERROR)**" END IF irec=idate(2) CALL ReadGetSLM(nfslm,irec,bfr_in) IF (reducedGrid) THEN CALL AveBoxIJtoIBJB(bfr_in,gslm) ELSE CALL IJtoIBJB(bfr_in,gslm) END IF CLOSE(UNIT=nfslm) ifslm=0 ELSE IF (ifslm == 2.OR. & (ifslm == 3.AND.tod == 0.0_r8.AND.ifday == 0)) THEN INQUIRE (IOLENGTH=LRecIn) rbrf OPEN (UNIT=nfslm,FILE=TRIM(fNameSoilms),FORM='UNFORMATTED', ACCESS='DIRECT', & ACTION='read', RECL=LRecIn, STATUS='OLD', IOSTAT=ierr) IF (ierr /= 0) THEN WRITE(UNIT=nfprt,FMT="('**(ERROR)** Open file ',a,' returned iostat=',i4)") & TRIM(fNameSoilms), ierr STOP "**(ERROR)**" END IF irec=idate(2) CALL ReadGetSLM(nfslm,irec,bfr_in) IF (reducedGrid) THEN CALL AveBoxIJtoIBJB(bfr_in,gslm) ELSE CALL IJtoIBJB(bfr_in,gslm) END IF IF (irec == 12) THEN irec=1 ELSE irec=irec+1 END IF CALL ReadGetSLM(nfslm,irec,bfr_in) IF (reducedGrid) THEN CALL AveBoxIJtoIBJB(bfr_in,bfr_out) ELSE CALL IJtoIBJB(bfr_in,bfr_out) END IF CLOSE(UNIT=nfslm) gmax=-1.0e10_r8 gmin=+1.0e10_r8 DO j=1,jbMax DO i=1,ibMaxPerJB(j) gslm(i,j)=f2*gslm(i,j)+f1*bfr_out(i,j) gmax=MAX(gmax,gslm(i,j)) gmin=MIN(gmin,gslm(i,j)) END DO END DO IF (ifslm == 3.AND.tod == 0.0_r8.AND.ifday == 0) THEN ifslm=0 END IF IF (nfctrl(23) >= 1) THEN WRITE(UNIT=nfprt,FMT=222) mf,f1,f2,gmax,gmin END IF ELSE WRITE(UNIT=nfprt,FMT=333) STOP END IF END IF 222 FORMAT(' SOILM START MONTH=',i2,' F1,F2=',2f6.3,' MAX,MIN=',2e12.5) 223 FORMAT(' OZONE START MONTH=',i2,' F1,F2=',2f6.3,' MAX,MIN=',2e12.5) 333 FORMAT(' ABNORMAL END IN SUBR.GETSBC AT SOILM INTERPOLATION') END SUBROUTINE getsbc_OFFLINE SUBROUTINE GetRecWgtMonthlySST & (idate, idatec, tod, labelsi, labelsj, & irec, f1, f2, mra, mrb,monl) IMPLICIT NONE ! Computes the Corresponding Records to do Linear ! Time Interpolation and the Respectives Weights. INTEGER, INTENT (IN) :: idate(4), idatec(4),monl(12) REAL (KIND=r8), INTENT (IN) :: tod CHARACTER (LEN=10), INTENT (IN) :: labelsi, labelsj INTEGER, INTENT (OUT) :: irec, mra, mrb REAL (KIND=r8), INTENT (OUT) :: f1, f2 ! Local Constants INTEGER :: ysi, msi, dsi, ysj, msj, dsj, ndij, nd, & tmca, tmcb, tmcf REAL (KIND=r8) :: xday, zdayf, zdaya, zdayb, tc ! Get Year, Month and Day of the Initial and Second Medium Date ! for SST Direct Access File Data READ (labelsi(1:4), '(I4)') ysi READ (labelsi(5:6), '(I2)') msi READ (labelsi(7:8), '(I2)') dsi READ (labelsj(1:4), '(I4)') ysj READ (labelsj(5:6), '(I2)') msj READ (labelsj(7:8), '(I2)') dsj ! Lag of Days for SST Data: ! Just for Checking if the Scale is a Month ndij=0 IF (msi+1 <= msj-1) THEN DO nd=msi+1,msj-1 ndij=ndij+monl(nd) END DO ELSE DO nd=msi+1,12 ndij=ndij+monl(nd) END DO DO nd=1,msj-1 ndij=ndij+monl(nd) END DO END IF ndij=ndij+monl(msi)-dsi+dsj+365*(ysj-ysi-1) ! Check for Monthly Scale SST Data IF (ABS(ndij) <= 27 .OR. ABS(ndij) >= 32) THEN WRITE (UNIT=0, FMT='(/,A)') ' *** Error: The SST Data Is Not On Monthly Scale ***' WRITE (UNIT=0, FMT='(/,A,I8,12X,A,/)') ' *** Lag Of Days For SST Data: ', ndij, '***' WRITE (UNIT=0, FMT='(A,/)') ' *** Program STOP: SUBROUTINE GetRecWgtMonthlySST ***' STOP END IF ! Length in Days of the Date of Forecasting tmcf=monl(idatec(2)) IF (idatec(2) == 2 .AND. MOD(idatec(4),4) == 0) tmcf=29 ! Medium Day of the Month of Forecasting zdayf=0.5_r8*REAL(tmcf,r8)+1.0_r8 ! Fractional Day of Forecasting tc=REAL(idate(1),r8)/24.0_r8+tod/86400.0_r8 ! Correcting Factor if Necessary (tc is in Days) IF (tc >= 1.0_r8) tc=tc-1.0_r8 xday=REAL(idatec(3),r8)+tc ! Getting the Corresponding Record in SST Data irec=12-msi+idatec(2)+12*(idatec(4)-ysi-1)+2 IF (xday >= zdayf) irec=irec+1 ! Months for the Linear Time Interpolation Related to the Records mra=MOD(irec-3+msi,12) IF (mra == 0) mra=12 mrb=mra+1 IF (mrb > 12) mrb=1 ! Length in Days for the First Month of Interpolation tmca=monl(mra) IF (mra == 2 .AND. MOD(ysi,4) == 0) tmca=29 ! Medium Fracitonal Day for the First Month of Interpolation zdaya=0.5_r8*REAL(tmca,r8)+1.0_r8-REAL(tmca,r8) ! Length in Days for the Second Month of Interpolation tmcb=monl(mrb) IF (mrb == 2 .AND. MOD(ysj,4) == 0) tmcb=29 ! Medium Fracitonal Day for the Second Month of Interpolation zdayb=0.5_r8*REAL(tmcb,r8)+1.0_r8 ! Scaling Fractional Day of Forecasting, if Necessary IF (xday >= zdayf) xday=xday-REAL(tmca,r8) ! Interpolation Factors f1=(xday-zdaya)/(zdayb-zdaya) f2=1.0_r8-f1 END SUBROUTINE GetRecWgtMonthlySST SUBROUTINE GetWeightsOld (yrl,monl,idatec, tod, f1, f2,mf) IMPLICIT NONE ! Computes Weights as in getsbc: INTEGER, PARAMETER :: r8 = SELECTED_REAL_KIND(15) INTEGER, INTENT (IN) :: idatec(4) INTEGER, INTENT (IN) :: monl(12) REAL (KIND=r8), INTENT (IN) :: tod REAL (KIND=r8), INTENT (IN) :: yrl REAL (KIND=r8), INTENT (OUT) :: f1, f2 INTEGER, INTENT (OUT):: mf INTEGER :: mon, mnl, mn, mnlf, mnln REAL (KIND=r8) :: yday, add LOGICAL :: ly mon=idatec(2) yday=REAL(idatec(3),r8)+REAL(idatec(1),r8)/24.0_r8+MOD(tod,3600.0_r8)/86400.0_r8 mf=mon-1 ly= yrl == 365.25_r8 .AND. MOD(idatec(4),4) == 0 mnl=monl(mon) IF (ly .AND. mon == 2) mnl=29 ! Em getsbc seria apenas > ! As consideracoes de interpolacao leva a >= IF (yday >= 1.0_r8+0.5_r8*REAL(mnl,r8)) mf=mon mn=mf+1 IF (mf < 1) mf=12 IF (mn > 12) mn=1 mnlf=monl(mf) IF (ly .AND. mf == 2) mnlf=29 add=0.5_r8*REAL(mnlf,r8)-1.0_r8 IF (mf == mon) add=-add-2.0_r8 mnln=monl(mn) IF (ly .AND. mn == 2) mnln=29 f1=2.0_r8*(yday+add)/REAL(mnlf+mnln,r8) f2=1.0_r8-f1 END SUBROUTINE GetWeightsOld END MODULE InputOutput