SUBROUTINE QUILT !>-------------------------------------------------------------------------------------------------- !> SUBROUTINE QUILT !> !> SUBROUTINE: QUILT - I/O SERVERS !> PROGRAMMER: TUCCILLO !> ORG: IBM !> DATE: 00-01-20 !> !> ABSTRACT: !> I/O SERVERS !> !> PROGRAM HISTORY LOG: !> 00-01-20 TUCCILLO - ORIGINATOR !> 00-11-02 BLACK - SLP FOR NEST BOUNDARIES !> 00-12-12 BLACK - RESTART CAPABILITY !> 18-01-15 LUCCI - MODERNIZATION OF THE CODE, INCLUDING: !> * F77 TO F90/F95 !> * INDENTATION & UNIFORMIZATION CODE !> * REPLACEMENT OF COMMONS BLOCK FOR MODULES !> * DOCUMENTATION WITH DOXYGEN !> * OPENMP FUNCTIONALITY !> !> INPUT ARGUMENT LIST: !> NONE !> !> OUTPUT ARGUMENT LIST: !> NONE !> !> INPUT FILES: NONE !> !> OUTPUT FILES: NONE !> !> USE MODULES: BUFFER !> F77KINDS !> GLB_TABLE !> MAPPINGS !> MPPCOM !> PARA !> PARMETA !> PARMSOIL !> TEMPCOM !> TOPO !> !> DRIVER : EBU !> !> CALLS : COLLECT !> DECOAL !> GETENV !> MPI_ABORT !> MPI_BCAST !> MPI_FIRST !> MPI_RECV !> SLP !> SLPSIG !> SLPSIGSPLINE !-------------------------------------------------------------------------------------------------- ! !--------------------------------------------------------------------------------- ! THIS CODE ASSUMES THAT NSOIL IS GE TO 4. IF THIS IS NOT TRUE,THE CODE WILL STOP. ! THE EQUIVALENCING IS THE PROBLEM. !--------------------------------------------------------------------------------- USE BUFFER USE F77KINDS USE GLB_TABLE USE MAPPINGS USE MPPCOM USE PARA USE PARMETA USE PARMSOIL USE TEMPCOM USE TOPO ! IMPLICIT NONE ! INCLUDE "mpif.h" ! INTEGER(KIND=I4KIND), PARAMETER :: LB = 2 * IM + JM - 3 ! REAL (KIND=R4KIND), DIMENSION(IM, JM) ::& & DUM1 , DUM2 , DUM3 , DUM4 , DUM5 , DUM6 , DUM7 !--------- ! SM v100M !--------- REAL (KIND=R4KIND), DIMENSION(IM, JM) ::& & DUM8 , DUM9 , DUM10 , DUM11 !--------- ! SM v100M !--------- ! Lyra GSM Wind stress REAL (KIND=R4KIND), DIMENSION(IM, JM) ::& & DUM12 , DUM13 ! Lyra GSM Wind stress ! REAL (KIND=R4KIND), DIMENSION(IM, JM, NSOIL) ::& & DUMS ! INTEGER(KIND=I4KIND), DIMENSION(MPI_STATUS_SIZE) ::& & STATUS ! EQUIVALENCE (DUM1(1,1), DUMS(1,1,1)) EQUIVALENCE (DUM2(1,1), DUMS(1,1,2)) EQUIVALENCE (DUM3(1,1), DUMS(1,1,3)) EQUIVALENCE (DUM4(1,1), DUMS(1,1,4)) ! REAL (KIND=R4KIND), DIMENSION(:,:), ALLOCATABLE ::& & PDOMG , RESOMG , PD , RES , FIS , & & RSWIN , RSWOUT , TG , Z0 , AKMS , & & CZEN , AKHS , THS , QS , TWBS , & & QWBS , HBOT , CFRACL , THZ0 , QZ0 , & & UZ0 , VZ0 , USTAR , HTOP , CFRACM , & & SNO , SI , CLDEFI , RF , PSLP , & & CUPPT , CFRACH , SOILTB , SFCEXC , & & SMSTAV , SMSTOT , GRNFLX , PCTSNO , & & RLWIN , RADOT , CZMEAN , SIGT4 , & & U00 , SR , PREC , ACPREC , ACCLIQ , & & CUPREC , ACFRCV , ACFRST , SFCSHX , & & ACSNOW , ACSNOM , SSROFF , BGROFF , & & SFCLHX , SUBSHX , SNOPCX , SFCUVX , & & SFCEVP , POTEVP , ASWIN , ASWOUT , & & ASWTOA , ALWIN , ALWOUT , ALWTOA , & !--------- ! SM v100M !--------- & TH100 , Q100 , U100 , V100 , & !--------- ! SM v100M !--------- ! Lyra GSM Wind stress & XMOMFLUX, YMOMFLUX, & ! Lyra GSM Wind stress ! & TH10 , Q10 , U10 , V10 , TSHLTR , & & QSHLTR , PSHLTR , CMC , POTFLX , & & TLMIN , TLMAX , RSWTOA , RLWTOA , & & CNVBOT , CNVTOP , ALBEDO , & ! !Lyra GSM Max wind & MAXWU , MAXWV, & !Lyra GSM Max wind ! & SM , HBM2 REAL (KIND=R4KIND), DIMENSION(:), ALLOCATABLE ::& & DETA ! REAL (KIND=R4KIND), DIMENSION(2*LM) ::& & UL ! REAL (KIND=R4KIND), DIMENSION(:,:,:), ALLOCATABLE ::& & OMGALF , T , Q , U , V , Q2 , TTND , CWM , TRAIN , & & TCUCN , RSWTT , RLWTT , SMC , STC , SH2O ! REAL (KIND=R4KIND), DIMENSION(LB, 2) ::& & PDB ! REAL (KIND=R4KIND), DIMENSION(LB, LM, 2) ::& & TB , QB , UB , VB , Q2B , CWMB ! INTEGER(KIND=I4KIND), DIMENSION(3) ::& & IDAT ! INTEGER(KIND=I4KIND), DIMENSION(:,:), ALLOCATABLE ::& & LC , NCFRCV , NCFRST ! LOGICAL(KIND=L4KIND) ::& & RUN , FIRST , HYDRO , SIGMA ! CHARACTER(LEN= 56) :: RSTFIL1 , RSTFIL2 , ENVAR , FINFIL CHARACTER(LEN= 8) :: RESTHR , BLANK CHARACTER(LEN= 32) :: LABEL CHARACTER(LEN= 80) :: FNAME CHARACTER(LEN= 16) :: DONE ! CHARACTER(LEN=200) :: SUBMIT !CHOU CHARACTER(LEN=200) :: CHMO CHARACTER(LEN= 88) :: LINE CHARACTER(LEN= 32) :: OUTJOB ! LOGICAL(KIND=L4KIND) ::& & LME , OUTJ ! DATA LRSTRT1/21/, LRSTRT2/61/, NHB/12/, BLANK/' '/ ! REAL (KIND=R8KIND) ::& & TIMEF , IST , ISP , RTC , IST2 , ISP2 , ICUM ! REAL (KIND=R4KIND), DIMENSION(999999) ::& & TSHDE ! REAL (KIND=R4KIND), DIMENSION(LSM) ::& & SPL ! LOGICAL(KIND=L4KIND) ::& & RESTRT , SINGLRST, SUBPOST , NEST , SPLINE !------------------------ ! IMPLICIT NONE VARIABLES !------------------------ INTEGER(KIND=I4KIND) ::& & LRSTRT1 , LRSTRT2 , NHB , NMAP , NPHS , NCNVC , NRADSH , NRADLH , NTDDMP , & & LFCSTD , IERR , NFCST , NBC , LIST , IDTAD , IHOUR , IER , IXXX , & & IPE , IS , IE , JS , JE , LEN_CH , IDUM , IHRST , NTSD , & & L , IOUT , NSHDE , NHEAT , NPREC , NRDSW , NSRFC , KPATH , KRST , & & ITAG , LFINFIL , NRDLW ! REAL (KIND=R4KIND) ::& & TSTART , TEND , TCP , TPREC , THEAT , TCLOD , TRDSW , TRDLW , TSRFC , & & DT , ARDSW , ARDLW , ASRFC , AVRAIN , AVCNVC , ACUTIM , ARATIM , APHTIM , & & TPH0D , TLM0D , PT !----------------- ! DECLARE NAMELIST !----------------- NAMELIST /FCSTDATA/ & & TSTART, TEND , TCP , RESTRT, SINGLRST, SUBPOST, NMAP , TSHDE, SPL, NPHS , NCNVC , NRADSH,& & NRADLH, NTDDMP, TPREC, THEAT , TCLOD , TRDSW , TRDLW, TSRFC, NEST, HYDRO, SPLINE ! NAMELIST /POSTLIST/ CHMO NAMELIST /POSTLIST/ SUBMIT !CHOU ! CALL MPI_FIRST !----------------------------------------------------------- ! READ NAMELIST FCSTDATA TO FIND OUT IF THIS IS A NESTED RUN !----------------------------------------------------------- LFCSTD = 11 OPEN(LFCSTD, FILE='FCSTDATA.meso', STATUS='OLD') READ(LFCSTD, FCSTDATA) ! IF (NSOIL < 4) THEN PRINT*, ' NSOIL IS LESS THAN 4. CHANGE THE EQUIVALENCES' PRINT*, ' STOPPING' CALL MPI_ABORT(MPI_COMM_WORLD, 1, IERR) END IF ! IF (ME == 0) THEN LME = .TRUE. ELSE LME = .FALSE. END IF !------------------------------ ! READ NHB FILE TO OBTAIN SIGMA !------------------------------ OPEN(UNIT=NHB, FORM='UNFORMATTED', FILE='CNST.file') REWIND NHB READ(NHB) NFCST, NBC, LIST, DT, IDTAD, SIGMA IF (ME == 0) THEN PRINT*,'IN QUILT, SIGMA= ', SIGMA END IF ! ALLOCATE (PDOMG(IM,MY_JSD:MY_JED)) ALLOCATE (RESOMG(IM,MY_JSD:MY_JED)) ALLOCATE (OMGALF(IM,MY_JSD:MY_JED,1:LM)) ALLOCATE (PD(IM,MY_JSD:MY_JED)) ALLOCATE (RES(IM,MY_JSD:MY_JED)) ALLOCATE (FIS(IM,MY_JSD:MY_JED)) ALLOCATE (T(IM,MY_JSD:MY_JED,1:LM)) ALLOCATE (Q(IM,MY_JSD:MY_JED,1:LM)) ALLOCATE (U(IM,MY_JSD:MY_JED,1:LM)) ALLOCATE (V(IM,MY_JSD:MY_JED,1:LM)) ALLOCATE (Q2(IM,MY_JSD:MY_JED,1:LM)) ALLOCATE (TTND(IM,MY_JSD:MY_JED,1:LM)) ALLOCATE (CWM(IM,MY_JSD:MY_JED,1:LM)) ALLOCATE (TRAIN(IM,MY_JSD:MY_JED,1:LM)) ALLOCATE (TCUCN(IM,MY_JSD:MY_JED,1:LM)) ALLOCATE (RSWIN(IM,MY_JSD:MY_JED)) ALLOCATE (RSWOUT(IM,MY_JSD:MY_JED)) ALLOCATE (TG(IM,MY_JSD:MY_JED)) ALLOCATE (Z0(IM,MY_JSD:MY_JED)) ALLOCATE (AKMS(IM,MY_JSD:MY_JED)) ALLOCATE (CZEN(IM,MY_JSD:MY_JED)) ALLOCATE (AKHS(IM,MY_JSD:MY_JED)) ALLOCATE (THS(IM,MY_JSD:MY_JED)) ALLOCATE (QS(IM,MY_JSD:MY_JED)) ALLOCATE (TWBS(IM,MY_JSD:MY_JED)) ALLOCATE (QWBS(IM,MY_JSD:MY_JED)) ALLOCATE (HBOT(IM,MY_JSD:MY_JED)) ALLOCATE (CFRACL(IM,MY_JSD:MY_JED)) ALLOCATE (THZ0(IM,MY_JSD:MY_JED)) ALLOCATE (QZ0(IM,MY_JSD:MY_JED)) ALLOCATE (UZ0(IM,MY_JSD:MY_JED)) ALLOCATE (VZ0(IM,MY_JSD:MY_JED)) ALLOCATE (USTAR(IM,MY_JSD:MY_JED)) ALLOCATE (HTOP(IM,MY_JSD:MY_JED)) ALLOCATE (SNO(IM,MY_JSD:MY_JED)) ALLOCATE (SI(IM,MY_JSD:MY_JED)) ALLOCATE (CLDEFI(IM,MY_JSD:MY_JED)) ALLOCATE (RF(IM,MY_JSD:MY_JED)) ALLOCATE (PSLP(IM,MY_JSD:MY_JED)) ALLOCATE (CUPPT(IM,MY_JSD:MY_JED)) ALLOCATE (CFRACH(IM,MY_JSD:MY_JED)) ALLOCATE (CFRACM(IM,MY_JSD:MY_JED)) ALLOCATE (SOILTB(IM,MY_JSD:MY_JED)) ALLOCATE (SFCEXC(IM,MY_JSD:MY_JED)) ALLOCATE (SMSTAV(IM,MY_JSD:MY_JED)) ALLOCATE (SMSTOT(IM,MY_JSD:MY_JED)) ALLOCATE (GRNFLX(IM,MY_JSD:MY_JED)) ALLOCATE (PCTSNO(IM,MY_JSD:MY_JED)) ALLOCATE (RLWIN(IM,MY_JSD:MY_JED)) ALLOCATE (RADOT(IM,MY_JSD:MY_JED)) ALLOCATE (CZMEAN(IM,MY_JSD:MY_JED)) ALLOCATE (SIGT4(IM,MY_JSD:MY_JED)) ALLOCATE (U00(IM,MY_JSD:MY_JED)) ALLOCATE (LC(IM,MY_JSD:MY_JED)) ALLOCATE (SR(IM,MY_JSD:MY_JED)) ALLOCATE (PREC(IM,MY_JSD:MY_JED)) ALLOCATE (ACPREC(IM,MY_JSD:MY_JED)) ALLOCATE (ACCLIQ(IM,MY_JSD:MY_JED)) ALLOCATE (CUPREC(IM,MY_JSD:MY_JED)) ALLOCATE (ACFRCV(IM,MY_JSD:MY_JED)) ALLOCATE (NCFRCV(IM,MY_JSD:MY_JED)) ALLOCATE (ACFRST(IM,MY_JSD:MY_JED)) ALLOCATE (NCFRST(IM,MY_JSD:MY_JED)) ALLOCATE (ACSNOW(IM,MY_JSD:MY_JED)) ALLOCATE (ACSNOM(IM,MY_JSD:MY_JED)) ALLOCATE (SSROFF(IM,MY_JSD:MY_JED)) ALLOCATE (BGROFF(IM,MY_JSD:MY_JED)) ALLOCATE (SFCSHX(IM,MY_JSD:MY_JED)) ALLOCATE (SFCLHX(IM,MY_JSD:MY_JED)) ALLOCATE (SUBSHX(IM,MY_JSD:MY_JED)) ALLOCATE (SNOPCX(IM,MY_JSD:MY_JED)) ALLOCATE (SFCUVX(IM,MY_JSD:MY_JED)) ALLOCATE (SFCEVP(IM,MY_JSD:MY_JED)) ALLOCATE (POTEVP(IM,MY_JSD:MY_JED)) ALLOCATE (ASWIN(IM,MY_JSD:MY_JED)) ALLOCATE (ASWOUT(IM,MY_JSD:MY_JED)) ALLOCATE (ASWTOA(IM,MY_JSD:MY_JED)) ALLOCATE (ALWIN(IM,MY_JSD:MY_JED)) ALLOCATE (ALWOUT(IM,MY_JSD:MY_JED)) ALLOCATE (ALWTOA(IM,MY_JSD:MY_JED)) !--------- ! SM v100M !--------- ALLOCATE (TH100(IM,MY_JSD:MY_JED)) ALLOCATE (Q100(IM,MY_JSD:MY_JED)) ALLOCATE (U100(IM,MY_JSD:MY_JED)) ALLOCATE (V100(IM,MY_JSD:MY_JED)) !--------- ! SM v100M !--------- ! Lyra GSM Wind stress ALLOCATE(XMOMFLUX(IM,MY_JSD:MY_JED)) ALLOCATE(YMOMFLUX(IM,MY_JSD:MY_JED)) ! Lyra GSM Wind stress ! ALLOCATE (TH10(IM,MY_JSD:MY_JED)) ALLOCATE (Q10(IM,MY_JSD:MY_JED)) ALLOCATE (U10(IM,MY_JSD:MY_JED)) ALLOCATE (V10(IM,MY_JSD:MY_JED)) ALLOCATE (TSHLTR(IM,MY_JSD:MY_JED)) ALLOCATE (QSHLTR(IM,MY_JSD:MY_JED)) ALLOCATE (PSHLTR(IM,MY_JSD:MY_JED)) ALLOCATE (SMC(IM,MY_JSD:MY_JED,1:NSOIL)) ALLOCATE (CMC(IM,MY_JSD:MY_JED)) ALLOCATE (STC(IM,MY_JSD:MY_JED,1:NSOIL)) ALLOCATE (SH2O(IM,MY_JSD:MY_JED,1:NSOIL)) ALLOCATE (ALBEDO(IM,MY_JSD:MY_JED)) ALLOCATE (POTFLX(IM,MY_JSD:MY_JED)) ALLOCATE (TLMIN(IM,MY_JSD:MY_JED)) ALLOCATE (TLMAX(IM,MY_JSD:MY_JED)) !Lyra GSM Max wind ALLOCATE(MAXWU(IM,MY_JSD:MY_JED)) ALLOCATE(MAXWV(IM,MY_JSD:MY_JED)) !Lyra GSM Max wind ! ALLOCATE (RSWTT(IM,MY_JSD:MY_JED,1:LM)) ALLOCATE (RLWTT(IM,MY_JSD:MY_JED,1:LM)) ! ALLOCATE (CNVBOT(MY_ISD:MY_IED,MY_JSD:MY_JED)) ALLOCATE (CNVTOP(MY_ISD:MY_IED,MY_JSD:MY_JED)) ALLOCATE (RSWTOA(MY_ISD:MY_IED,MY_JSD:MY_JED)) ALLOCATE (RLWTOA(MY_ISD:MY_IED,MY_JSD:MY_JED)) ! ALLOCATE (HBM2(IM,MY_JSD:MY_JED)) ALLOCATE (SM(IM,MY_JSD:MY_JED)) ! ALLOCATE (DETA(1:LM)) !------------------------------- ! LOOP OVER ALL THE OUTPUT TIMES !------------------------------- 666 CONTINUE ! IF (ME == 0) THEN CALL MPI_RECV(IHOUR, 1, MPI_INTEGER, 0, 0, MPI_COMM_INTER, STATUS, IER) PRINT*,' IHOUR IN QUILT = ', IHOUR END IF ! CALL MPI_BCAST(IHOUR, 1, MPI_INTEGER, 0, MPI_COMM_COMP, IER) ! IF (IHOUR == -999) GOTO 667 ! DO 200 IXXX=1,JEND(ME)-JSTA(ME)+1 !--------------------------------------------------------------------- ! RECEIVE ALL THE DATA FROM CHKOUT FROM THE APPROPRIATE FORECAST TASKS !--------------------------------------------------------------------- IST = TIMEF() ! CALL MPI_RECV(BUF, IBUFMAX, MPI_REAL, MPI_ANY_SOURCE, IHOUR, MPI_COMM_INTER, STATUS, IER) ! IPE = STATUS(MPI_SOURCE) ! IF (IER /= 0) THEN PRINT*,' ERROR FROM MPI_REC = ', IER END IF ! IS = MY_IS_GLB_A(IPE) IE = MY_IE_GLB_A(IPE) JS = MY_JS_GLB_A(IPE) JE = MY_JE_GLB_A(IPE) ! LEN_CH = (IE - IS + 1) * (JE - JS + 1) !----------------------------------------------------------------------- ! EXTRACT RECORD LENGTH - LETS KEEP THIS BECAUSE IT IS POTENTIALLY HANDY !----------------------------------------------------------------------- CALL DECOAL(IDUM , -1 ) CALL DECOAL(RUN , 1 ) CALL DECOAL(IDAT , 3 ) CALL DECOAL(IHRST , 1 ) CALL DECOAL(NTSD , 1 ) CALL DECOAL(LABEL , 8 ) CALL DECOAL( PDOMG(IS:IE,JS:JE), LEN_CH) CALL DECOAL(RESOMG(IS:IE,JS:JE), LEN_CH) ! DO L=1,LM CALL DECOAL(OMGALF(IS:IE,JS:JE,L), LEN_CH) END DO ! CALL DECOAL(RUN , 1 ) CALL DECOAL(IDAT , 3 ) CALL DECOAL(IHRST , 1 ) CALL DECOAL(NTSD , 1 ) CALL DECOAL(LABEL , 8 ) CALL DECOAL(FIRST , 1 ) CALL DECOAL(IOUT , 1 ) CALL DECOAL(NSHDE , 1 ) CALL DECOAL(PD(IS:IE,JS:JE) , LEN_CH ) CALL DECOAL(RES(IS:IE,JS:JE), LEN_CH ) CALL DECOAL(FIS(IS:IE,JS:JE), LEN_CH ) CALL DECOAL(PDB , LB*2 ) CALL DECOAL(TB , LB*LM*2) CALL DECOAL(QB , LB*LM*2) CALL DECOAL(UB , LB*LM*2) CALL DECOAL(VB , LB*LM*2) CALL DECOAL(Q2B , LB*LM*2) CALL DECOAL(CWMB , LB*LM*2) ! DO L=1,LM CALL DECOAL( T(IS:IE,JS:JE,L), LEN_CH) CALL DECOAL( Q(IS:IE,JS:JE,L), LEN_CH) CALL DECOAL( U(IS:IE,JS:JE,l), LEN_CH) CALL DECOAL( V(IS:IE,JS:JE,l), LEN_CH) CALL DECOAL( Q2(IS:IE,JS:JE,L), LEN_CH) CALL DECOAL( TTND(IS:IE,JS:JE,L), LEN_CH) CALL DECOAL( CWM(IS:IE,JS:JE,L), LEN_CH) CALL DECOAL(TRAIN(IS:IE,JS:JE,L), LEN_CH) CALL DECOAL(TCUCN(IS:IE,JS:JE,L), LEN_CH) END DO ! CALL DECOAL(RUN , 1 ) CALL DECOAL(IDAT , 3 ) CALL DECOAL(IHRST , 1 ) CALL DECOAL(NTSD , 1 ) CALL DECOAL(LABEL , 8 ) CALL DECOAL( RSWIN(IS:IE,JS:JE), LEN_CH) CALL DECOAL(RSWOUT(IS:IE,JS:JE), LEN_CH) CALL DECOAL( TG(IS:IE,JS:JE), LEN_CH) CALL DECOAL( Z0(IS:IE,JS:JE), LEN_CH) CALL DECOAL( AKMS(IS:IE,JS:JE), LEN_CH) CALL DECOAL( CZEN(IS:IE,JS:JE), LEN_CH) CALL DECOAL( AKHS(IS:IE,JS:JE), LEN_CH) CALL DECOAL( THS(IS:IE,JS:JE), LEN_CH) CALL DECOAL( QS(IS:IE,JS:JE), LEN_CH) CALL DECOAL( TWBS(IS:IE,JS:JE), LEN_CH) CALL DECOAL( QWBS(IS:IE,JS:JE), LEN_CH) CALL DECOAL( HBOT(IS:IE,JS:JE), LEN_CH) CALL DECOAL(CFRACL(IS:IE,JS:JE), LEN_CH) CALL DECOAL( THZ0(IS:IE,JS:JE), LEN_CH) CALL DECOAL( QZ0(IS:IE,JS:JE), LEN_CH) CALL DECOAL( UZ0(IS:IE,JS:JE), LEN_CH) CALL DECOAL( VZ0(IS:IE,JS:JE), LEN_CH) CALL DECOAL( USTAR(IS:IE,JS:JE), LEN_CH) CALL DECOAL( HTOP(IS:IE,JS:JE), LEN_CH) CALL DECOAL(CFRACM(IS:IE,JS:JE), LEN_CH) CALL DECOAL( SNO(IS:IE,JS:JE), LEN_CH) CALL DECOAL( SI(IS:IE,JS:JE), LEN_CH) CALL DECOAL(CLDEFI(IS:IE,JS:JE), LEN_CH) CALL DECOAL( RF(IS:IE,JS:JE), LEN_CH) CALL DECOAL( PSLP(IS:IE,JS:JE), LEN_CH) CALL DECOAL( CUPPT(IS:IE,JS:JE), LEN_CH) CALL DECOAL(CFRACH(IS:IE,JS:JE), LEN_CH) CALL DECOAL(SOILTB(IS:IE,JS:JE), LEN_CH) CALL DECOAL(SFCEXC(IS:IE,JS:JE), LEN_CH) CALL DECOAL(SMSTAV(IS:IE,JS:JE), LEN_CH) CALL DECOAL(SMSTOT(IS:IE,JS:JE), LEN_CH) CALL DECOAL(GRNFLX(IS:IE,JS:JE), LEN_CH) CALL DECOAL(PCTSNO(IS:IE,JS:JE), LEN_CH) CALL DECOAL( RLWIN(IS:IE,JS:JE), LEN_CH) CALL DECOAL( RADOT(IS:IE,JS:JE), LEN_CH) CALL DECOAL(CZMEAN(IS:IE,JS:JE), LEN_CH) CALL DECOAL( SIGT4(IS:IE,JS:JE), LEN_CH) CALL DECOAL( U00(IS:IE,JS:JE), LEN_CH) CALL DECOAL(UL , 2*LM ) CALL DECOAL( LC(IS:IE,JS:JE), LEN_CH) CALL DECOAL( SR(IS:IE,JS:JE), LEN_CH) CALL DECOAL(RUN , 1 ) CALL DECOAL(IDAT , 3 ) CALL DECOAL(IHRST , 1 ) CALL DECOAL(NTSD , 1 ) CALL DECOAL(LABEL , 8 ) CALL DECOAL( PREC(IS:IE,JS:JE), LEN_CH) CALL DECOAL(ACPREC(IS:IE,JS:JE), LEN_CH) CALL DECOAL(ACCLIQ(IS:IE,JS:JE), LEN_CH) CALL DECOAL(CUPREC(IS:IE,JS:JE), LEN_CH) CALL DECOAL(ACFRCV(IS:IE,JS:JE), LEN_CH) CALL DECOAL(NCFRCV(IS:IE,JS:JE), LEN_CH) CALL DECOAL(ACFRST(IS:IE,JS:JE), LEN_CH) CALL DECOAL(NCFRST(IS:IE,JS:JE), LEN_CH) CALL DECOAL(ACSNOW(IS:IE,JS:JE), LEN_CH) CALL DECOAL(ACSNOM(IS:IE,JS:JE), LEN_CH) CALL DECOAL(SSROFF(IS:IE,JS:JE), LEN_CH) CALL DECOAL(bgroff(IS:IE,JS:JE), LEN_CH) CALL DECOAL(SFCSHX(IS:IE,JS:JE), LEN_CH) CALL DECOAL(SFCLHX(IS:IE,JS:JE), LEN_CH) CALL DECOAL(SUBSHX(IS:IE,JS:JE), LEN_CH) CALL DECOAL(SNOPCX(IS:IE,JS:JE), LEN_CH) CALL DECOAL(SFCUVX(IS:IE,JS:JE), LEN_CH) CALL DECOAL(SFCEVP(IS:IE,JS:JE), LEN_CH) CALL DECOAL(POTEVP(IS:IE,JS:JE), LEN_CH) CALL DECOAL( ASWIN(IS:IE,JS:JE), LEN_CH) CALL DECOAL(ASWOUT(IS:IE,JS:JE), LEN_CH) CALL DECOAL(ASWTOA(IS:IE,JS:JE), LEN_CH) CALL DECOAL( ALWIN(IS:IE,JS:JE), LEN_CH) CALL DECOAL(ALWOUT(IS:IE,JS:JE), LEN_CH) CALL DECOAL(ALWTOA(IS:IE,JS:JE), LEN_CH) CALL DECOAL(ARDSW , 1 ) CALL DECOAL(ARDLW , 1 ) CALL DECOAL(ASRFC , 1 ) CALL DECOAL(AVRAIN , 1 ) CALL DECOAL(AVCNVC , 1 ) CALL DECOAL( TH10(IS:IE,JS:JE), LEN_CH) CALL DECOAL( Q10(IS:IE,JS:JE), LEN_CH) CALL DECOAL( U10(IS:IE,JS:JE), LEN_CH) CALL DECOAL( V10(IS:IE,JS:JE), LEN_CH) CALL DECOAL(TSHLTR(IS:IE,JS:JE), LEN_CH) CALL DECOAL(QSHLTR(IS:IE,JS:JE), LEN_CH) CALL DECOAL(PSHLTR(IS:IE,JS:JE), LEN_CH) !--------- ! SM v100 M !--------- CALL DECOAL( TH100(IS:IE,JS:JE), LEN_CH) CALL DECOAL( Q100(IS:IE,JS:JE), LEN_CH) CALL DECOAL( U100(IS:IE,JS:JE), LEN_CH) CALL DECOAL( V100(IS:IE,JS:JE), LEN_CH) !--------- ! SM v100M !--------- ! Lyra GSM Wind stress CALL DECOAL(XMOMFLUX(IS:IE,JS:JE),LEN_CH) CALL DECOAL(YMOMFLUX(IS:IE,JS:JE),LEN_CH) ! Lyra GSM Wind stress ! CALL DECOAL( SMC(IS:IE,JS:JE,1:NSOIL), LEN_CH*NSOIL) CALL DECOAL( CMC(IS:IE,JS:JE) , LEN_CH) CALL DECOAL( STC(IS:IE,JS:JE,1:NSOIL), LEN_CH*NSOIL) CALL DECOAL( SH2O(IS:IE,JS:JE,1:NSOIL), LEN_CH*NSOIL) CALL DECOAL( ALBEDO(IS:IE,JS:JE) , LEN_CH) CALL DECOAL( POTFLX(IS:IE,JS:JE) , LEN_CH) CALL DECOAL( TLMIN(IS:IE,JS:JE) , LEN_CH) CALL DECOAL( TLMAX(IS:IE,JS:JE) , LEN_CH) ! !Lyra GSM Max wind CALL DECOAL( MAXWU(IS:IE,JS:JE) , LEN_CH) CALL DECOAL( MAXWV(IS:IE,JS:JE) , LEN_CH) !Lyra ! CALL DECOAL(ACUTIM,1) CALL DECOAL(ARATIM,1) CALL DECOAL(APHTIM,1) CALL DECOAL(NHEAT ,1) CALL DECOAL(NPHS ,1) CALL DECOAL(NCNVC ,1) CALL DECOAL(NPREC ,1) CALL DECOAL(NRDSW ,1) CALL DECOAL(NRDLW ,1) CALL DECOAL(NSRFC ,1) CALL DECOAL(TPH0D ,1) CALL DECOAL(TLM0D ,1) CALL DECOAL(RESTRT,1) ! DO L=1,LM CALL DECOAL(RSWTT(IS:IE,JS:JE,L), LEN_CH) CALL DECOAL(RLWTT(IS:IE,JS:JE,L), LEN_CH) END DO ! CALL DECOAL(CNVBOT(IS:IE,JS:JE), LEN_CH) CALL DECOAL(CNVTOP(IS:IE,JS:JE), LEN_CH) CALL DECOAL(RSWTOA(IS:IE,JS:JE), LEN_CH) CALL DECOAL(RLWTOA(IS:IE,JS:JE), LEN_CH) !----------------------- ! ADDED FOR SLPSIG STUFF !----------------------- CALL DECOAL(HBM2(IS:IE,JS:JE), LEN_CH) CALL DECOAL( SM(IS:IE,JS:JE), LEN_CH) CALL DECOAL( SPL(1:LSM), LSM) CALL DECOAL(DETA(1:LM) , LM) CALL DECOAL(PT , 1) CALL DECOAL(SPLINE , 1) ! WRITE(6,*) 'DECOALED IN QUILT THAT SPLINE= ', SPLINE ! 200 END DO !----------------------------------------------------- ! BEFORE WRITING OUT THE RESTRT FILE, COMPUTE THE MSLP !----------------------------------------------------- !JLG PRINT*,'CALLING SLP' ! CALL SLP(NHB, PD, RES, FIS, T, Q, NTSD, NEST, PSLP) ! !---------------------------------- ! WRITE OUT THE GLOBAL RESTRT FILE. !---------------------------------- ! !--------------------------------------------------- ! GENERATE THE NAME OF THE GLOBAL OUTPUT RESTRT FILE !--------------------------------------------------- ENVAR = ' ' CALL GETENV("RSTFNL", ENVAR) CALL GETENV("TMMARK", RESTHR) RESTHR='t00s' KPATH = INDEX(ENVAR,' ') -1 ! IF (KPATH <= 0) KPATH = LEN(ENVAR) IF (RESTHR == ' ') THEN WRITE(RSTFIL2,280) IHOUR 280 FORMAT('RESTRT', I7.7) ELSE WRITE(RSTFIL2,285) IHOUR, RESTHR 285 FORMAT('RESTRT',I7.7,'.',A4) END IF ! KRST = INDEX(RSTFIL2,' ') -1 IF (KRST <= 0) KRST = LEN(RSTFIL2) !------------------------------------- ! OPEN UNIT TO THE GLOBAL RESTART FILE !------------------------------------- CLOSE(LRSTRT2) ! IF (ENVAR(1:4) == BLANK) THEN OPEN(UNIT=LRSTRT2, FILE=RSTFIL2, FORM='UNFORMATTED', IOSTAT=IER) ELSE FNAME = ENVAR(1:KPATH) // RSTFIL2(1:KRST) OPEN(UNIT=LRSTRT2, FILE=FNAME, FORM='UNFORMATTED', IOSTAT=IER) END IF ! IF (LME) WRITE(LRSTRT2) RUN, IDAT, IHRST, NTSD, LABEL, IHOUR ! CALL COLLECT(PDOMG , DUM1) CALL COLLECT(RESOMG, DUM2) ! IF (LME) WRITE(LRSTRT2) DUM1, DUM2 ! DO L=1,LM CALL COLLECT(OMGALF(:,:,L), DUM1) IF (LME) WRITE(LRSTRT2) DUM1 END DO ! IF (LME) WRITE(LRSTRT2) RUN, IDAT, IHRST, NTSD, LABEL, IHOUR, FIRST, IOUT, NSHDE ! CALL COLLECT(PD ,DUM1) CALL COLLECT(RES,DUM2) CALL COLLECT(FIS,DUM3) ! IF (LME) WRITE(LRSTRT2) DUM1, DUM2, DUM3 IF (LME) WRITE(LRSTRT2) PDB , TB , QB , UB, VB, Q2B, CWMB ! DO L=1,LM CALL COLLECT (T(:,:,L),DUM1) IF (LME) WRITE(LRSTRT2) DUM1 CALL COLLECT (Q(:,:,L),DUM1) IF (LME) WRITE(LRSTRT2) DUM1 CALL COLLECT (U(:,:,L),DUM1) IF (LME) WRITE(LRSTRT2) DUM1 CALL COLLECT (V(:,:,L),DUM1) IF (LME) WRITE(LRSTRT2) DUM1 CALL COLLECT (Q2(:,:,L),DUM1) IF (LME) WRITE(LRSTRT2) DUM1 CALL COLLECT (TTND(:,:,L),DUM1) IF (LME) WRITE(LRSTRT2) DUM1 CALL COLLECT (CWM(:,:,L),DUM1) IF (LME) WRITE(LRSTRT2) DUM1 CALL COLLECT (TRAIN(:,:,L),DUM1) IF (LME) WRITE(LRSTRT2) DUM1 CALL COLLECT (TCUCN(:,:,L),DUM1) IF (LME) WRITE(LRSTRT2) DUM1 END DO ! CALL COLLECT(RSWIN , DUM1) CALL COLLECT(RSWOUT, DUM2) CALL COLLECT(TG , DUM3) CALL COLLECT(Z0 , DUM4) CALL COLLECT(AKMS , DUM5) CALL COLLECT(CZEN , DUM6) ! IF (LME) WRITE(LRSTRT2) RUN , IDAT, IHRST, NTSD, LABEL, IHOUR, & & DUM1, DUM2, DUM3 , DUM4, DUM5 , DUM6 ! CALL COLLECT(AKHS ,DUM1) CALL COLLECT(THS ,DUM2) CALL COLLECT(QS ,DUM3) CALL COLLECT(TWBS ,DUM4) CALL COLLECT(QWBS ,DUM5) CALL COLLECT(HBOT ,DUM6) CALL COLLECT(CFRACL,DUM7) ! IF (LME) WRITE(LRSTRT2) DUM1, DUM2, DUM3, DUM4, DUM5, DUM6, DUM7 ! CALL COLLECT(THZ0 ,DUM1) CALL COLLECT(QZ0 ,DUM2) CALL COLLECT(UZ0 ,DUM3) CALL COLLECT(VZ0 ,DUM4) CALL COLLECT(USTAR ,DUM5) CALL COLLECT(HTOP ,DUM6) CALL COLLECT(CFRACM,DUM7) ! IF (LME) WRITE(LRSTRT2) DUM1, DUM2, DUM3, DUM4, DUM5, DUM6, DUM7 ! CALL COLLECT(SNO ,DUM1) CALL COLLECT(SI ,DUM2) CALL COLLECT(CLDEFI,DUM3) CALL COLLECT(RF ,DUM4) CALL COLLECT(PSLP ,DUM5) CALL COLLECT(CUPPT ,DUM6) CALL COLLECT(CFRACH,DUM7) ! IF (LME) WRITE(LRSTRT2) DUM1, DUM2, DUM3, DUM4, DUM5, DUM6, DUM7 ! CALL COLLECT(SOILTB,DUM1) CALL COLLECT(SFCEXC,DUM2) CALL COLLECT(SMSTAV,DUM3) CALL COLLECT(SMSTOT,DUM4) CALL COLLECT(GRNFLX,DUM5) CALL COLLECT(PCTSNO,DUM6) ! IF (LME) WRITE(LRSTRT2) DUM1, DUM2, DUM3, DUM4, DUM5, DUM6 ! CALL COLLECT(RLWIN ,DUM1) CALL COLLECT(RADOT ,DUM2) CALL COLLECT(CZMEAN,DUM3) CALL COLLECT(SIGT4 ,DUM4) ! IF (LME) WRITE(LRSTRT2) DUM1, DUM2, DUM3, DUM4 ! CALL COLLECT(U00,DUM1) CALL COLLECT(LC ,DUM2) CALL COLLECT(SR ,DUM3) ! IF (LME) WRITE(LRSTRT2) DUM1, UL, DUM2, DUM3 ! CALL COLLECT(PREC ,DUM1) CALL COLLECT(ACPREC,DUM2) CALL COLLECT(ACCLIQ,DUM3) CALL COLLECT(CUPREC,DUM4) ! IF (LME) WRITE(LRSTRT2) RUN, IDAT, IHRST, NTSD, LABEL, IHOUR, DUM1, DUM2, DUM3, DUM4 ! CALL COLLECT(ACFRCV,DUM1) CALL COLLECT(NCFRCV,DUM2) CALL COLLECT(ACFRST,DUM3) CALL COLLECT(NCFRST,DUM4) ! IF (LME) WRITE(LRSTRT2) DUM1, DUM2, DUM3, DUM4 ! CALL COLLECT(ACSNOW,DUM1) CALL COLLECT(ACSNOM,DUM2) CALL COLLECT(SSROFF,DUM3) CALL COLLECT(BGROFF,DUM4) ! IF (LME) WRITE(LRSTRT2) DUM1, DUM2, DUM3, DUM4 ! CALL COLLECT(SFCSHX,DUM1) CALL COLLECT(SFCLHX,DUM2) CALL COLLECT(SUBSHX,DUM3) CALL COLLECT(SNOPCX,DUM4) CALL COLLECT(SFCUVX,DUM5) CALL COLLECT(SFCEVP,DUM6) CALL COLLECT(POTEVP,DUM7) ! IF (LME) WRITE(LRSTRT2) DUM1, DUM2, DUM3, DUM4, DUM5, DUM6, DUM7 ! CALL COLLECT(ASWIN ,DUM1) CALL COLLECT(ASWOUT,DUM2) CALL COLLECT(ASWTOA,DUM3) CALL COLLECT(ALWIN ,DUM4) CALL COLLECT(ALWOUT,DUM5) CALL COLLECT(ALWTOA,DUM6) ! IF (LME) WRITE(LRSTRT2) DUM1, DUM2, DUM3, DUM4, DUM5, DUM6 ! IF (LME) WRITE(LRSTRT2) ARDSW, ARDLW, ASRFC, AVRAIN, AVCNVC ! CALL COLLECT(TH10 ,DUM1) CALL COLLECT(Q10 ,DUM2) CALL COLLECT(U10 ,DUM3) CALL COLLECT(V10 ,DUM4) CALL COLLECT(TSHLTR,DUM5) CALL COLLECT(QSHLTR,DUM6) CALL COLLECT(PSHLTR,DUM7) !--------- ! SM V100M !--------- CALL COLLECT(TH100,DUM8 ) CALL COLLECT(Q100 ,DUM9 ) CALL COLLECT(U100 ,DUM10) CALL COLLECT(V100 ,DUM11) !--------- ! SM V100M !--------- ! Lyra Wind stress CALL COLLECT(XMOMFLUX,DUM12) CALL COLLECT(YMOMFLUX,DUM13) ! Lyra Wind stress ! IF (LME) WRITE(LRSTRT2) DUM1, DUM2, DUM3, DUM4, DUM5, DUM6, DUM7, DUM8, DUM9, DUM10, DUM11, DUM12, DUM13 !--------- ! SM V100M !--------- DO L=1,NSOIL CALL COLLECT(SMC(:,:,L), DUMS(:,:,L)) END DO ! IF (LME) WRITE(LRSTRT2) DUMS ! CALL COLLECT(CMC, DUM1) ! IF (LME) WRITE(LRSTRT2) DUM1 ! DO L=1,NSOIL CALL COLLECT(STC(:,:,L), DUMS(:,:,L)) END DO ! IF (LME) WRITE(LRSTRT2) DUMS ! DO L=1,NSOIL CALL COLLECT(SH2O(:,:,L), DUMS(:,:,L)) END DO ! IF (LME) WRITE(LRSTRT2) DUMS ! CALL COLLECT(ALBEDO, DUM1) ! IF (LME) WRITE(LRSTRT2) DUM1 ! CALL COLLECT(POTFLX,DUM1) CALL COLLECT(TLMIN ,DUM2) CALL COLLECT(TLMAX ,DUM3) ! ! Lyra GSM Max wind CALL COLLECT(MAXWU ,DUM4) CALL COLLECT(MAXWV ,DUM5) ! Lyra GSM Max wind ! IF (LME) WRITE(LRSTRT2) DUM1 , DUM2 , DUM3 , DUM4 , DUM5 , ACUTIM, ARATIM, APHTIM, NHEAT , NPHS, NCNVC, & & NPREC, NRDSW, NRDLW, NSRFC , TPH0D , TLM0D , RESTRT ! DO L=1,LM CALL COLLECT(RSWTT(:,:,L), DUM1) ! IF (LME) WRITE(LRSTRT2) DUM1 ! CALL COLLECT(RLWTT(:,:,L), DUM1) ! IF (LME) WRITE(LRSTRT2) DUM1 END DO ! CALL COLLECT(CNVBOT(:,:), DUM1) ! IF (LME) WRITE(LRSTRT2) DUM1 ! CALL COLLECT(CNVTOP(:,:), DUM1) ! IF (LME) WRITE(LRSTRT2) DUM1 ! CALL COLLECT(RSWTOA(:,:), DUM1) ! IF (LME) WRITE(LRSTRT2) DUM1 ! CALL COLLECT(RLWTOA(:,:), DUM1) ! IF (LME) WRITE(LRSTRT2) DUM1 ! CLOSE(LRSTRT2) !---------------------------------------------------------------------------------- ! SM - ALTERA\E7\E3O FEITA PARA O IO - PARA N\E3O MAIS ESCREVER O OUTJOB E FCSTDONE !---------------------------------------------------------------------------------- OUTJ = .TRUE. ! IF (OUTJ) THEN ! IF (LME) THEN DONE = 'DONE' ITAG = IHOUR ! WRITE(FINFIL,1190) ITAG, RESTHR ! 1190 FORMAT('FCSTDONE',I7.7,'.',A4) LFINFIL = 91 CLOSE(LFINFIL) ! OPEN(UNIT=LFINFIL, FILE=FINFIL, FORM='UNFORMATTED', IOSTAT=IER) WRITE(LFINFIL) DONE CLOSE(LFINFIL) ! IF (IER /= 0) WRITE(LIST,*)' SIGNAL SENT TO FINFIL: DONE' END IF END IF ! GOTO 666 667 CONTINUE ! PRINT*,' QUILT I/O SERVER SHUTTING DOWN NOW' END SUBROUTINE QUILT ! ! SUBROUTINE DECOAL(A, LEN_CH) !-------------------------------------------------------------------------------------------------- USE F77KINDS USE BUFFER ! REAL (KIND=R4KIND) ::& & A(*) ! IF (LEN_CH < 0) THEN IP = 0 END IF ! DO I=1,ABS(LEN_CH) IP = IP + 1 A(I) = BUF(IP) END DO ! END SUBROUTINE DECOAL