SUBROUTINE BOCOHF !>-------------------------------------------------------------------------------------------------- !> SUBROUTINE BOCOHF !> !> SUBPROGRAM: BOCOH - UPDATE MASS POINTS ON BOUNDARY !> PROGRAMMER: 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 !> 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/OUTPUT ARGUMENT LIST: !> NONE !> !> USE MODULES: BOCO !> CLDWTR !> CTLBLK !> DYNAM !> GLB_TABLE !> MAPOT !> MAPPINGS !> MASKS !> MPPCOM !> NHYDRO !> PARMETA !> PVRBLS !> TEMPCOM !> TOPO !> VRBLS !> !> DRIVER : DIGFLT !> NEWFLT !> !> CALLS : MPI_BCAST !>-------------------------------------------------------------------------------------------------- USE BOCO USE CLDWTR USE CTLBLK USE DYNAM USE GLB_TABLE USE MAPOT USE MAPPINGS USE MASKS USE MPPCOM USE NHYDRO USE PARMETA USE PVRBLS USE TEMPCOM USE TOPO USE VRBLS ! IMPLICIT NONE ! INCLUDE "mpif.h" ! #include "sp.h" ! INTEGER(KIND=I4KIND), PARAMETER :: IMJM = IM * JM - JM / 2 !------------------------ ! IMPLICIT NONE VARIABLES !------------------------ INTEGER(KIND=I4KIND) ::& & NREC , JK , JN , JL , IRTN , IIM , JJM , N , I , & & II , J , JJ , K ! REAL (KIND=R4KIND) ::& & BCHR , SHTM , RHTM !-------------------------------------- ! 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,JL,N), K=1,LB), JL=1,LM), N=1,2), & & (((QB(K,JL,N), K=1,LB), JL=1,LM), N=1,2), & & (((UB(K,JL,N), K=1,LB), JL=1,LM), N=1,2), & & (((VB(K,JL,N), K=1,LB), JL=1,LM), N=1,2), & & (((Q2B(K,JL,N), K=1,LB), JL=1,LM), N=1,2), & & (((CWMB(K,JL,N), K=1,LB), JL=1,LM), N=1,2) END IF ! 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 END IF ! CALL MPI_BCAST(PDB, ISIZ1, MPI_REAL, 0, MPI_COMM_COMP, IRTN) CALL MPI_BCAST(TB , 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) !---------------------------------- ! 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) END IF ! END IF ! 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) END IF 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) END IF 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) END IF 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) END IF N = N + 1 104 END DO !------------------------------ ! UPDATE THE 3-D MASS VARIABLES !------------------------------ DO 115 JL=1,LM ! N = 1 DO 111 I=1,IM TB(N,JL,1) = TB(N,JL,1) + TB(N,JL,2) * DT Q2B(N,JL,1) = Q2B(N,JL,1) + Q2B(N,JL,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,JL ) = TB(N,JL,1) Q2(II,1,JL ) = Q2B(N,JL,1) PINT(II,1,JL+1) = PD(II,1) * ETA(JL+1) + PT END IF N = N + 1 111 END DO ! DO 112 I=1,IM TB(N,JL,1) = TB(N,JL,1) + TB(N,JL,2) * DT Q2B(N,JL,1) = Q2B(N,JL,1) + Q2B(N,JL,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,JL ) = TB(N,JL,1) Q2(II,JJM,JL ) = Q2B(N,JL,1) PINT(II,JJM,JL+1) = PD(II,JJM) * ETA(JL+1) + PT END IF N = N + 1 112 END DO ! DO 113 J=3,JM-2,2 TB(N,JL,1) = TB(N,JL,1) + TB(N,JL,2) * DT Q2B(N,JL,1) = Q2B(N,JL,1) + Q2B(N,JL,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,JL ) = TB(N,JL,1) Q2(1,JJ,JL ) = Q2B(N,JL,1) PINT(1,JJ,JL+1) = PD(1,JJ) * ETA(JL+1) + PT END IF N = N + 1 113 END DO ! DO 114 J=3,JM-2,2 TB(N,JL,1) = TB(N,JL,1) + TB(N,JL,2) * DT Q2B(N,JL,1) = Q2B(N,JL,1) + Q2B(N,JL,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,JL ) = TB(N,JL,1) Q2(IIM,JJ,JL ) = Q2B(N,JL,1) PINT(IIM,JJ,JL+1) = PD(IIM,JJ) * ETA(JL+1) + PT END IF 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 END IF ! 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 END IF ! 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 END IF 123 END DO END IF ! 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 END IF 124 END DO END IF ! DO 135 JL=1,LM ! IF (IBROW == 1) THEN DO 131 I=MYIS,MYIE1 RHTM= 1. / (HTM(I,1,JL) + HTM(I+1,1,JL) + HTM(I,3,JL) + HTM(I+1,3,JL)) ! T(I,2,JL ) = (T(I,1,JL ) * HTM(I,1,JL) + T(I+1,1,JL ) * HTM(I+1,1,JL) & & + T(I,3,JL ) * HTM(I,3,JL) + T(I+1,3,JL ) * HTM(I+1,3,JL)) & & * RHTM ! Q2(I,2,JL ) = (Q2(I,1,JL ) * HTM(I,1,JL) + Q2(I+1,1,JL ) * HTM(I+1,1,JL) & & + Q2(I,3,JL ) * HTM(I,3,JL) + Q2(I+1,3,JL ) * HTM(I+1,3,JL)) & & * RHTM ! PINT(I,2,JL+1) = (PINT(I,1,JL+1) * HTM(I,1,JL) + PINT(I+1,1,JL+1) * HTM(I+1,1,JL) & & + PINT(I,3,JL+1) * HTM(I,3,JL) + PINT(I+1,3,JL+1) * HTM(I+1,3,JL)) & & * RHTM 131 END DO END IF ! IF (ITROW == 1) THEN DO 132 I=MYIS,MYIE1 RHTM = 1. / (HTM(I,JJM-2,JL) + HTM(I+1,JJM-2,JL) + HTM(I,JJM,JL) + HTM(I+1,JJM,JL)) ! T(I,JJM-1,JL ) = (T(I ,JJM-2,JL ) * HTM(I ,JJM-2,JL) & & + T(I+1,JJM-2,JL ) * HTM(I+1,JJM-2,JL) & & + T(I ,JJM ,JL ) * HTM(I ,JJM ,JL) & & + T(I+1,JJM ,JL ) * HTM(I+1,JJM ,JL)) & & * RHTM ! Q2(I,JJM-1,JL ) = (Q2(I ,JJM-2,JL ) * HTM(I ,JJM-2,JL) & & + Q2(I+1,JJM-2,JL ) * HTM(I+1,JJM-2,JL) & & + Q2(I ,JJM ,JL ) * HTM(I ,JJM ,JL) & & + Q2(I+1,JJM ,JL ) * HTM(I+1,JJM ,JL)) & & * RHTM ! PINT(I,JJM-1,JL+1) = (PINT(I ,JJM-2,JL+1) * HTM(I ,JJM-2,JL) & & + PINT(I+1,JJM-2,JL+1) * HTM(I+1,JJM-2,JL) & & + PINT(I ,JJM ,JL+1) * HTM(I ,JJM ,JL) & & + PINT(I+1,JJM ,JL+1) * HTM(I+1,JJM ,JL)) & & * RHTM 132 END DO END IF ! 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,JL) + HTM(2,JJ-1,JL) + HTM(1,JJ+1,JL) + HTM(2,JJ+1,JL)) ! T(1,JJ,JL ) = (T(1,JJ-1,JL ) * HTM(1,JJ-1,JL) & & + T(2,JJ-1,JL ) * HTM(2,JJ-1,JL) & & + T(1,JJ+1,JL ) * HTM(1,JJ+1,JL) & & + T(2,JJ+1,JL ) * HTM(2,JJ+1,JL)) & & * RHTM ! Q2(1,JJ,JL ) = (Q2(1,JJ-1,JL ) * HTM(1,JJ-1,JL) & & + Q2(2,JJ-1,JL ) * HTM(2,JJ-1,JL) & & + Q2(1,JJ+1,JL ) * HTM(1,JJ+1,JL) & & + Q2(2,JJ+1,JL ) * HTM(2,JJ+1,JL)) & & * RHTM ! PINT(1,JJ,JL+1) = (PINT(1,JJ-1,JL+1) * HTM(1,JJ-1,JL) & & + PINT(2,JJ-1,JL+1) * HTM(2,JJ-1,JL) & & + PINT(1,JJ+1,JL+1) * HTM(1,JJ+1,JL) & & + PINT(2,JJ+1,JL+1) * HTM(2,JJ+1,JL)) & & * RHTM END IF 133 END DO END IF ! 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,JL) + HTM(IIM,JJ-1,JL) & & + HTM(IIM-1,JJ+1,JL) + HTM(IIM,JJ+1,JL)) ! T(IIM-1,JJ,JL ) = (T(IIM-1,JJ-1,JL ) * HTM(IIM-1,JJ-1,JL) & & + T(IIM ,JJ-1,JL ) * HTM(IIM ,JJ-1,JL) & & + T(IIM-1,JJ+1,JL ) * HTM(IIM-1,JJ+1,JL) & & + T(IIM ,JJ+1,JL ) * HTM(IIM ,JJ+1,JL)) & & * RHTM ! Q2(IIM-1,JJ,JL ) = (Q2(IIM-1,JJ-1,JL ) * HTM(IIM-1,JJ-1,JL) & & + Q2(IIM ,JJ-1,JL ) * HTM(IIM ,JJ-1,JL) & & + Q2(IIM-1,JJ+1,JL ) * HTM(IIM-1,JJ+1,JL) & & + Q2(IIM ,JJ+1,JL ) * HTM(IIM ,JJ+1,JL)) & & * RHTM ! PINT(IIM-1,JJ,JL+1) = (PINT(IIM-1,JJ-1,JL+1) * HTM(IIM-1,JJ-1,JL) & & + PINT(IIM ,JJ-1,JL+1) * HTM(IIM ,JJ-1,JL) & & + PINT(IIM-1,JJ+1,JL+1) * HTM(IIM-1,JJ+1,JL) & & + PINT(IIM ,JJ+1,JL+1) * HTM(IIM ,JJ+1,JL)) & & * RHTM END IF 134 END DO END IF 135 END DO ! RETURN ! END SUBROUTINE BOCOHF