A ROTINA DA ESQUERDA É A VERSÃO ANTIGA DE 2012 E A ROTINA DA DIREITA É A VERSÃO MODULAR DO Eta1km C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& | SUBROUTINE HADZ SUBROUTINE HADZ | !>---------------------------------------------------------------------------------------------- C ****************************************************************** | !> SUBROUTINE HADZ C$$$ SUBPROGRAM DOCUMENTATION BLOCK | !> C . . . | !> SUBPROGRAM: HADZ - HORIZONTAL ADVECTION OF HEIGHT C SUBPROGRAM: HADZ HORIZONTAL ADVECTION OF HEIGHT | !> PROGRAMMER: JANJIC C PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-05-?? | !> ORG: W/NP22 C | !> DATE: 96-05-?? C ABSTRACT: | !> C HADZ CALCULATES DIAGNOSTICALLY THE CONTRIBUTION OF | !> ABSTRACT: C THE HORIZONTAL ADVECTION OF HEIGHT | !> HADZ CALCULATES DIAGNOSTICALLY THE CONTRIBUTION OF THE HORIZONTAL ADVECTION OF HEIGHT C | !> C PROGRAM HISTORY LOG: | !> PROGRAM HISTORY LOG: C 96-05-?? JANJIC - ORIGINATOR | !> 96-05-?? JANJIC - ORIGINATOR C 00-01-04 BLACK - DISTRIBUTED MEMORY AND THREADS | !> 00-01-04 BLACK - DISTRIBUTED MEMORY AND THREADS C | !> 18-01-15 LUCCI - MODERNIZATION OF THE CODE, INCLUDING: C USAGE: CALL HADZ FROM MAIN PROGRAM | !> * F77 TO F90/F95 C INPUT ARGUMENT LIST: | !> * INDENTATION & UNIFORMIZATION CODE C NONE | !> * REPLACEMENT OF COMMONS BLOCK FOR MODULES C | !> * DOCUMENTATION WITH DOXYGEN C OUTPUT ARGUMENT LIST: | !> * OPENMP FUNCTIONALITY C NONE | !> C | !> INPUT ARGUMENT LIST: C OUTPUT FILES: | !> NONE C NONE | !> C | !> OUTPUT ARGUMENT LIST: C SUBPROGRAMS CALLED: | !> NONE C | !> C UNIQUE: NONE | !> INPUT/OUTPUT ARGUMENT LIST: C | !> NONE C LIBRARY: NONE | !> C | !> USE MODULES: CONTIN C COMMON BLOCKS: CTLBLK | !> CTLBLK C LOOPS | !> DYNAM C MASKS | !> F77KINDS C DYNAM | !> GLB_TABLE C VRBLS | !> INDX C CONTIN | !> LOOPS C NHYDRO | !> MAPPINGS C INDX | !> MASKS C ATTRIBUTES: | !> MPPCOM C LANGUAGE: FORTRAN 90 | !> NHYDRO C MACHINE : IBM SP | !> PARMETA C$$$ | !> TEMPCOM C*********************************************************************** | !> TOPO C----------------------------------------------------------------------- | !> VRBLS INCLUDE "parmeta" | !> INCLUDE "mpp.h" | !> DRIVER : EBU C----------------------------------------------------------------------- | !> P A R A M E T E R | !> CALLS : ----- &(JAM=6+2*(JM-10) | !>---------------------------------------------------------------------------------------------- &,IMJM=IM*JM-JM/2,LM1=LM-1,LP1=LM+1) | USE CONTIN P A R A M E T E R | USE CTLBLK &(G=9.8,NTSHY=2) | USE DYNAM C----------------------------------------------------------------------- | USE F77KINDS L O G I C A L | USE GLB_TABLE & RUN,FIRST,RESTRT,SIGMA | USE INDX C---------------------------------------------------------------------- | USE LOOPS INCLUDE "CTLBLK.comm" | USE MAPPINGS C----------------------------------------------------------------------- | USE MASKS INCLUDE "LOOPS.comm" | USE MPPCOM C----------------------------------------------------------------------- | USE NHYDRO INCLUDE "MASKS.comm" | USE PARMETA C----------------------------------------------------------------------- | USE TEMPCOM INCLUDE "DYNAM.comm" | USE TOPO C----------------------------------------------------------------------- | USE VRBLS INCLUDE "VRBLS.comm" | ! c----------------------------------------------------------------------- | IMPLICIT NONE include "CONTIN.comm" | ! C----------------------------------------------------------------------- | INTEGER(KIND=I4KIND), PARAMETER :: IMJM = IM * JM - JM / 2 INCLUDE "NHYDRO.comm" | INTEGER(KIND=I4KIND), PARAMETER :: NTSHY = 2 C----------------------------------------------------------------------- | ! INCLUDE "INDX.comm" | REAL (KIND=R4KIND), PARAMETER :: G = 9.8 C----------------------------------------------------------------------- | R E A L | ! & HBMS (IDIM1:IDIM2,JDIM1:JDIM2),DPDE (IDIM1:IDIM2,JDIM1:JDIM2) | REAL (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2) &,UDY (IDIM1:IDIM2,JDIM1:JDIM2),VDX (IDIM1:IDIM2,JDIM1:JDIM2) | & HBMS , DPDE , &,UNED (IDIM1:IDIM2,JDIM1:JDIM2),USED (IDIM1:IDIM2,JDIM1:JDIM2) | & UDY , VDX , &,ZEW (IDIM1:IDIM2,JDIM1:JDIM2),ZNS (IDIM1:IDIM2,JDIM1:JDIM2) | & UNED , USED , &,ZNE (IDIM1:IDIM2,JDIM1:JDIM2),ZSE (IDIM1:IDIM2,JDIM1:JDIM2) | & ZEW , ZNS , C----------------------------------------------------------------------- | & ZNE , ZSE C | !------------------------ IF(NTSD.LE.NTSHY.OR.HYDRO)THEN | ! IMPLICIT NONE VARIABLES !$omp parallel do | !------------------------ DO L=1,LM | INTEGER(KIND=I4KIND) DO J=MYJS,MYJE | & I , J , K , IX , JX , IVH , IVL , IHH , IHL DO I=MYIS,MYIE | ! W(I,J,L)=0. | IF (NTSD <= NTSHY .OR. HYDRO) THEN ENDDO | !------- ENDDO | ! OPENMP ENDDO | !------- C*** | ! RETURN | !$omp parallel do C*** | ! ENDIF | DO K=1,LM C*********************************************************************** | DO J=MYJS,MYJE C----------------------------------------------------------------------- | DO I=MYIS,MYIE !$omp parallel do | W(I,J,K) = 0. !$omp& private (dpde,ihh,ihl,ivh,ivl,ix,jx,udy,uned,used, | END DO !$omp& vdx,zew,zne,zns,zse) | END DO DO 200 L=1,LM | END DO C----------------------------------------------------------------------- | ! DO J=MYJS_P3,MYJE_P3 | RETURN DO I=MYIS_P3,MYIE_P3 | ! DPDE(I,J)=PDSL(I,J)*DETA(L) | END IF ENDDO | !------- ENDDO | ! OPENMP C----------------------------------------------------------------------- | !------- C--------------MASS FLUXES AND MASS POINTS ADVECTION COMPONENTS--------- | ! C----------------------------------------------------------------------- | !$omp parallel do DO 125 J=2,JM-1 | ! IF(J.GE.MY_JS_GLB-JBPAD2.AND.J.LE.MY_JE_GLB+JTPAD2)THEN | !$omp private (DPDE , IHH , IHL , IVH , IVL , IX , JX , UDY , JX=J-MY_JS_GLB+1 | !$omp UNED , USED , VDX , ZEW , ZNE , ZNS , ZSE ) IVL=2-MOD(J,2) | ! IVH=IM-1 | DO 200 K=1,LM C | ! DO 120 I=IVL,IVH | DO J=MYJS_P3,MYJE_P3 IF(I.GE.MY_IS_GLB-ILPAD2.AND.I.LE.MY_IE_GLB+IRPAD2)THEN | DO I=MYIS_P3,MYIE_P3 IX=I-MY_IS_GLB+1 | DPDE(I,J) = PDSL(I,J) * DETA(K) UDY(IX,JX)=U(IX,JX,L)*DY | END DO ZEW(IX,JX)=UDY(IX,JX) | END DO 1 *(DPDE(IX+IVW(JX),JX )+DPDE(IX+IVE(JX),JX )) | !------------------------------------------------- 2 *(Z (IX+IVE(JX),JX,L)-Z (IX+IVW(JX),JX,L)) | ! MASS FLUXES AND MASS POINTS ADVECTION COMPONENTS VDX(IX,JX)=V(IX,JX,L)*DX(IX,JX) | !------------------------------------------------- ZNS(IX,JX)=VDX(IX,JX) | DO 125 J=2,JM-1 1 *(DPDE(IX ,JX-1 )+DPDE(IX ,JX+1 )) | IF (J >= MY_JS_GLB-JBPAD2 .AND. J <= MY_JE_GLB+JTPAD2) THEN 2 *(Z (IX ,JX+1,L)-Z (IX ,JX-1,L)) | JX = J - MY_JS_GLB + 1 UNED(IX,JX)=UDY(IX,JX)+VDX(IX,JX) | IVL = 2 - MOD(J,2) USED(IX,JX)=UDY(IX,JX)-VDX(IX,JX) | IVH = IM - 1 ENDIF | ! 120 CONTINUE | DO 120 I=IVL,IVH ENDIF | IF (I >= MY_IS_GLB-ILPAD2 .AND. I <= MY_IE_GLB+IRPAD2) THEN 125 CONTINUE | IX = I - MY_IS_GLB + 1 C----------------------------------------------------------------------- | UDY(IX,JX) = U(IX,JX,K) * DY C--------------DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND------------- | ZEW(IX,JX) = UDY(IX,JX) * (DPDE(IX + IVW(JX), JX) C----------------------------------------------------------------------- | & + DPDE(IX + IVE(JX), JX)) DO 145 J=2,JM-2 | & * (Z(IX + IVE(JX), JX,K) IF(J.GE.MY_JS_GLB-JBPAD1.AND.J.LE.MY_JE_GLB+JTPAD1)THEN | & - Z(IX + IVW(JX), JX,K)) JX=J-MY_JS_GLB+1 | ! IHL=2-MOD(J+1,2) | VDX(IX,JX) = V(IX,JX,K) * DX(IX,JX) IHH=IM-2+MOD(J,2) | ZNS(IX,JX) = VDX(IX,JX) * (DPDE(IX,JX-1) + DPDE(IX,JX+1)) C | & * (Z(IX,JX+1,K) - Z(IX,JX-1,K)) DO 140 I=IHL,IHH | UNED(IX,JX) = UDY(IX,JX) + VDX(IX,JX) IF(I.GE.MY_IS_GLB-ILPAD1.AND.I.LE.MY_IE_GLB+IRPAD1)THEN | USED(IX,JX) = UDY(IX,JX) - VDX(IX,JX) IX=I-MY_IS_GLB+1 | END IF ZNE(IX,JX)=(UNED(IX+IHE(JX),JX) +UNED(IX ,JX+1)) | 120 END DO 1 *(DPDE(IX ,JX) +DPDE(IX+IHE(JX),JX+1)) | ! 2 *(Z (IX+IHE(JX),JX+1,L)-Z (IX ,JX ,L)) | END IF ENDIF | 125 END DO 140 CONTINUE | !--------------------------------------------- ENDIF | ! DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND 145 CONTINUE | !--------------------------------------------- C | DO 145 J=2,JM-2 DO 165 J=3,JM-1 | IF (J >= MY_JS_GLB-JBPAD1 .AND. J <= MY_JE_GLB+JTPAD1) THEN IF(J.GE.MY_JS_GLB-JBPAD1.AND.J.LE.MY_JE_GLB+JTPAD1)THEN | JX = J - MY_JS_GLB + 1 JX=J-MY_JS_GLB+1 | IHL = 2 - MOD(J+1,2) IHL=2-MOD(J+1,2) | IHH = IM - 2 + MOD(J ,2) IHH=IM-2+MOD(J,2) | ! C | DO 140 I=IHL,IHH DO 160 I=IHL,IHH | IF (I >= MY_IS_GLB-ILPAD1 .AND. I <= MY_IE_GLB+IRPAD1) THEN IF(I.GE.MY_IS_GLB-ILPAD1.AND.I.LE.MY_IE_GLB+IRPAD1)THEN | IX = I - MY_IS_GLB + 1 IX=I-MY_IS_GLB+1 | ! ZSE(IX,JX)=(USED(IX+IHE(JX),JX ) +USED(IX ,JX-1 )) | ZNE(IX,JX) = (UNED(IX + IHE(JX), JX ) 1 *(DPDE(IX ,JX ) +DPDE(IX+IHE(JX),JX-1 )) | & + UNED(IX , JX+1)) 2 *(Z (IX+IHE(JX),JX-1,L)-Z (IX ,JX ,L)) | & * (DPDE(IX , JX ) ENDIF | & + DPDE(IX + IHE(JX), JX+1)) 160 CONTINUE | & * (Z(IX + IHE(JX), JX+1, K) ENDIF | & - Z(IX , JX , K)) 165 CONTINUE | END IF C----------------------------------------------------------------------- | 140 END DO C--------------ADVECTION OF Z------------------------------------------- | ! C----------------------------------------------------------------------- | END IF c DO 170 J=4,JM-3 | 145 END DO c IF(J.GE.MY_JS_GLB.AND.J.LE.MY_JE_GLB)THEN | ! c IHL=2+MOD(J,2) | DO 165 J=3,JM-1 c IHH=IM-2 | IF (J >= MY_JS_GLB-JBPAD1 .AND. J <= MY_JE_GLB+JTPAD1) THEN c DO 171 I=IHL,IHH | JX = J - MY_JS_GLB + 1 c | IHL = 2 - MOD(J+1, 2) DO 175 J=3,JM-2 | IHH = IM - 2 + MOD(J , 2) IF(J.GE.MY_JS_GLB.AND.J.LE.MY_JE_GLB)THEN | ! JX=J-MY_JS_GLB+1 | DO 160 I=IHL,IHH IHL=2 | IF (I >= MY_IS_GLB-ILPAD1 .AND. I <= MY_IE_GLB+IRPAD1) THEN IHH=IM-2+MOD(J,2) | IX = I - MY_IS_GLB + 1 C | ! DO 170 I=IHL,IHH | ZSE(IX,JX) = (USED(IX + IHE(JX), JX ) IF(I.GE.MY_IS_GLB.AND.I.LE.MY_IE_GLB)THEN | & + USED(IX , JX-1)) IX=I-MY_IS_GLB+1 | & * (DPDE(IX , JX ) W(IX,JX,L)= | & + DPDE(IX + IHE(JX), JX-1)) 1 -(ZEW(IX+IHW(JX),JX )+ZEW(IX+IHE(JX),JX ) | & * (Z(IX + IHE(JX), JX-1, K) 1 +ZNS(IX ,JX-1)+ZNS(IX ,JX+1) | & - Z(IX , JX , K)) 2 +ZNE(IX+IHW(JX),JX-1)+ZNE(IX ,JX ) | END IF 2 +ZSE(IX ,JX )+ZSE(IX+IHW(JX),JX+1)) | 160 END DO 3 *FAD(IX,JX)*HTM(IX,JX,L)*HBM2(IX,JX)/(DPDE(IX,JX)*DT) | ! 4 +W(IX,JX,L) | END IF ENDIF | 165 END DO 170 CONTINUE | !--------------- ENDIF | ! ADVECTION OF Z 175 CONTINUE | !--------------- C----------------------------------------------------------------------- | DO 175 J=3,JM-2 200 CONTINUE | IF (J >= MY_JS_GLB .AND. J <= MY_JE_GLB) THEN C----------------------------------------------------------------------- | JX = J - MY_JS_GLB + 1 C*********************************************************************** | IHL = 2 c NSMUD=7 | IHH = IM - 2 + MOD(J,2) c DO J=MYJS,MYJE | ! c DO I=MYIS,MYIE | DO 170 I=IHL,IHH c HBMS(I,J)=HBM2(I,J) | IF (I >= MY_IS_GLB .AND. I <= MY_IE_GLB) THEN c ENDDO | IX = I - MY_IS_GLB + 1 c ENDDO | ! cC | W(IX,JX,K) = -(ZEW(IX + IHW(JX), JX) + ZEW(IX + IHE(JX), JX ) cC JHL MUST BE ODD!!! | & + ZNS(IX , JX-1) + ZNS(IX , JX+1) c JHL=9 | & + ZNE(IX + IHW(JX), JX-1) + ZNE(IX , JX ) c JHH=JM-JHL+1 | & + ZSE(IX , JX ) + ZSE(IX + IHW(JX), JX+1)) cC | & * FAD(IX , JX ) c DO 225 J=JHL,JHH | & * HTM(IX,JX,K) * HBM2(IX,JX) / (DPDE(IX,JX) * DT) c IF(J.GE.MY_JS_GLB.AND.J.LE.MY_JE_GLB)THEN | & + W(IX,JX,K) c JX=J-MY_JS_GLB+1 | END IF c IHL=JHL/2+1 | 170 END DO c IHH=IM-IHL+MOD(J,2) | ! c DO I=IHL,IHH | END IF c IF(I.GE.MY_IS_GLB.AND.I.LE.MY_IE_GLB)THEN | 175 END DO c IX=I-MY_IS_GLB+1 | ! c HBMS(IX,JX)=0. | 200 END DO c ENDDO | ! c ENDIF | RETURN c 225 CONTINUE | ! cC----------------------------------------------------------------------- | END SUBROUTINE HADZ c!#omp paralle do private (ihh,ihl,ix,jx,zne,zse) < c DO 300 L=1,LM < cC----------------------------------------------------------------------- < c DO KS=1,NSMUD < cC < c DO J=MYJS,MYJE1 < c DO I=MYIS,MYIE1 < c ZNE(I,J)=(W(I+IHE(J),J+1,L)-W(I,J,L)) < c & *HTM(I,J,L)*HTM(I+IHE(J),J+1,L) < c ENDDO < c ENDDO < cC < c DO J=MYJS1,MYJE < c DO I=MYIS,MYIE1 < c ZSE(I,J)=(W(I+IHE(J),J-1,L)-W(I,J,L)) < c & *HTM(I+IHE(J),J-1,L)*HTM(I,J,L) < c ENDDO < c ENDDO < cC < c DO 250 J=3,JM-2 < c IF(J.GE.MY_JS_GLB.AND.J.LE.MY_JE_GLB)THEN < c JX=J-MY_JS_GLB+1 < c IHL=2 < c IHH=IM-2+MOD(J,2) < cC < c DO 245 I=2,IM-2 < c IF(I.GE.MY_IS_GLB.AND.I.LE.MY_IE_GLB)THEN < c IX=I-MY_IS_GLB+1 < c W(IX,JX,L)=(ZNE(IX,JX)-ZNE(IX+IHW(JX),JX-1) < c & +ZSE(IX,JX)-ZSE(IX+IHW(JX),JX+1)) < c & *HBMS(IX,JX)*0.125+W(IX,JX,L) < c ENDIF < c 245 CONTINUE < c ENDIF < c 250 CONTINUE < c ENDDO < cC---------------------------------------------------------------------- < c 300 CONTINUE < cC---------------------------------------------------------------------- < RETURN < END <