!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE BOCOHF ! ****************************************************************** !$$$ SUBPROGRAM DOCUMENTATION BLOCK ! . . . ! SUBPROGRAM: BOCOH UPDATE MASS POINTS ON BOUNDARY ! PRGRMMR: JANJIC ORG: W/NP22 DATE: 94-03-08 ! ABSTRACT: ! TEMPERATURE, SPECIFIC HUMIDITY, AND SURFACE PRESSURE ! ARE UPDATED ON THE DOMAIN BOUNDARY BY APPLYING THE ! PRE-COMPUTED TENDENCIES AT EACH TIME STEP. ! PROGRAM HISTORY LOG: ! 87-??-?? MESINGER - ORIGINATOR ! 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D in HORIZONTAL ! 96-12-13 BLACK - FINAL MODIFICATION FOR NESTED RUNS ! 98-10-30 BLACK - MODIFIED FOR DISTRIBUTED MEMORY ! 00-01-06 BLACK - MODIFIED FOR JANJIC NONHYDROSTATIC CODE ! 00-09-14 BLACK - MODIFIED FOR DIRECT ACCESS READ ! USAGE: CALL BOCOH FROM MAIN PROGRAM EBU ! INPUT ARGUMENT LIST: ! NONE ! OUTPUT ARGUMENT LIST: ! NONE ! OUTPUT FILES: ! NONE ! SUBPROGRAMS CALLED: ! UNIQUE: NONE ! LIBRARY: NONE ! COMMON BLOCKS: CTLBLK ! MASKS ! VRBLS ! PVRBLS ! CLDWTR ! BOCO ! MAPOT ! DYNAM ! NHYDRO ! ATTRIBUTES: ! LANGUAGE: FORTRAN 90 ! MACHINE : IBM SP !$$$ ! ****************************************************************** !----------------------------------------------------------------------- INCLUDE "parmeta.f90" INCLUDE "mpif.h" INCLUDE "mpp.h" #include "sp.h" !----------------------------------------------------------------------- PARAMETER & (IMJM=IM*JM-JM/2,LB=2*IM+JM-3,LP1=LM+1) PARAMETER & (ISIZ1=2*LB,ISIZ2=2*LB*LM) !----------------------------------------------------------------------- LOGICAL :: & RUN,FIRST,RESTRT,SIGMA,NEST !----------------------------------------------------------------------- INCLUDE "COMM_CTLBLK.f90" !----------------------------------------------------------------------- INCLUDE "COMM_MASKS.f90" !----------------------------------------------------------------------- INCLUDE "COMM_VRBLS.f90" !----------------------------------------------------------------------- INCLUDE "COMM_PVRBLS.f90" !----------------------------------------------------------------------- INCLUDE "COMM_CLDWTR.f90" !----------------------------------------------------------------------- INCLUDE "COMM_BOCO.f90" !----------------------------------------------------------------------- INCLUDE "COMM_MAPOT.f90" !----------------------------------------------------------------------- INCLUDE "COMM_NHYDRO.f90" !----------------------------------------------------------------------- !*********************************************************************** !--------------READ FRESH BOUNDARY DATA IF NECESSARY-------------------- IF(NTSD-1 == NBOCO)THEN IF(MYPE == 0 .AND. NEST)THEN NREC=NINT((NTSD-1)*ABS(DT)/3600.)+2 READ(NBC,REC=NREC)BCHR & , ((PDB(K,N),K=1,LB),N=1,2) & , (((TB(K,L,N),K=1,LB),L=1,LM),N=1,2) & , (((QB(K,L,N),K=1,LB),L=1,LM),N=1,2) & , (((UB(K,L,N),K=1,LB),L=1,LM),N=1,2) & , (((VB(K,L,N),K=1,LB),L=1,LM),N=1,2) & , (((Q2B(K,L,N),K=1,LB),L=1,LM),N=1,2) & , (((CWMB(K,L,N),K=1,LB),L=1,LM),N=1,2) ENDIF IF(MYPE == 0 .AND. .NOT. NEST)THEN READ(NBC)PDB READ(NBC)TB READ(NBC)QB READ(NBC)UB READ(NBC)VB READ(NBC)Q2B READ(NBC)CWMB ENDIF CALL MPI_BCAST(PDB,ISIZ1,MPI_REAL,0,MPI_COMM_COMP,IRTN) CALL MPI_BCAST(TB,ISIZ2,MPI_REAL,0,MPI_COMM_COMP,IRTN) ! c CALL MPI_BCAST(QB,ISIZ2,MPI_REAL,0,MPI_COMM_COMP,IRTN) CALL MPI_BCAST(UB,ISIZ2,MPI_REAL,0,MPI_COMM_COMP,IRTN) CALL MPI_BCAST(VB,ISIZ2,MPI_REAL,0,MPI_COMM_COMP,IRTN) CALL MPI_BCAST(Q2B,ISIZ2,MPI_REAL,0,MPI_COMM_COMP,IRTN) ! c CALL MPI_BCAST(CWMB,ISIZ2,MPI_REAL,0,MPI_COMM_COMP,IRTN) !*** !*** FIND NEXT BOUNDARY CONDITION READ !*** IF(NTSD < NTSTM)THEN IF(MYPE == 0 .AND. NEST)BCHR=BCHR+1 ! This assumes 1-hrly BCs IF(MYPE == 0 .AND. .NOT. NEST)READ(NBC)BCHR CALL MPI_BCAST(BCHR,1,MPI_REAL,0,MPI_COMM_COMP,IRTN) NBOCO=INT(BCHR*TSPH+0.5) ENDIF ENDIF !----------------------------------------------------------------------- !----------------------------------------------------------------------- IIM=IM-MY_IS_GLB+1 JJM=JM-MY_JS_GLB+1 !-------------------------------------------------------------- !*** !*** UPDATE THE SURFACE PRESSURE !*** !-------------------------------------------------------------- N=1 DO 101 I=1,IM PDB(N,1)=PDB(N,1)+PDB(N,2)*DT IF(MY_JS_GLB == 1 .AND. I >= MY_IS_GLB-ILPAD1 & .AND.I <= MY_IE_GLB+IRPAD1)THEN II=I-MY_IS_GLB+1 PD(II,1)=PDB(N,1) ENDIF N=N+1 101 END DO DO 102 I=1,IM PDB(N,1)=PDB(N,1)+PDB(N,2)*DT IF(MY_JE_GLB == JM .AND. I >= MY_IS_GLB-ILPAD1 & .AND.I <= MY_IE_GLB+IRPAD1)THEN II=I-MY_IS_GLB+1 PD(II,JJM)=PDB(N,1) ENDIF N=N+1 102 END DO DO 103 J=3,JM-2,2 PDB(N,1)=PDB(N,1)+PDB(N,2)*DT IF(MY_IS_GLB == 1 .AND. J >= MY_JS_GLB-JBPAD1 & .AND.J <= MY_JE_GLB+JTPAD1)THEN JJ=J-MY_JS_GLB+1 PD(1,JJ)=PDB(N,1) ENDIF N=N+1 103 END DO DO 104 J=3,JM-2,2 PDB(N,1)=PDB(N,1)+PDB(N,2)*DT IF(MY_IE_GLB == IM .AND. J >= MY_JS_GLB-JBPAD1 & .AND.J <= MY_JE_GLB+JTPAD1)THEN JJ=J-MY_JS_GLB+1 PD(IIM,JJ)=PDB(N,1) ENDIF N=N+1 104 END DO !-------------------------------------------------------------- !*** !*** UPDATE THE 3-D MASS VARIABLES !*** !-------------------------------------------------------------- DO 115 L=1,LM !-------------------------------------------------------------- N=1 DO 111 I=1,IM TB(N,L,1)=TB(N,L,1)+TB(N,L,2)*DT Q2B(N,L,1)=Q2B(N,L,1)+Q2B(N,L,2)*DT IF(MY_JS_GLB == 1 .AND. I >= MY_IS_GLB-ILPAD1 & .AND.I <= MY_IE_GLB+IRPAD1)THEN II=I-MY_IS_GLB+1 T(II,1,L)=TB(N,L,1) Q2(II,1,L)=Q2B(N,L,1) PINT(II,1,L+1)=PD(II,1)*ETA(L+1)+PT ENDIF N=N+1 111 END DO DO 112 I=1,IM TB(N,L,1)=TB(N,L,1)+TB(N,L,2)*DT Q2B(N,L,1)=Q2B(N,L,1)+Q2B(N,L,2)*DT IF(MY_JE_GLB == JM .AND. I >= MY_IS_GLB-ILPAD1 & .AND.I <= MY_IE_GLB+IRPAD1)THEN II=I-MY_IS_GLB+1 T(II,JJM,L)=TB(N,L,1) Q2(II,JJM,L)=Q2B(N,L,1) PINT(II,JJM,L+1)=PD(II,JJM)*ETA(L+1)+PT ENDIF N=N+1 112 END DO DO 113 J=3,JM-2,2 TB(N,L,1)=TB(N,L,1)+TB(N,L,2)*DT Q2B(N,L,1)=Q2B(N,L,1)+Q2B(N,L,2)*DT IF(MY_IS_GLB == 1 .AND. J >= MY_JS_GLB-JBPAD1 & .AND.J <= MY_JE_GLB+JTPAD1)THEN JJ=J-MY_JS_GLB+1 T(1,JJ,L)=TB(N,L,1) Q2(1,JJ,L)=Q2B(N,L,1) PINT(1,JJ,L+1)=PD(1,JJ)*ETA(L+1)+PT ENDIF N=N+1 113 END DO DO 114 J=3,JM-2,2 TB(N,L,1)=TB(N,L,1)+TB(N,L,2)*DT Q2B(N,L,1)=Q2B(N,L,1)+Q2B(N,L,2)*DT IF(MY_IE_GLB == IM .AND. J >= MY_JS_GLB-JBPAD1 & .AND.J <= MY_JE_GLB+JTPAD1)THEN JJ=J-MY_JS_GLB+1 T(IIM,JJ,L)=TB(N,L,1) Q2(IIM,JJ,L)=Q2B(N,L,1) PINT(IIM,JJ,L+1)=PD(IIM,JJ)*ETA(L+1)+PT ENDIF N=N+1 114 END DO 115 END DO !-------------------------------------------------------------------- !------- SPACE INTERPOLATION OF PD AND T AT THE INNER BOUNDARY ------ !-------------------------------------------------------------------- IF(IBROW == 1)THEN DO 121 I=MYIS,MYIE1 SHTM=HTM(I,1,LM)+HTM(I+1,1,LM)+HTM(I,3,LM)+HTM(I+1,3,LM) PD(I,2)=(PD(I,1)*HTM(I,1,LM)+PD(I+1,1)*HTM(I+1,1,LM) & +PD(I,3)*HTM(I,3,LM)+PD(I+1,3)*HTM(I+1,3,LM))/SHTM 121 END DO ENDIF IF(ITROW == 1)THEN DO 122 I=MYIS,MYIE1 SHTM=HTM(I,JJM-2,LM)+HTM(I+1,JJM-2,LM)+HTM(I,JJM,LM) & +HTM(I+1,JJM,LM) PD(I,JJM-1)=(PD(I,JJM-2)*HTM(I,JJM-2,LM) & +PD(I+1,JJM-2)*HTM(I+1,JJM-2,LM) & +PD(I,JJM)*HTM(I,JJM,LM) & +PD(I+1,JJM)*HTM(I+1,JJM,LM))/SHTM 122 END DO ENDIF IF(ILCOL == 1)THEN DO 123 J=4,JM-3,2 IF(MY_IS_GLB == 1 .AND. J >= MY_JS_GLB-JBPAD1 & .AND.J <= MY_JE_GLB+JTPAD1)THEN JJ=J-MY_JS_GLB+1 SHTM=HTM(1,JJ-1,LM)+HTM(2,JJ-1,LM)+HTM(1,JJ+1,LM) & +HTM(2,JJ+1,LM) PD(1,JJ)=(PD(1,JJ-1)*HTM(1,JJ-1,LM) & +PD(2,JJ-1)*HTM(2,JJ-1,LM) & +PD(1,JJ+1)*HTM(1,JJ+1,LM) & +PD(2,JJ+1)*HTM(2,JJ+1,LM))/SHTM ENDIF 123 END DO ENDIF IF(IRCOL == 1)THEN DO 124 J=4,JM-3,2 IF(MY_IE_GLB == IM .AND. J >= MY_JS_GLB-JBPAD1 & .AND.J <= MY_JE_GLB+JTPAD1)THEN JJ=J-MY_JS_GLB+1 SHTM=HTM(IIM-1,JJ-1,LM)+HTM(IIM,JJ-1,LM) & +HTM(IIM-1,JJ+1,LM)+HTM(IIM,JJ+1,LM) PD(IIM-1,JJ)=(PD(IIM-1,JJ-1)*HTM(IIM-1,JJ-1,LM) & +PD(IIM,JJ-1)*HTM(IIM,JJ-1,LM) & +PD(IIM-1,JJ+1)*HTM(IIM-1,JJ+1,LM) & +PD(IIM,JJ+1)*HTM(IIM,JJ+1,LM))/SHTM ENDIF 124 END DO ENDIF !-------------------------------------------------------------------- DO 135 L=1,LM !-------------------------------------------------------------------- IF(IBROW == 1)THEN DO 131 I=MYIS,MYIE1 RHTM=1./(HTM(I,1,L)+HTM(I+1,1,L)+HTM(I,3,L)+HTM(I+1,3,L)) T(I,2,L)=(T(I,1,L)*HTM(I,1,L)+T(I+1,1,L)*HTM(I+1,1,L) & +T(I,3,L)*HTM(I,3,L)+T(I+1,3,L)*HTM(I+1,3,L))*RHTM Q2(I,2,L)=(Q2(I,1,L)*HTM(I,1,L)+Q2(I+1,1,L)*HTM(I+1,1,L) & +Q2(I,3,L)*HTM(I,3,L)+Q2(I+1,3,L)*HTM(I+1,3,L))*RHTM PINT(I,2,L+1)=(PINT(I,1,L+1)*HTM(I,1,L) & +PINT(I+1,1,L+1)*HTM(I+1,1,L) & +PINT(I,3,L+1)*HTM(I,3,L) & +PINT(I+1,3,L+1)*HTM(I+1,3,L))*RHTM 131 END DO ENDIF IF(ITROW == 1)THEN DO 132 I=MYIS,MYIE1 RHTM=1./(HTM(I,JJM-2,L)+HTM(I+1,JJM-2,L) & +HTM(I,JJM,L)+HTM(I+1,JJM,L)) T(I,JJM-1,L)=(T(I,JJM-2,L)*HTM(I,JJM-2,L) & +T(I+1,JJM-2,L)*HTM(I+1,JJM-2,L) & +T(I,JJM,L)*HTM(I,JJM,L) & +T(I+1,JJM,L)*HTM(I+1,JJM,L))*RHTM Q2(I,JJM-1,L)=(Q2(I,JJM-2,L)*HTM(I,JJM-2,L) & +Q2(I+1,JJM-2,L)*HTM(I+1,JJM-2,L) & +Q2(I,JJM,L)*HTM(I,JJM,L) & +Q2(I+1,JJM,L)*HTM(I+1,JJM,L))*RHTM PINT(I,JJM-1,L+1)=(PINT(I,JJM-2,L+1)*HTM(I,JJM-2,L) & +PINT(I+1,JJM-2,L+1)*HTM(I+1,JJM-2,L) & +PINT(I,JJM,L+1)*HTM(I,JJM,L) & +PINT(I+1,JJM,L+1)*HTM(I+1,JJM,L))*RHTM 132 END DO ENDIF IF(ILCOL == 1)THEN DO 133 J=4,JM-3,2 IF(MY_IS_GLB == 1 .AND. J >= MY_JS_GLB-JBPAD1 & .AND.J <= MY_JE_GLB+JTPAD1)THEN JJ=J-MY_JS_GLB+1 RHTM=1./(HTM(1,JJ-1,L)+HTM(2,JJ-1,L) & +HTM(1,JJ+1,L)+HTM(2,JJ+1,L)) T(1,JJ,L)=(T(1,JJ-1,L)*HTM(1,JJ-1,L) & +T(2,JJ-1,L)*HTM(2,JJ-1,L) & +T(1,JJ+1,L)*HTM(1,JJ+1,L) & +T(2,JJ+1,L)*HTM(2,JJ+1,L))*RHTM Q2(1,JJ,L)=(Q2(1,JJ-1,L)*HTM(1,JJ-1,L) & +Q2(2,JJ-1,L)*HTM(2,JJ-1,L) & +Q2(1,JJ+1,L)*HTM(1,JJ+1,L) & +Q2(2,JJ+1,L)*HTM(2,JJ+1,L))*RHTM PINT(1,JJ,L+1)=(PINT(1,JJ-1,L+1)*HTM(1,JJ-1,L) & +PINT(2,JJ-1,L+1)*HTM(2,JJ-1,L) & +PINT(1,JJ+1,L+1)*HTM(1,JJ+1,L) & +PINT(2,JJ+1,L+1)*HTM(2,JJ+1,L))*RHTM ENDIF 133 END DO ENDIF IF(IRCOL == 1)THEN DO 134 J=4,JM-3,2 IF(MY_IE_GLB == IM .AND. J >= MY_JS_GLB-JBPAD1 & .AND.J <= MY_JE_GLB+JTPAD1)THEN JJ=J-MY_JS_GLB+1 RHTM=1./(HTM(IIM-1,JJ-1,L)+HTM(IIM,JJ-1,L) & +HTM(IIM-1,JJ+1,L)+HTM(IIM,JJ+1,L)) T(IIM-1,JJ,L)=(T(IIM-1,JJ-1,L)*HTM(IIM-1,JJ-1,L) & +T(IIM,JJ-1,L)*HTM(IIM,JJ-1,L) & +T(IIM-1,JJ+1,L)*HTM(IIM-1,JJ+1,L) & +T(IIM,JJ+1,L)*HTM(IIM,JJ+1,L))*RHTM Q2(IIM-1,JJ,L)=(Q2(IIM-1,JJ-1,L)*HTM(IIM-1,JJ-1,L) & +Q2(IIM,JJ-1,L)*HTM(IIM,JJ-1,L) & +Q2(IIM-1,JJ+1,L)*HTM(IIM-1,JJ+1,L) & +Q2(IIM,JJ+1,L)*HTM(IIM,JJ+1,L))*RHTM PINT(IIM-1,JJ,L+1)=(PINT(IIM-1,JJ-1,L+1)*HTM(IIM-1,JJ-1,L) & +PINT(IIM,JJ-1,L+1)*HTM(IIM,JJ-1,L) & +PINT(IIM-1,JJ+1,L+1)*HTM(IIM-1,JJ+1,L) & +PINT(IIM,JJ+1,L+1)*HTM(IIM,JJ+1,L))*RHTM ENDIF 134 END DO ENDIF 135 END DO !-------------------------------------------------------------------- !-------------------------------------------------------------------- RETURN END SUBROUTINE BOCOHF