A ROTINA DA ESQUERDA É A VERSÃO ANTIGA DE 2012 E A ROTINA DA DIREITA É A VERSÃO MODULAR DO Eta1km SUBROUTINE PGCOR | SUBROUTINE PGCOR C ****************************************************************** | !>---------------------------------------------------------------------------------------------- C$$$ SUBPROGRAM DOCUMENTATION BLOCK | !> SUBROUTINE PGCOR C . . . | !> C SUBPROGRAM: PGCOR PRESSURE GRADIENT/CORIOLIS CALC | !> SUBROUTINE: PGCOR - PRESSURE GRADIENT/CORIOLIS CALC C PRGRMMR: JANJIC ORG: W/NP22 DATE: 93-10-28 | !> PROGRAMMER: JANJIC C | !> ORG: W/NP22 C ABSTRACT: | !> DATE: 93-10-28 C PGCOR CALCULATES THE PRESSURE GRADIENT FORCE, UPDATES THE | !> C VELOCITY COMPONENTS DUE TO THE EFFECT OF THE PRESSURE GRADIENT | !> ABSTRACT: C AND CORIOLIS FORCES. | !> PGCOR CALCULATES THE PRESSURE GRADIENT FORCE, UPDATES THE VELOCITY COMPONENTS DUE TO THE EFFE C | !> OF THE PRESSURE GRADIENT AND CORIOLIS FORCES. C PROGRAM HISTORY LOG: | !> C 87-06-?? JANJIC - ORIGINATOR | !> PROGRAM HISTORY LOG: C 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL | !> 87-06-?? JANJIC - ORIGINATOR C 96-03-29 BLACK - ADDED EXTERNAL EDGE | !> 95-03-25 BLACK - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL C 97-03-17 MESINGER - SPLIT FROM PFDHT | !> 96-03-29 BLACK - ADDED EXTERNAL EDGE C 98-10-28 BLACK - MODIFIED FOR DISTRIBUTED MEMORY | !> 97-03-17 MESINGER - SPLIT FROM PFDHT C 00-10-20 BLACK - INCORPORATED PRESSURE GRADIENT METHOD | !> 98-10-28 BLACK - MODIFIED FOR DISTRIBUTED MEMORY C FROM MESO MODEL | !> 00-10-20 BLACK - INCORPORATED PRESSURE GRADIENT METHOD FROM MESO MODEL C | !> 18-01-15 LUCCI - MODERNIZATION OF THE CODE, INCLUDING: C USAGE: CALL PGCOR FROM MAIN PROGRAM EBU | !> * 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 | !> OUTPUT FILES: C COMMON BLOCKS: CTLBLK | !> NONE C MASKS | !> C LOOPS | !> USE MODULES: CONTIN C DYNAM | !> CTLBLK C VRBLS | !> DYNAM C CONTIN | !> F77KINDS C NHYDRO | !> GLB_TABLE C INDX | !> INDX C | !> LOOPS C ATTRIBUTES: | !> MAPPINGS C LANGUAGE: FORTRAN 90 | !> MASKS C MACHINE : IBM SP | !> MPPCOM C$$$ | !> NHYDRO C*********************************************************************** | !> PARMETA C----------------------------------------------------------------------- | !> TEMPCOM INCLUDE "parmeta" | !> TOPO INCLUDE "mpp.h" | !> VRBLS C----------------------------------------------------------------------- | !> P A R A M E T E R | !> DRIVER : DIGFLT & (LP1=LM+1,JAM=6+2*(JM-10)) | !> EBU C----------------------------------------------------------------------- | !> NEWFLT L O G I C A L | !> & RUN,FIRST,RESTRT,SIGMA | !> CALLS : ZERO2 C---------------------------------------------------------------------- | !>---------------------------------------------------------------------------------------------- INCLUDE "CTLBLK.comm" | USE CONTIN c----------------------------------------------------------------------- | USE CTLBLK include "LOOPS.comm" | USE DYNAM C----------------------------------------------------------------------- | USE F77KINDS INCLUDE "MASKS.comm" | USE GLB_TABLE C----------------------------------------------------------------------- | USE INDX INCLUDE "INDX.comm" | USE LOOPS c----------------------------------------------------------------------- | USE MAPOT INCLUDE "DYNAM.comm" | USE MAPPINGS C----------------------------------------------------------------------- | USE MASKS INCLUDE "VRBLS.comm" | USE MPPCOM c----------------------------------------------------------------------- | USE NHYDRO INCLUDE "CONTIN.comm" | USE PARMETA c----------------------------------------------------------------------- | USE TEMPCOM INCLUDE "NHYDRO.comm" | USE TOPO c----------------------------------------------------------------------- | USE VRBLS R E A L | ! & PINTLG(IDIM1:IDIM2,JDIM1:JDIM2,LM+1) | IMPLICIT NONE C | ! R E A L | REAL (KIND=R8KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2, LM+1) & FIM (IDIM1:IDIM2,JDIM1:JDIM2) | & PINTLG &,FILO (IDIM1:IDIM2,JDIM1:JDIM2),RDPD (IDIM1:IDIM2,JDIM1:JDIM2) | &,ADPDX (IDIM1:IDIM2,JDIM1:JDIM2),RDPDX (IDIM1:IDIM2,JDIM1:JDIM2) | REAL (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2) &,ADPDY (IDIM1:IDIM2,JDIM1:JDIM2),RDPDY (IDIM1:IDIM2,JDIM1:JDIM2) | & FIM , &,ADPDNE(IDIM1:IDIM2,JDIM1:JDIM2),ADPDSE(IDIM1:IDIM2,JDIM1:JDIM2) | & FILO , RDPD , &,PEW (IDIM1:IDIM2,JDIM1:JDIM2),PNS (IDIM1:IDIM2,JDIM1:JDIM2) | & ADPDX , RDPDX , &,PCEW (IDIM1:IDIM2,JDIM1:JDIM2),PCNS (IDIM1:IDIM2,JDIM1:JDIM2) | & ADPDY , RDPDY , &,DPFEW (IDIM1:IDIM2,JDIM1:JDIM2),DPFNS (IDIM1:IDIM2,JDIM1:JDIM2) | & ADPDNE , ADPDSE , &,FNS (IDIM1:IDIM2,JDIM1:JDIM2),TNS (IDIM1:IDIM2,JDIM1:JDIM2) | & PEW , PNS , &,HM (IDIM1:IDIM2,JDIM1:JDIM2),VM (IDIM1:IDIM2,JDIM1:JDIM2) | & PCEW , PCNS , C | & DPFEW , DPFNS , R E A L | & FNS , TNS , & DPDE (IDIM1:IDIM2,JDIM1:JDIM2) | & HM , VM &,APEL (IDIM1:IDIM2,JDIM1:JDIM2) | ! &,ALP1 (IDIM1:IDIM2,JDIM1:JDIM2) | REAL (KIND=R4KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2) &,DFDZ (IDIM1:IDIM2,JDIM1:JDIM2) | & DPDE , &,PNE (IDIM1:IDIM2,JDIM1:JDIM2),PSE (IDIM1:IDIM2,JDIM1:JDIM2) | & PNE , PSE , &,CNE (IDIM1:IDIM2,JDIM1:JDIM2),CSE (IDIM1:IDIM2,JDIM1:JDIM2) | & CNE , CSE , &,PPNE (IDIM1:IDIM2,JDIM1:JDIM2),PPSE (IDIM1:IDIM2,JDIM1:JDIM2) | & PPNE , PPSE , &,PCNE (IDIM1:IDIM2,JDIM1:JDIM2),PCSE (IDIM1:IDIM2,JDIM1:JDIM2) | & PCNE , PCSE C----------------------------------------------------------------------- | ! C----------------------------------------------------------------------- | REAL (KIND=R8KIND), DIMENSION(IDIM1:IDIM2, JDIM1:JDIM2) CALL ZERO2(ALP1) | & APEL , CALL ZERO2(DPDE) | & ALP1 , CALL ZERO2(APEL) | & DFDZ CALL ZERO2(ADPDX) | !------------------------ CALL ZERO2(ADPDY) | ! IMPLICIT NONE VARIABLES CALL ZERO2(DFDZ) | !------------------------ CALL ZERO2(PNE) | INTEGER(KIND=I4KIND) CALL ZERO2(PSE) | & I , J , K CALL ZERO2(CNE) | ! CALL ZERO2(CSE) | REAL (KIND=R4KIND) CALL ZERO2(PPNE) | & RDPDS , FIUPK , F0K , CALL ZERO2(PPSE) | & DPNEK , DPSEK , CALL ZERO2(PCNE) | & DCNEK , DCSEK , CALL ZERO2(PCSE) | & DPFNEK , DPFSEK , C----------------------------------------------------------------------- | & UPK , VPK , C--------------PREPARATORY CALCULATIONS--------------------------------- | & UTK , VTK C----------------------------------------------------------------------- | ! IF(SIGMA)THEN | REAL (KIND=R8KIND) !$omp parallel do | & ALP1P , ALP1PL , DO 50 J=MYJS_P5,MYJE_P5 | & ALP2P , ALP2PL , DO 50 I=MYIS_P5,MYIE_P5 | & DFI , FILO(I,J)=FIS(I,J) | & TMP1 , TMP2 , TMP3 PDSL(I,J)=PD(I,J) | ! 50 CONTINUE | CALL ZERO2(DPDE) ELSE | CALL ZERO2(APEL) !$omp parallel do | CALL ZERO2(ADPDX) DO 100 J=MYJS_P5,MYJE_P5 | CALL ZERO2(ADPDY) DO 100 I=MYIS_P5,MYIE_P5 | CALL ZERO2(DFDZ) FILO(I,J)=0.0 | CALL ZERO2(PNE) PDSL(I,J)=RES(I,J)*PD(I,J) | CALL ZERO2(PSE) 100 CONTINUE | CALL ZERO2(CNE) ENDIF | CALL ZERO2(CSE) C | CALL ZERO2(PPNE) IF(HYDRO)THEN | CALL ZERO2(PPSE) !$omp parallel do | CALL ZERO2(PCNE) DO L=1,LM+1 | CALL ZERO2(PCSE) DO J=MYJS_P5,MYJE_P5 | !------------------------- DO I=MYIS_P5,MYIE_P5 | ! PREPARATORY CALCULATIONS PINTLG(I,J,L)=ALOG(ETA(L)*PDSL(I,J)+PT) | !------------------------- ENDDO | IF (SIGMA) THEN ENDDO | ! ENDDO | !$omp parallel do ELSE | ! !$omp parallel do | DO 50 J=MYJS_P5,MYJE_P5 DO L=1,LM+1 | DO 50 I=MYIS_P5,MYIE_P5 DO J=MYJS_P5,MYJE_P5 | FILO(I,J) = FIS(I,J) DO I=MYIS_P5,MYIE_P5 | PDSL(I,J) = PD(I,J) PINTLG(I,J,L)=ALOG(PINT(I,J,L)) | 50 END DO if (L.GT.1) then | ! if (PINTLG(I,J,L) .eq. PINTLG(I,J,L-1)) then | ELSE write(6,*) 'same pintlg at different levels: ', MYPE,I,J,L,LMH(I,J) | ! write(6,*) 'PINT vals: ', PINT(I,J,L),PINT(I,J,L-1), | !$omp parallel do + PINT(I,J,L-2),PINT(I,J,L-3) | ! STOP 690 | DO 100 J=MYJS_P5,MYJE_P5 write(6,*) 'PINT vals at I-1: ', PINT(I-1,J,L),PINT(I-1,J,L-1), | DO 100 I=MYIS_P5,MYIE_P5 + PINT(I-1,J,L-2),PINT(I-1,J,L-3) | FILO(I,J) = 0.0 endif | PDSL(I,J) = RES(I,J) * PD(I,J) endif | 100 END DO ENDDO | END IF ENDDO | ! ENDDO | IF (HYDRO) THEN ENDIF | ! C----------------------------------------------------------------------- | !$omp parallel do !$omp parallel do private (alp1p) | ! DO J=MYJS_P5,MYJE_P5 | DO K=1,LM+1 DO I=MYIS_P5,MYIE_P5 | DO J=MYJS_P5,MYJE_P5 ALP1P=PINTLG(I,J,LM+1) | DO I=MYIS_P5,MYIE_P5 ALP1(I,J)=ALP1P | TMP1=ETA(K) ENDDO | TMP2=PDSL(I,J) ENDDO | TMP3=PT C----------------------------------------------------------------------- | PINTLG(I,J,K) = DLOG(TMP1 * TMP2 + TMP3) C-------------------- MAIN VERTICAL INTEGRATION LOOP ------------------- | END DO C----------------------------------------------------------------------- | END DO C----------------------------------------------------------------------- | END DO | ELSE Cmp | ! FIM=0. | !$omp parallel do Cmp | ! DO 400 L=LM,1,-1 | ! CHOU DO K=1,LM+1 C----------------------------------------------------------------------- | DO K=1,LM C*** | DO J=MYJS_P5,MYJE_P5 C*** INTEGRATE THE GEOPOTENTIAL | DO I=MYIS_P5,MYIE_P5 C*** | TMP1=PINT(I,J,K) !$omp parallel do private (alp1p,dfi,fiupk,rdpds) | PINTLG(I,J,K) = DLOG(TMP1) DO 125 J=MYJS_P5,MYJE_P5 | IF (K > 1) THEN DO 125 I=MYIS_P5,MYIE_P5 | IF (PINTLG(I,J,K) == PINTLG(I,J,K-1)) THEN C | WRITE(6,*) 'SAME PINTLG AT DIFFERENT LEVELS: ', MYPE,I,J,K,LMH(I,J) ALP1P=PINTLG(I,J,L) | WRITE(6,*) 'PINT VALS: ', PINT(I,J,K ), PINT(I,J,K-1), C | & PINT(I,J,K-2), PINT(I,J,K-3) DFI=(Q(I,J,L)*0.608+1.)*T(I,J,L)*R*(ALP1(I,J)-ALP1P)/DWDT(I,J,L) | ! if (abs(DFI) .lt. 2.e13) then | TMP1=ETA(K) else | TMP2=PDSL(I,J) write(6,*) 'BAD DFI: ', DFI | TMP3=PT write(6,*) 'Q,T: ', Q(I,J,L),T(I,J,L) | PINTLG(I,J,K) = DLOG(TMP1 * TMP2 + TMP3) write(6,*) 'ALP vals: ', ALP1(I,J),ALP1P | ! write(6,*) 'DWDT= ', DWDT(I,J,L) | IF (PINTLG(I,J,K) == PINTLG(I,J,K-1)) THEN endif | TMP1=ETA(K-1) C | TMP2=PDSL(I,J) RDPDS=1./(DETA(L)*PDSL(I,J)) | TMP3=PT FIUPK=FILO(I,J)+DFI | PINTLG(I,J,K-1) = DLOG(TMP1 * TMP2 + TMP3) if (abs(FIUPK) .lt. 2.e13) then | else | IF (PINTLG(I,J,K) == PINTLG(I,J,K-1)) THEN write(6,*) 'bad FIUPK. FILO, DFI ', FILO(I,J), DFI | WRITE(6,*) 'SAME PINTLG_NEW AT DIFFERENT LEVELS: ', MYPE , endif | & I , FIM(I,J)=FILO(I,J)+FIUPK | & J , C | & K , FILO(I,J)=(FIUPK-DFL(L))*HTM(I,J,L)+DFL(L) | & LMH(I,J) C if (MYPE.eq.4.and.I.eq.1.and.J.eq.2.and.L.eq.25) then | ! C write(6,*) 'L,FILO, DFI-->: ', L,FILO(I,J),DFI | WRITE(6,*) 'PINT_NEW VALS: ', PINT(I,J,K), PINT(I,J,K-1) C write(6,*) 'T,Q,ALP1,ALP1P,DWDT: ', T(I,J,L),Q(I,J,L),ALP1(I,J), | STOP 700 C + ALP1P,DWDT(I,J,L) | END IF C endif | END IF if (abs(FILO(I,J)) .lt. 20000000.) then | END IF else | END IF write(6,*) 'bad FILO value ', FILO(I,J),' on PE: ' , | END DO + MYPE, 'at ', I,J | END DO write(6,*) 'FIUPK,DFL: ', FIUPK, DFL(L) | END DO STOP 999 | !CHOU endif | DO J=MYJS_P5,MYJE_P5 ALP1(I,J)=ALP1P | DO I=MYIS_P5,MYIE_P5 125 CONTINUE | PINT(I,J,LM+1) = PDSL(I,J) * DETA(LM) + PINT(I,J,LM) C----------------------------------------------------------------------- | PINTLG(I,J,LM+1) = ALOG(PINT(I,J,LM+1)) !$omp parallel do private (alp1p,alp1pl,alp2p,alp2pl,dfi) | END DO DO 205 J=MYJS_P5,MYJE_P5 | END DO DO 205 I=MYIS_P5,MYIE_P5 | !CHOU HM(I,J)=HTM(I,J,L)*HBM2(I,J) | END IF VM(I,J)=VTM(I,J,L)*VBM2(I,J) | C | ! ALP1P =PINTLG(I,J,L) | !$omp parallel do private (ALP1P) ALP1PL=PINTLG(I,J,L+1) | ! ALP2P =ALP1P*ALP1P | DO J=MYJS_P5,MYJE_P5 ALP2PL=ALP1PL*ALP1PL | DO I=MYIS_P5,MYIE_P5 C | ALP1P = PINTLG(I,J,LM+1) DFI=(Q(I,J,L)*0.608+1.)*T(I,J,L)*R*(ALP1PL-ALP1P)/DWDT(I,J,L) | ALP1(I,J) = ALP1P if (abs(DFI) .le. 2.e13) then | END DO else | END DO write(6,*) 'BAD DFI:::: ', DFI | !------------------------------- endif | ! MAIN VERTICAL INTEGRATION LOOP | !------------------------------- if (abs(DWDT(I,J,L)) .le. 2.e13) then | FIM = 0. else | ! write(6,*) 'BAD DWDTI:::: ', DWDT(I,J,L) | DO 400 K=LM,1,-1 endif | !--------------------------- | ! INTEGRATE THE GEOPOTENTIAL if (abs(ALP2PL) .le. 2.e13) then | !--------------------------- else | ! write(6,*) 'BAD ALP2PL:::: ', ALP2PL | !$omp parallel do private (ALP1P , DFI , FIUPK , RDPDS) endif | ! | doout125: DO J=MYJS_P5,MYJE_P5 if (abs(ALP2P) .le. 2.e13) then | doin125: DO I=MYIS_P5,MYIE_P5 else | ! write(6,*) 'BAD ALP2P:::: ', ALP2P | ALP1P = PINTLG(I,J,K) endif | ! | DFI = (Q(I,J,K) * 0.608 + 1.) * T(I,J,K) * R * (ALP1(I,J) - ALP1P) / DWDT(I,J,K) | ! DFDZ(I,J)=DFI*DWDT(I,J,L)/(ALP2PL-ALP2P) | IF (ABS(DFI) < 2.E13) THEN | ELSE if (abs(DFDZ(I,J)) .le. 2.e13) then | WRITE(6,*) 'BAD DFI: ' , DFI else | WRITE(6,*) 'I,J,K,Q,T: ', I,J,K , Q(I,J,K) , T(I,J,K) write(6,*) 'on PE: ', MYPE | WRITE(6,*) 'ALP VALS: ' , ALP1(I,J) , ALP1P write(6,*) 'at = ', I,J,L | WRITE(6,*) 'DWDT= ' , DWDT(I,J,K) write(6,*) 'DFDZ= ', DFDZ(I,J) | END IF write(6,*) 'DFI= ', DFI | ! write(6,*) 'DWDT= ', DWDT(I,J,L) | RDPDS = 1. / (DETA(K) * PDSL(I,J)) write(6,*) 'denom= ', ALP2PL-ALP2P | FIUPK = FILO(I,J) + DFI write(6,*) 'PINTLG(L) ', PINTLG(I,J,L) | ! write(6,*) 'PINTLG(L+1) ', PINTLG(I,J,L+1) | IF (ABS(FIUPK) < 2.E13) THEN endif | ELSE | WRITE(6,*) 'BAD FIUPK. FILO, DFI ', FILO(I,J), DFI APEL(I,J)=(ALP2PL+ALP2P)*0.5 | END IF DPDE(I,J)=DETA(L)*PDSL(I,J) | ! 205 CONTINUE | FIM(I,J) = FILO(I,J) + FIUPK C | !$omp parallel do | FILO(I,J) = (FIUPK - DFL(K)) * HTM(I,J,K) + DFL(K) DO 215 J=MYJS_P1,MYJE_P1 | ! DO 215 I=MYIS_P1,MYIE_P1 | IF (ABS(FILO(I,J)) < 20000000.) THEN RDPD(I,J)=1./DPDE(I,J) | ELSE 215 CONTINUE | WRITE(6,*) 'BAD FILO VALUE ', FILO(I,J),' ON PE: ' ,MYPE, 'AT ', I, J C | WRITE(6,*) 'FIUPK,DFL: ', FIUPK, DFL(K) !$omp parallel do | STOP 999 DO 220 J=MYJS1_P3,MYJE1_P3 | END IF DO 220 I=MYIS_P3,MYIE_P3 | ! ADPDX(I,J)=DPDE(I+IVW(J),J)+DPDE(I+IVE(J),J) | ALP1(I,J) = ALP1P ADPDY(I,J)=DPDE(I,J-1)+DPDE(I,J+1) | END DO doin125 RDPDX(I,J)=1./ADPDX(I,J) | END DO doout125 RDPDY(I,J)=1./ADPDY(I,J) | ! 220 CONTINUE | !$omp parallel do private (ALP1P , ALP1PL , ALP2P , ALP2PL , DFI) C | ! C--------------DIAGONAL CONTRIBUTIONS TO PRESSURE GRADIENT FORCE-------- | DO 205 J=MYJS_P5,MYJE_P5 C | DO 205 I=MYIS_P5,MYIE_P5 CC | HM(I,J) = HTM(I,J,K) * HBM2(I,J) CC Having problem with global boundary here | VM(I,J) = VTM(I,J,K) * VBM2(I,J) CC | ! !$omp parallel do | ALP1P = PINTLG(I,J,K ) if (MYPE .eq. 5 .and. L .eq. LM ) then | ALP1PL = PINTLG(I,J,K+1) I=MYIE_P4 | ALP2P = ALP1P * ALP1P J=MYJE_P4-2 | ALP2PL = ALP1PL * ALP1PL C write(6,*) 'bad FIM point: ',I+IHE(J),J+1,FIM (I+IHE(J),J+1) | ! endif | DFI = (Q(I,J,K) * 0.608 + 1.) * T(I,J,K) * R * (ALP1PL - ALP1P) / DWDT(I,J,K) DO 240 J=MYJS_P4,MYJE_P4 | ! DO 240 I=MYIS_P4,MYIE_P4 | IF (ABS(DFI) <= 2.E13) THEN ADPDNE(I,J)=DPDE(I+IHE(J),J+1)+DPDE(I,J) | ELSE if ( abs(FIM (I+IHE(J),J+1)) .lt. 2000000.) then | WRITE(6,*) 'BAD DFI ' , DFI else | END IF write(6,*) 'using FIM val: ', FIM (I+IHE(J),J+1), 'at point', | ! + I+IHE(J),J+1, 'on PE: ', MYPE | IF (ABS(DWDT(I,J,K)) <= 2.E13) THEN endif | ELSE PNE(I,J)=(FIM (I+IHE(J),J+1)-FIM (I,J)) | WRITE(6,*) 'BAD DWDTI ' , DWDT(I,J,K) 1 *(DWDT(I+IHE(J),J+1,L)+DWDT(I,J,L)) | END IF PPNE(I,J)=PNE(I,J)*ADPDNE(I,J) | CNE(I,J)=(DFDZ(I+IHE(J),J+1)+DFDZ(I,J))*2. | IF (ABS(ALP2PL) <= 2.E13) THEN 1 *(APEL(I+IHE(J),J+1)-APEL(I,J)) | ELSE PCNE(I,J)=CNE(I,J)*ADPDNE(I,J) | WRITE(6,*) 'BAD ALP2PL ', ALP2PL 240 CONTINUE | END IF C | !$omp parallel do | IF (ABS(ALP2P) <= 2.E13) THEN DO 250 J=MYJS1_P4,MYJE_P4 | ELSE DO 250 I=MYIS_P4,MYIE1_P4 | WRITE(6,*) 'BAD ALP2P ' , ALP2P ADPDSE(I,J)=DPDE(I+IHE(J),J-1)+DPDE(I,J) | END IF PSE(I,J)=(FIM (I+IHE(J),J-1)-FIM (I,J)) | ! 1 *(DWDT(I+IHE(J),J-1,L)+DWDT(I,J,L)) | DFDZ(I,J) = DFI * DWDT(I,J,K) / (ALP2PL - ALP2P) PPSE(I,J)=PSE(I,J)*ADPDSE(I,J) | ! CSE(I,J)=(DFDZ(I+IHE(J),J-1)+DFDZ(I,J))*2. | IF (ABS(DFDZ(I,J)) <= 2.E13) THEN 1 *(APEL(I+IHE(J),J-1)-APEL(I,J)) | ELSE PCSE(I,J)=CSE(I,J)*ADPDSE(I,J) | WRITE(6,*) 'ON PE: ' , MYPE 250 CONTINUE | WRITE(6,*) 'AT = ' , I,J,K C | WRITE(6,*) 'DFDZ= ' , DFDZ(I,J) C--------------LAT & LONG PRESSURE FORCE COMPONENTS--------------------- | WRITE(6,*) 'DFI= ' , DFI C | WRITE(6,*) 'DWDT= ' , DWDT(I,J,K) !$omp parallel do private (dcnek,dcsek,dpnek,dpsek) | WRITE(6,*) 'DENOM= ' , ALP2PL - ALP2P DO 280 J=MYJS1_P3,MYJE1_P3 | WRITE(6,*) 'PINTLG(K) ' , PINTLG(I,J,K) DO 280 I=MYIS_P3,MYIE_P3 | WRITE(6,*) 'PINTLG(K+1) ', PINTLG(I,J,K+1) DPNEK=PNE(I+IVW(J),J)+PNE(I,J-1) | END IF DPSEK=PSE(I+IVW(J),J)+PSE(I,J+1) | ! PEW(I,J)=DPNEK+DPSEK | APEL(I,J) = (ALP2PL + ALP2P) * 0.5 PNS(I,J)=DPNEK-DPSEK | DPDE(I,J) = DETA(K) * PDSL(I,J) DCNEK=CNE(I+IVW(J),J)+CNE(I,J-1) | 205 END DO DCSEK=CSE(I+IVW(J),J)+CSE(I,J+1) | ! PCEW(I,J)=(DCNEK+DCSEK)*ADPDX(I,J) | !$omp parallel do PCNS(I,J)=(DCNEK-DCSEK)*ADPDY(I,J) | ! 280 CONTINUE | DO 215 J=MYJS_P1,MYJE_P1 C | DO 215 I=MYIS_P1,MYIE_P1 C--------------UPDATE U AND V (CORIOLIS & PGF)-------------------------- | RDPD(I,J) = 1. / DPDE(I,J) C | 215 END DO !$omp parallel do private (dpfnek,dpfsek) | ! DO 290 J=MYJS2_P3,MYJE2_P3 | !$omp parallel do DO 290 I=MYIS_P3,MYIE1_P3 | ! DPFNEK=((PPNE(I+IVW(J),J)+PPNE(I,J-1)) | DO 220 J=MYJS1_P3,MYJE1_P3 1 +(PCNE(I+IVW(J),J)+PCNE(I,J-1)))*2. | DO 220 I=MYIS_P3,MYIE_P3 DPFSEK=((PPSE(I+IVW(J),J)+PPSE(I,J+1)) | ADPDX(I,J) = DPDE(I+IVW(J),J ) + DPDE(I+IVE(J),J ) 1 +(PCSE(I+IVW(J),J)+PCSE(I,J+1)))*2. | ADPDY(I,J) = DPDE(I ,J-1) + DPDE(I ,J+1) DPFEW(I,J)=DPFNEK+DPFSEK | RDPDX(I,J) = 1./ ADPDX(I,J) DPFNS(I,J)=DPFNEK-DPFSEK | RDPDY(I,J) = 1./ ADPDY(I,J) 290 CONTINUE | 220 END DO C | !-------------------------------------------------- !$omp parallel do private (f0k,upk,utk,vpk,vtk) | ! DIAGONAL CONTRIBUTIONS TO PRESSURE GRADIENT FORCE DO 300 J=MYJS2_P2,MYJE2_P2 | !-------------------------------------------------- DO 300 I=MYIS_P2,MYIE1_P2 | ! F0K=U(I,J,L)*CURV(I,J)+F(I,J) | !$omp parallel do VM(I,J)=VTM(I,J,L)*VBM2(I,J) | ! UPK=((DPFEW(I,J)+PCEW(I,J))*RDPDX(I,J) | IF (MYPE == 5 .AND. K == LM) THEN 1 +PEW(I,J))*CPGFU(I,J)+F0K*V(I,J,L)+U(I,J,L) | I = MYIE_P4 VPK=((DPFNS(I,J)+PCNS(I,J))*RDPDY(I,J) | J = MYJE_P4 - 2 1 +PNS(I,J))*CPGFV-F0K*U(I,J,L)+V(I,J,L) | END IF UTK=U(I,J,L) | ! VTK=V(I,J,L) | DO 240 J=MYJS_P4,MYJE_P4 U(I,J,L)=((F0K*VPK+UPK)/(F0K*F0K+1.)-UTK) | DO 240 I=MYIS_P4,MYIE_P4 1 *VM(I,J)+UTK | ADPDNE(I,J) = DPDE(I+IHE(J),J+1) + DPDE(I,J) V(I,J,L)=(VPK-F0K*U(I,J,L)-VTK) | ! 1 *VM(I,J)+VTK | IF (ABS(FIM (I+IHE(J),J+1)) < 2000000.) THEN 300 CONTINUE | ELSE C----------------------------------------------------------------------- | WRITE(6,*) 'USING FIM VAL: ', FIM (I+IHE(J),J+1), 'AT POINT',I+IHE(J),J+1, 400 CONTINUE | & 'ON PE: ', MYPE C----------------------------------------------------------------------- | END IF RETURN | ! END | PNE(I,J) = (FIM (I+IHE(J),J+1) - FIM (I,J)) > & * (DWDT(I+IHE(J),J+1,K) + DWDT(I,J,K)) > ! > PPNE(I,J) = PNE(I,J) * ADPDNE(I,J) > ! > CNE(I,J) = (DFDZ(I+IHE(J),J+1) + DFDZ(I,J)) * 2. > & * (APEL(I+IHE(J),J+1) - APEL(I,J)) > ! > PCNE(I,J) = CNE(I,J) * ADPDNE(I,J) > 240 END DO > ! > !$omp parallel do > ! > DO 250 J=MYJS1_P4,MYJE_P4 > DO 250 I=MYIS_P4,MYIE1_P4 > ADPDSE(I,J) = DPDE(I+IHE(J),J-1) + DPDE(I,J) > ! > PSE(I,J) = (FIM (I+IHE(J),J-1) - FIM (I,J)) > & * (DWDT(I+IHE(J),J-1,K) + DWDT(I,J,K)) > ! > PPSE(I,J) = PSE(I,J)*ADPDSE(I,J) > ! > CSE(I,J) = (DFDZ(I+IHE(J),J-1) + DFDZ(I,J)) * 2. > & * (APEL(I+IHE(J),J-1) - APEL(I,J)) > ! > PCSE(I,J) = CSE(I,J) * ADPDSE(I,J) > 250 END DO > !--------------------------------------- > ! LAT AND LONG PRESSURE FORCE COMPONENTS > !--------------------------------------- > ! > !$omp parallel do private (DCNEK , DCSEK , DPNEK , DPSEK) > ! > DO 280 J=MYJS1_P3,MYJE1_P3 > DO 280 I=MYIS_P3,MYIE_P3 > DPNEK = PNE(I+IVW(J),J) + PNE(I,J-1) > DPSEK = PSE(I+IVW(J),J) + PSE(I,J+1) > ! > PEW(I,J) = DPNEK + DPSEK > PNS(I,J) = DPNEK - DPSEK > ! > DCNEK = CNE(I+IVW(J),J) + CNE(I,J-1) > DCSEK = CSE(I+IVW(J),J) + CSE(I,J+1) > ! > PCEW(I,J) = (DCNEK + DCSEK) * ADPDX(I,J) > PCNS(I,J) = (DCNEK - DCSEK) * ADPDY(I,J) > 280 END DO > !---------------------------------- > ! UPDATE U AND V (CORIOLIS AND PGF) > !---------------------------------- > ! > !$omp parallel do private (DPFNEK , DPFSEK) > ! > DO 290 J=MYJS2_P3,MYJE2_P3 > DO 290 I=MYIS_P3,MYIE1_P3 > DPFNEK = ((PPNE(I+IVW(J),J)+PPNE(I,J-1)) > & + (PCNE(I+IVW(J),J)+PCNE(I,J-1))) * 2. > ! > DPFSEK = ((PPSE(I+IVW(J),J)+PPSE(I,J+1)) > & + (PCSE(I+IVW(J),J)+PCSE(I,J+1))) * 2. > ! > DPFEW(I,J) = DPFNEK + DPFSEK > DPFNS(I,J) = DPFNEK - DPFSEK > 290 END DO > ! > !$omp parallel do private (F0K , UPK , UTK , VPK , VTK) > ! > DO 300 J=MYJS2_P2,MYJE2_P2 > DO 300 I=MYIS_P2,MYIE1_P2 > F0K = U(I,J,K) * CURV(I,J) + F(I,J) > VM(I,J) = VTM(I,J,K) * VBM2(I,J) > ! > UPK = ((DPFEW(I,J) + PCEW(I,J)) * RDPDX(I,J) + PEW(I,J)) > & * CPGFU(I,J) + F0K * V(I,J,K) + U(I,J,K) > ! > VPK = ((DPFNS(I,J) + PCNS(I,J)) * RDPDY(I,J) + PNS(I,J)) > & * CPGFV - F0K * U(I,J,K) + V(I,J,K) > ! > UTK = U(I,J,K) > VTK = V(I,J,K) > ! > U(I,J,K) = ((F0K * VPK + UPK) / (F0K * F0K + 1.) - UTK) * VM(I,J) + UTK > V(I,J,K) = (VPK - F0K * U(I,J,K) - VTK) * VM(I,J) + VTK > 300 END DO > ! > 400 END DO > ! > RETURN > ! > END SUBROUTINE PGCOR