diff --git a/src/programs/ectrans-benchmark.F90 b/src/programs/ectrans-benchmark.F90 index 8a2fb698..d0fd4627 100644 --- a/src/programs/ectrans-benchmark.F90 +++ b/src/programs/ectrans-benchmark.F90 @@ -810,8 +810,8 @@ program transform_test if (zmaxerrg > real(ncheck, jprb) * epsilon(1.0_jprb)) then write(nout, '(a)') '*******************************' write(nout, '(a)') 'Correctness test failed' - write(nout, '(a,1e7.2)') 'Maximum spectral norm error = ', zmaxerrg - write(nout, '(a,1e7.2)') 'Error tolerance = ', real(ncheck, jprb) * epsilon(1.0_jprb) + write(nout, '(a,1e9.2)') 'Maximum spectral norm error = ', zmaxerrg + write(nout, '(a,1e9.2)') 'Error tolerance = ', real(ncheck, jprb) * epsilon(1.0_jprb) write(nout, '(a)') '*******************************' ierr = 1 endif diff --git a/src/trans/algor/butterfly_alg_mod.F90 b/src/trans/algor/butterfly_alg_mod.F90 index 1cb785d0..dd3cf7a2 100644 --- a/src/trans/algor/butterfly_alg_mod.F90 +++ b/src/trans/algor/butterfly_alg_mod.F90 @@ -9,7 +9,7 @@ ! MODULE BUTTERFLY_ALG_MOD -USE PARKIND1, ONLY : JPRD, JPIM, JPRB, JPIB +USE PARKIND1, ONLY : JPRD, JPRM, JPIM, JPRB, JPIB USE INTERPOL_DECOMP_MOD USE SHAREDMEM_MOD @@ -392,11 +392,11 @@ SUBROUTINE UNPACK_BUTTERFLY_STRUCT(YD_STRUCT,YD_CLONE,YDMEMBUF) ELSE ZBUF => YD_CLONE%COMMSBUF(I+1:I+5) ENDIF -YD_STRUCT%M_ORDER = NINT(ZBUF(1),JPRB) -YD_STRUCT%N_ORDER = NINT(ZBUF(2),JPRB) -YD_STRUCT%N_CMAX = NINT(ZBUF(3),JPRB) -YD_STRUCT%N_LEVELS = NINT(ZBUF(4),JPRB) -YD_STRUCT%IBETALEN_MAX = NINT(ZBUF(5),JPRB) +YD_STRUCT%M_ORDER = NINT(ZBUF(1),JPIM) +YD_STRUCT%N_ORDER = NINT(ZBUF(2),JPIM) +YD_STRUCT%N_CMAX = NINT(ZBUF(3),JPIM) +YD_STRUCT%N_LEVELS = NINT(ZBUF(4),JPIM) +YD_STRUCT%IBETALEN_MAX = NINT(ZBUF(5),JPIM) I=I+5 ALLOCATE(YD_STRUCT%SLEV(0:YD_STRUCT%N_LEVELS)) @@ -406,9 +406,9 @@ SUBROUTINE UNPACK_BUTTERFLY_STRUCT(YD_STRUCT,YD_CLONE,YDMEMBUF) ELSE ZBUF => YD_CLONE%COMMSBUF(I+1:I+3) ENDIF - YD_STRUCT%SLEV(JL)%IJ =NINT(ZBUF(1),JPRB) - YD_STRUCT%SLEV(JL)%IK =NINT(ZBUF(2),JPRB) - YD_STRUCT%SLEV(JL)%IBETALEN=NINT(ZBUF(3),JPRB) + YD_STRUCT%SLEV(JL)%IJ =NINT(ZBUF(1),JPIM) + YD_STRUCT%SLEV(JL)%IK =NINT(ZBUF(2),JPIM) + YD_STRUCT%SLEV(JL)%IBETALEN=NINT(ZBUF(3),JPIM) I=I+3 ALLOCATE(YD_STRUCT%SLEV(JL)%NODE(YD_STRUCT%SLEV(JL)%IJ,YD_STRUCT%SLEV(JL)%IK)) DO JIK=1,YD_STRUCT%SLEV(JL)%IK @@ -418,15 +418,15 @@ SUBROUTINE UNPACK_BUTTERFLY_STRUCT(YD_STRUCT,YD_CLONE,YDMEMBUF) ELSE ZBUF => YD_CLONE%COMMSBUF(I+1:I+10) ENDIF - YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ILEV = NINT(ZBUF(1),JPRB) - YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IFCOL = NINT(ZBUF(2),JPRB) - YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ILCOL = NINT(ZBUF(3),JPRB) - YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IFROW = NINT(ZBUF(4),JPRB) - YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ILROW = NINT(ZBUF(5),JPRB) - YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICOLS = NINT(ZBUF(6),JPRB) - YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IROWS = NINT(ZBUF(7),JPRB) - YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IRANK = NINT(ZBUF(8),JPRB) - YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IOFFBETA= NINT(ZBUF(9),JPRB) + YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ILEV = NINT(ZBUF(1),JPIM) + YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IFCOL = NINT(ZBUF(2),JPIM) + YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ILCOL = NINT(ZBUF(3),JPIM) + YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IFROW = NINT(ZBUF(4),JPIM) + YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ILROW = NINT(ZBUF(5),JPIM) + YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICOLS = NINT(ZBUF(6),JPIM) + YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IROWS = NINT(ZBUF(7),JPIM) + YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IRANK = NINT(ZBUF(8),JPIM) + YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%IOFFBETA= NINT(ZBUF(9),JPIM) J = NINT(ZBUF(10)) I=I+10 ALLOCATE(YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICLIST(J)) @@ -437,7 +437,7 @@ SUBROUTINE UNPACK_BUTTERFLY_STRUCT(YD_STRUCT,YD_CLONE,YDMEMBUF) ZBUF => YD_CLONE%COMMSBUF(I+1:I+J) ENDIF DO II=1,J - YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICLIST(II)=NINT(ZBUF(II),JPRB) + YD_STRUCT%SLEV(JL)%NODE(JIJ,JIK)%ICLIST(II)=NINT(ZBUF(II),JPIM) END DO I=I+J ENDIF @@ -446,7 +446,7 @@ SUBROUTINE UNPACK_BUTTERFLY_STRUCT(YD_STRUCT,YD_CLONE,YDMEMBUF) ELSE ZBUF => YD_CLONE%COMMSBUF(I+1:I+1) ENDIF - J=NINT(ZBUF(1),JPRB) + J=NINT(ZBUF(1),JPIM) I=I+1 IF( J > 0 )THEN IF(LLMEMBUF) THEN @@ -462,8 +462,8 @@ SUBROUTINE UNPACK_BUTTERFLY_STRUCT(YD_STRUCT,YD_CLONE,YDMEMBUF) ELSE ZBUF => YD_CLONE%COMMSBUF(I+1:I+2) ENDIF - J1=NINT(ZBUF(1),JPRB) - J2=NINT(ZBUF(2),JPRB) + J1=NINT(ZBUF(1),JPIM) + J2=NINT(ZBUF(2),JPIM) I=I+2 IF( J1 > 0 .AND. J2 > 0 )THEN IF(LLMEMBUF) THEN @@ -621,8 +621,8 @@ SUBROUTINE MULT_BUTV(CDTRANS,YD_STRUCT,PVECIN,PVECOUT) & 0.0_JPRD,ZBETA(IBTST:IBTEN,IBETALV),1) ELSE CALL SGEMV('T',IROWS,YD_STRUCT%SLEV(ILEVS)%NODE(JJ,JK)%IRANK,& - & 1.0_JPRB,YNODE%B,IROWS,PVECIN(IFR:ILR),1,& - & 0.0_JPRB,ZBETA(IBTST:IBTEN,IBETALV),1) + & 1.0_JPRM,YNODE%B,IROWS,PVECIN(IFR:ILR),1,& + & 0.0_JPRM,ZBETA(IBTST:IBTEN,IBETALV),1) ENDIF ENDIF ILM1 = JL-1 @@ -700,8 +700,8 @@ SUBROUTINE MULT_BUTV(CDTRANS,YD_STRUCT,PVECIN,PVECOUT) & 0.0_JPRD,PVECOUT(IFR:ILR),1) ELSE CALL SGEMV('N',IROWS,YD_STRUCT%SLEV(ILEVS)%NODE(JJ,JK)%IRANK,& - & 1.0_JPRB,YNODE%B,IROWS,ZBETA(IBTST:IBTEN,IBETALV),1,& - & 0.0_JPRB,PVECOUT(IFR:ILR),1) + & 1.0_JPRM,YNODE%B,IROWS,ZBETA(IBTST:IBTEN,IBETALV),1,& + & 0.0_JPRM,PVECOUT(IFR:ILR),1) ENDIF ENDIF ENDDO @@ -788,7 +788,7 @@ SUBROUTINE MULT_BUTM(CDTRANS,YD_STRUCT,KF,PVECIN,PVECOUT,KWV) CALL DGEMM('T','N',IN,KF,IM,1.0_JPRD,& & ZPNONIM_D,IM,ZBETA_D,ILBETA,0.0_JPRD,& & ZOUT_D,YD_STRUCT%N_ORDER) - ZVECOUT(YNODE%IRANK+1:YNODE%IRANK+IN,1:KF) = REAL(ZOUT_D(1:IN,1:KF),JPRB) + ZVECOUT(YNODE%IRANK+1:YNODE%IRANK+IN,1:KF) = REAL(ZOUT_D(1:IN,1:KF),JPRM) DEALLOCATE(ZPNONIM_D) ELSE CALL DGEMM('T','N',IN,KF,IM,1.0_JPRD,& @@ -800,8 +800,8 @@ SUBROUTINE MULT_BUTM(CDTRANS,YD_STRUCT,KF,PVECIN,PVECOUT,KWV) call ieee_get_halting_mode(ieee_invalid,LL_HALT_INVALID) if (LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.false.) ENDIF - CALL SGEMM('T','N',IN,KF,IM,1.0_JPRB,& - & YNODE%PNONIM(1),IM,ZBETA(IBTST,1,IBETALV),ILBETA,0.0_JPRB,& + CALL SGEMM('T','N',IN,KF,IM,1.0_JPRM,& + & YNODE%PNONIM(1),IM,ZBETA(IBTST,1,IBETALV),ILBETA,0.0_JPRM,& & ZVECOUT(YNODE%IRANK+1,1),YD_STRUCT%N_ORDER) if (LL_IEEE_HALT .and. LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.true.) ENDIF @@ -832,7 +832,7 @@ SUBROUTINE MULT_BUTM(CDTRANS,YD_STRUCT,KF,PVECIN,PVECOUT,KWV) & ZB_D,IROWS,ZIN_D,IRIN,0.0_JPRD,& & ZBETA_D,ILBETA) - ZBETA(IBTST:IBTST+IRANK-1,1:KF,IBETALV)=REAL(ZBETA_D(1:IRANK,1:KF),JPRB) + ZBETA(IBTST:IBTST+IRANK-1,1:KF,IBETALV)=REAL(ZBETA_D(1:IRANK,1:KF),JPRM) DEALLOCATE(ZB_D) ELSE @@ -845,8 +845,8 @@ SUBROUTINE MULT_BUTM(CDTRANS,YD_STRUCT,KF,PVECIN,PVECOUT,KWV) call ieee_get_halting_mode(ieee_invalid,LL_HALT_INVALID) if (LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.false.) ENDIF - CALL SGEMM('T','N',IRANK,KF,IROWS,1.0_JPRB,& - & YNODE%B,IROWS,PVECIN(IFR,1),IRIN,0.0_JPRB,& + CALL SGEMM('T','N',IRANK,KF,IROWS,1.0_JPRM,& + & YNODE%B,IROWS,PVECIN(IFR,1),IRIN,0.0_JPRM,& & ZBETA(IBTST,1,IBETALV),ILBETA) if (LL_IEEE_HALT .and. LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.true.) ENDIF @@ -887,7 +887,7 @@ SUBROUTINE MULT_BUTM(CDTRANS,YD_STRUCT,KF,PVECIN,PVECOUT,KWV) & ZPNONIM_D,IM,ZBETA_D,ILBETA,0.0_JPRD,& & ZOUT_D,YD_STRUCT%N_ORDER) - ZVECOUT(YNODE%IRANK+1:YNODE%IRANK+IN,1:KF) = REAL(ZOUT_D(1:IN,1:KF),JPRB) + ZVECOUT(YNODE%IRANK+1:YNODE%IRANK+IN,1:KF) = REAL(ZOUT_D(1:IN,1:KF),JPRM) DEALLOCATE(ZPNONIM_D) ELSE CALL DGEMM('T','N',IN,KF,IM,1.0_JPRD,& @@ -899,8 +899,8 @@ SUBROUTINE MULT_BUTM(CDTRANS,YD_STRUCT,KF,PVECIN,PVECOUT,KWV) call ieee_get_halting_mode(ieee_invalid,LL_HALT_INVALID) if (LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.false.) ENDIF - CALL SGEMM('T','N',IN,KF,IM,1.0_JPRB,& - & YNODE%PNONIM(1),IM,ZBETA(IBTST,1,IBETALV),ILBETA,0.0_JPRB,& + CALL SGEMM('T','N',IN,KF,IM,1.0_JPRM,& + & YNODE%PNONIM(1),IM,ZBETA(IBTST,1,IBETALV),ILBETA,0.0_JPRM,& & ZVECOUT(YNODE%IRANK+1,1),YD_STRUCT%N_ORDER) if (LL_IEEE_HALT .and. LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.true.) ENDIF @@ -977,8 +977,8 @@ SUBROUTINE MULT_BUTM(CDTRANS,YD_STRUCT,KF,PVECIN,PVECOUT,KWV) call ieee_get_halting_mode(ieee_invalid,LL_HALT_INVALID) if (LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.false.) ENDIF - CALL SGEMM('N','N',IRANK,KF,IN,1.0_JPRB,& - & YNODE%PNONIM(1),IRANK,ZVECIN(IRANK+1,1),YD_STRUCT%N_ORDER,1.0_JPRB,& + CALL SGEMM('N','N',IRANK,KF,IN,1.0_JPRM,& + & YNODE%PNONIM(1),IRANK,ZVECIN(IRANK+1,1),YD_STRUCT%N_ORDER,1.0_JPRM,& & ZBETA(IBTST,1,IBETALV),ILBETA) if (LL_IEEE_HALT .and. LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.true.) ENDIF @@ -1025,8 +1025,8 @@ SUBROUTINE MULT_BUTM(CDTRANS,YD_STRUCT,KF,PVECIN,PVECOUT,KWV) call ieee_get_halting_mode(ieee_invalid,LL_HALT_INVALID) if (LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.false.) ENDIF - CALL SGEMM('N','N',IRANK,KF,IN,1.0_JPRB,& - & YNODE%PNONIM(1),IRANK,ZVECIN(IRANK+1,1),YD_STRUCT%N_ORDER,1.0_JPRB,& + CALL SGEMM('N','N',IRANK,KF,IN,1.0_JPRM,& + & YNODE%PNONIM(1),IRANK,ZVECIN(IRANK+1,1),YD_STRUCT%N_ORDER,1.0_JPRM,& & ZBETA(IBTST,1,IBETALV),ILBETA) if (LL_IEEE_HALT .and. LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.true.) ENDIF @@ -1046,8 +1046,8 @@ SUBROUTINE MULT_BUTM(CDTRANS,YD_STRUCT,KF,PVECIN,PVECOUT,KWV) call ieee_get_halting_mode(ieee_invalid,LL_HALT_INVALID) if (LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.false.) ENDIF - CALL SGEMM('N','N',IROWS,KF,YNODE%IRANK,1.0_JPRB,& - & YNODE%B,IROWS,ZBETA(IBTST,1,IBETALV),YD_STRUCT%IBETALEN_MAX,0.0_JPRB,& + CALL SGEMM('N','N',IROWS,KF,YNODE%IRANK,1.0_JPRM,& + & YNODE%B,IROWS,ZBETA(IBTST,1,IBETALV),YD_STRUCT%IBETALEN_MAX,0.0_JPRM,& & PVECOUT(IFR,1),IROUT) if (LL_IEEE_HALT .and. LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.true.) ENDIF @@ -1084,10 +1084,10 @@ SUBROUTINE MULT_P(YDNODE,PVECIN,PVECOUT) IM = IRANK IN = YDNODE%ICOLS-IRANK IF (JPRB == JPRD) THEN - CALL DGEMV('N',IM,IN,1.0_JPRB,YDNODE%PNONIM(1),IRANK,ZVECIN(IRANK+1),1,1.0_JPRB,ZVECOUT,1) + CALL DGEMV('N',IM,IN,1.0_JPRD,YDNODE%PNONIM(1),IRANK,ZVECIN(IRANK+1),1,1.0_JPRD,ZVECOUT,1) PVECOUT(:)=ZVECOUT(:) ELSE - CALL SGEMV('N',IM,IN,1.0_JPRB,YDNODE%PNONIM(1),IRANK,ZVECIN(IRANK+1),1,1.0_JPRB,PVECOUT,1) + CALL SGEMV('N',IM,IN,1.0_JPRM,YDNODE%PNONIM(1),IRANK,ZVECIN(IRANK+1),1,1.0_JPRM,PVECOUT,1) ENDIF ENDIF @@ -1131,8 +1131,8 @@ SUBROUTINE MULT_PM(YDNODE,KF,KLBETA,PVECIN,PVECOUT) call ieee_get_halting_mode(ieee_invalid,LL_HALT_INVALID) if (LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.false.) ENDIF - CALL SGEMM('N','N',IRANK,KF,IN,1.0_JPRB,& - & YDNODE%PNONIM(1),IRANK,ZVECIN(IRANK+1,1),YDNODE%ICOLS,1.0_JPRB,& + CALL SGEMM('N','N',IRANK,KF,IN,1.0_JPRM,& + & YDNODE%PNONIM(1),IRANK,ZVECIN(IRANK+1,1),YDNODE%ICOLS,1.0_JPRM,& & PVECOUT,IRANK) if (LL_IEEE_HALT .and. LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.true.) ENDIF @@ -1158,7 +1158,7 @@ SUBROUTINE MULT_P_TR(YDNODE,PVECIN,PVECOUT) ZVECIN(:) = PVECIN(:) CALL DGEMV('T',IM,IN,1.0_JPRD,YDNODE%PNONIM,IRANK,ZVECIN,1,0.0_JPRD,ZVECOUT(IRANK+1),1) ELSE - CALL SGEMV('T',IM,IN,1.0_JPRB,YDNODE%PNONIM,IRANK,PVECIN,1,0.0_JPRB,ZVECOUT(IRANK+1),1) + CALL SGEMV('T',IM,IN,1.0_JPRM,YDNODE%PNONIM,IRANK,PVECIN,1,0.0_JPRM,ZVECOUT(IRANK+1),1) ENDIF ENDIF DO JK=1,IRANK @@ -1200,8 +1200,8 @@ SUBROUTINE MULT_P_TRM(YDNODE,KF,PVECIN,PVECOUT) call ieee_get_halting_mode(ieee_invalid,LL_HALT_INVALID) if (LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.false.) ENDIF - CALL SGEMM('T','N',IN,KF,IM,1.0_JPRB,& - & YDNODE%PNONIM(1),IM,PVECIN,IM,0.0_JPRB,& + CALL SGEMM('T','N',IN,KF,IM,1.0_JPRM,& + & YDNODE%PNONIM(1),IM,PVECIN,IM,0.0_JPRM,& & ZVECOUT(YDNODE%IRANK+1,1),YDNODE%ICOLS) if (LL_IEEE_HALT .and. LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.true.) ENDIF diff --git a/src/trans/internal/gpnorm_trans_ctl_mod.F90 b/src/trans/internal/gpnorm_trans_ctl_mod.F90 index 60a528f2..51226293 100644 --- a/src/trans/internal/gpnorm_trans_ctl_mod.F90 +++ b/src/trans/internal/gpnorm_trans_ctl_mod.F90 @@ -283,9 +283,9 @@ SUBROUTINE GPNORM_TRANS_CTL(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,PW) IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 - ZMING(JF)=MIN(ZMING(JF),ZRCV(IND)) + ZMING(JF)=MIN(ZMING(JF),REAL(ZRCV(IND),KIND=JPRB)) IND=IND+1 - ZMAXG(JF)=MAX(ZMAXG(JF),ZRCV(IND)) + ZMAXG(JF)=MAX(ZMAXG(JF),REAL(ZRCV(IND),KIND=JPRB)) ENDDO ENDIF DEALLOCATE(ZRCV) @@ -363,17 +363,17 @@ SUBROUTINE GPNORM_TRANS_CTL(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,PW) ENDDO IF(.NOT.LDAVE_ONLY)THEN IND=IND+1 - ZMING(JF)=MIN(ZMING(JF),ZRCV(IND)) + ZMING(JF)=MIN(ZMING(JF),REAL(ZRCV(IND),KIND=JPRB)) IND=IND+1 - ZMAXG(JF)=MAX(ZMAXG(JF),ZRCV(IND)) + ZMAXG(JF)=MAX(ZMAXG(JF),REAL(ZRCV(IND),KIND=JPRB)) ENDIF ENDDO IF(LDAVE_ONLY)THEN DO JF=1,KFIELDS IND=IND+1 - ZMING(JF)=MIN(ZMING(JF),ZRCV(IND)) + ZMING(JF)=MIN(ZMING(JF),REAL(ZRCV(IND),KIND=JPRB)) IND=IND+1 - ZMAXG(JF)=MAX(ZMAXG(JF),ZRCV(IND)) + ZMAXG(JF)=MAX(ZMAXG(JF),REAL(ZRCV(IND),KIND=JPRB)) ENDDO ENDIF DEALLOCATE(ZRCV) diff --git a/src/trans/internal/ledir_mod.F90 b/src/trans/internal/ledir_mod.F90 index 9c2cfd99..34ea24ed 100644 --- a/src/trans/internal/ledir_mod.F90 +++ b/src/trans/internal/ledir_mod.F90 @@ -55,7 +55,7 @@ SUBROUTINE LEDIR(KM,KMLOC,KFC,KIFC,KSL,KDGLU,KLED2,PAIA,PSIA,POA1,PW) ! P. Dueben : Dec 2019 Improvements for mass conservation in single precision ! ------------------------------------------------------------------ -USE PARKIND1 ,ONLY : JPRD, JPIM, JPRB +USE PARKIND1 ,ONLY : JPRD, JPRM, JPIM, JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R @@ -138,16 +138,16 @@ SUBROUTINE LEDIR(KM,KMLOC,KFC,KIFC,KSL,KDGLU,KLED2,PAIA,PSIA,POA1,PW) IF (LHOOK) CALL DR_HOOK('LEDIR_'//CLX//'GEMM_1',0,ZHOOK_HANDLE) IF (LLDOUBLE) THEN - CALL DGEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRB,S%FA(KMLOC)%RPNMA,KDGLU,& - &ZB,KDGLU,0._JPRB,ZCA,ILA) + CALL DGEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRD,S%FA(KMLOC)%RPNMA,KDGLU,& + &ZB,KDGLU,0._JPRD,ZCA,ILA) ELSE IF(KM>=1)THEN ! DGEM for the mean to improve mass conservation IF (LL_IEEE_HALT) THEN call ieee_get_halting_mode(ieee_invalid,LL_HALT_INVALID) if (LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.false.) ENDIF - CALL SGEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRB,S%FA(KMLOC)%RPNMA,KDGLU,& - &ZB,KDGLU,0._JPRB,ZCA,ILA) + CALL SGEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRM,S%FA(KMLOC)%RPNMA,KDGLU,& + &ZB,KDGLU,0._JPRM,ZCA,ILA) if (LL_IEEE_HALT .and. LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.true.) ELSE I1 = size(S%FA(KMLOC)%RPNMA(:,1)) @@ -212,16 +212,16 @@ SUBROUTINE LEDIR(KM,KMLOC,KFC,KIFC,KSL,KDGLU,KLED2,PAIA,PSIA,POA1,PW) IF (LHOOK) CALL DR_HOOK('LEDIR_'//CLX//'GEMM_2',0,ZHOOK_HANDLE) IF (LLDOUBLE) THEN - CALL DGEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRB,S%FA(KMLOC)%RPNMS,KDGLU,& - &ZB,KDGLU,0._JPRB,ZCS,ILS) + CALL DGEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRD,S%FA(KMLOC)%RPNMS,KDGLU,& + &ZB,KDGLU,0._JPRD,ZCS,ILS) ELSE IF(KM>=1)THEN ! DGEM for the mean to improve mass conservation IF (LL_IEEE_HALT) THEN call ieee_get_halting_mode(ieee_invalid,LL_HALT_INVALID) if (LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.false.) ENDIF - CALL SGEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRB,S%FA(KMLOC)%RPNMS,KDGLU,& - &ZB,KDGLU,0._JPRB,ZCS,ILS) + CALL SGEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRM,S%FA(KMLOC)%RPNMS,KDGLU,& + &ZB,KDGLU,0._JPRM,ZCS,ILS) if (LL_IEEE_HALT .and. LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.true.) ELSE I1 = size(S%FA(KMLOC)%RPNMS(:,1)) diff --git a/src/trans/internal/ledirad_mod.F90 b/src/trans/internal/ledirad_mod.F90 index dca3026c..d36d44eb 100644 --- a/src/trans/internal/ledirad_mod.F90 +++ b/src/trans/internal/ledirad_mod.F90 @@ -59,7 +59,7 @@ SUBROUTINE LEDIRAD(KM,KMLOC,KFC,KIFC,KDGLU,KLED2,PAIA,PSIA,POA1) ! Modified ! 16/10/12 J.Hague : DR_HOOK round calls to DGEMM: ! ------------------------------------------------------------------ -USE PARKIND1 ,ONLY : JPIM ,JPRB ,JPRD +USE PARKIND1 ,ONLY : JPIM ,JPRB ,JPRD, JPRM USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R @@ -138,11 +138,11 @@ SUBROUTINE LEDIRAD(KM,KMLOC,KFC,KIFC,KDGLU,KLED2,PAIA,PSIA,POA1) IF(ILA <= ITHRESHOLD .OR. .NOT.S%LUSEFLT) THEN IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_1',0,ZHOOK_HANDLE) IF(LLDOUBLE)THEN - CALL DGEMM('N','N',KDGLU,KIFC,ILA,1.0_JPRB,S%FA(KMLOC)%RPNMA,KDGLU,& - &ZCA,ILA,0._JPRB,ZB,KDGLU) + CALL DGEMM('N','N',KDGLU,KIFC,ILA,1.0_JPRD,S%FA(KMLOC)%RPNMA,KDGLU,& + &ZCA,ILA,0._JPRD,ZB,KDGLU) ELSE - CALL SGEMM('N','N',KDGLU,KIFC,ILA,1.0_JPRB,S%FA(KMLOC)%RPNMA,KDGLU,& - &ZCA,ILA,0._JPRB,ZB,KDGLU) + CALL SGEMM('N','N',KDGLU,KIFC,ILA,1.0_JPRM,S%FA(KMLOC)%RPNMA,KDGLU,& + &ZCA,ILA,0._JPRM,ZB,KDGLU) END IF IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_1',1,ZHOOK_HANDLE) @@ -176,11 +176,11 @@ SUBROUTINE LEDIRAD(KM,KMLOC,KFC,KIFC,KDGLU,KLED2,PAIA,PSIA,POA1) IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_2',0,ZHOOK_HANDLE) IF(LLDOUBLE)THEN - CALL DGEMM('N','N',KDGLU,KIFC,ILS,1.0_JPRB,S%FA(KMLOC)%RPNMS,KDGLU,& - &ZCS,ILS,0._JPRB,ZB,KDGLU) + CALL DGEMM('N','N',KDGLU,KIFC,ILS,1.0_JPRD,S%FA(KMLOC)%RPNMS,KDGLU,& + &ZCS,ILS,0._JPRD,ZB,KDGLU) ELSE - CALL SGEMM('N','N',KDGLU,KIFC,ILS,1.0_JPRB,S%FA(KMLOC)%RPNMS,KDGLU,& - &ZCS,ILS,0._JPRB,ZB,KDGLU) + CALL SGEMM('N','N',KDGLU,KIFC,ILS,1.0_JPRM,S%FA(KMLOC)%RPNMS,KDGLU,& + &ZCS,ILS,0._JPRM,ZB,KDGLU) END IF IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_2',1,ZHOOK_HANDLE) diff --git a/src/trans/internal/leinv_mod.F90 b/src/trans/internal/leinv_mod.F90 index 5611d57c..f75b02eb 100644 --- a/src/trans/internal/leinv_mod.F90 +++ b/src/trans/internal/leinv_mod.F90 @@ -54,7 +54,7 @@ SUBROUTINE LEINV(KM,KMLOC,KFC,KIFC,KF_OUT_LT,KSL,KDGLU,PIA,PAOA1,PSOA1) ! F. Vana 05-Mar-2015 Support for single precision ! ------------------------------------------------------------------ -USE PARKIND1 ,ONLY : JPRD, JPIM ,JPRB +USE PARKIND1 ,ONLY : JPRD, JPRM, JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R @@ -140,15 +140,15 @@ SUBROUTINE LEINV(KM,KMLOC,KFC,KIFC,KF_OUT_LT,KSL,KDGLU,PIA,PAOA1,PSOA1) IF (LHOOK) CALL DR_HOOK('LEINV_'//CLX//'GEMM_1',0,ZHOOK_HANDLE) IF (LLDOUBLE) THEN - CALL DGEMM('N','N',KDGLU,KIFC,ILA,1.0_JPRB,S%FA(KMLOC)%RPNMA,KDGLU,& - &ZBA,ILA,0._JPRB,ZC,KDGLU) + CALL DGEMM('N','N',KDGLU,KIFC,ILA,1.0_JPRD,S%FA(KMLOC)%RPNMA,KDGLU,& + &ZBA,ILA,0._JPRD,ZC,KDGLU) ELSE IF (LL_IEEE_HALT) THEN call ieee_get_halting_mode(ieee_invalid,LL_HALT_INVALID) if (LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.false.) ENDIF - CALL SGEMM('N','N',KDGLU,KIFC,ILA,1.0_JPRB,S%FA(KMLOC)%RPNMA,KDGLU,& - &ZBA,ILA,0._JPRB,ZC,KDGLU) + CALL SGEMM('N','N',KDGLU,KIFC,ILA,1.0_JPRM,S%FA(KMLOC)%RPNMA,KDGLU,& + &ZBA,ILA,0._JPRM,ZC,KDGLU) if (LL_IEEE_HALT .and. LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.true.) ENDIF IF (LHOOK) CALL DR_HOOK('LEINV_'//CLX//'GEMM_1',1,ZHOOK_HANDLE) @@ -184,15 +184,15 @@ SUBROUTINE LEINV(KM,KMLOC,KFC,KIFC,KF_OUT_LT,KSL,KDGLU,PIA,PAOA1,PSOA1) IF (LHOOK) CALL DR_HOOK('LEINV_'//CLX//'GEMM_2',0,ZHOOK_HANDLE) IF (LLDOUBLE) THEN - CALL DGEMM('N','N',KDGLU,KIFC,ILS,1.0_JPRB,S%FA(KMLOC)%RPNMS,KDGLU,& - &ZBS,ILS,0._JPRB,ZC,KDGLU) + CALL DGEMM('N','N',KDGLU,KIFC,ILS,1.0_JPRD,S%FA(KMLOC)%RPNMS,KDGLU,& + &ZBS,ILS,0._JPRD,ZC,KDGLU) ELSE IF (LL_IEEE_HALT) THEN call ieee_get_halting_mode(ieee_invalid,LL_HALT_INVALID) if (LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.false.) ENDIF - CALL SGEMM('N','N',KDGLU,KIFC,ILS,1.0_JPRB,S%FA(KMLOC)%RPNMS,KDGLU,& - &ZBS,ILS,0._JPRB,ZC,KDGLU) + CALL SGEMM('N','N',KDGLU,KIFC,ILS,1.0_JPRM,S%FA(KMLOC)%RPNMS,KDGLU,& + &ZBS,ILS,0._JPRM,ZC,KDGLU) if (LL_IEEE_HALT .and. LL_HALT_INVALID) call ieee_set_halting_mode(ieee_invalid,.true.) ENDIF IF (LHOOK) CALL DR_HOOK('LEINV_'//CLX//'GEMM_2',1,ZHOOK_HANDLE) diff --git a/src/trans/internal/leinvad_mod.F90 b/src/trans/internal/leinvad_mod.F90 index d23d856e..e661fb06 100644 --- a/src/trans/internal/leinvad_mod.F90 +++ b/src/trans/internal/leinvad_mod.F90 @@ -54,7 +54,7 @@ SUBROUTINE LEINVAD(KM,KMLOC,KFC,KIFC,KF_OUT_LT,KDGLU,PIA,PAOA1,PSOA1) ! Modified ! 16/10/12 J.Hague : DR_HOOK round calls to DGEMM: ! ------------------------------------------------------------------ -USE PARKIND1 ,ONLY : JPIM ,JPRB ,JPRD +USE PARKIND1 ,ONLY : JPIM ,JPRB ,JPRD, JPRM USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_DIM ,ONLY : R @@ -128,11 +128,11 @@ SUBROUTINE LEINVAD(KM,KMLOC,KFC,KIFC,KF_OUT_LT,KDGLU,PIA,PAOA1,PSOA1) IF(ILA <= ITHRESHOLD .OR. .NOT.S%LUSEFLT) THEN IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_1',0,ZHOOK_HANDLE) IF(LLDOUBLE)THEN - CALL DGEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRB,S%FA(KMLOC)%RPNMA,KDGLU,& - &ZC,KDGLU,0._JPRB,ZBA,ILA) + CALL DGEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRD,S%FA(KMLOC)%RPNMA,KDGLU,& + &ZC,KDGLU,0._JPRD,ZBA,ILA) ELSE - CALL SGEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRB,S%FA(KMLOC)%RPNMA,KDGLU,& - &ZC,KDGLU,0._JPRB,ZBA,ILA) + CALL SGEMM('T','N',ILA,KIFC,KDGLU,1.0_JPRM,S%FA(KMLOC)%RPNMA,KDGLU,& + &ZC,KDGLU,0._JPRM,ZBA,ILA) END IF IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_1',1,ZHOOK_HANDLE) @@ -165,11 +165,11 @@ SUBROUTINE LEINVAD(KM,KMLOC,KFC,KIFC,KF_OUT_LT,KDGLU,PIA,PAOA1,PSOA1) IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_2',0,ZHOOK_HANDLE) IF(LLDOUBLE)THEN - CALL DGEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRB,S%FA(KMLOC)%RPNMS,KDGLU,& - &ZC,KDGLU,0._JPRB,ZBS,ILS) + CALL DGEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRD,S%FA(KMLOC)%RPNMS,KDGLU,& + &ZC,KDGLU,0._JPRD,ZBS,ILS) ELSE - CALL SGEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRB,S%FA(KMLOC)%RPNMS,KDGLU,& - &ZC,KDGLU,0._JPRB,ZBS,ILS) + CALL SGEMM('T','N',ILS,KIFC,KDGLU,1.0_JPRM,S%FA(KMLOC)%RPNMS,KDGLU,& + &ZC,KDGLU,0._JPRM,ZBS,ILS) END IF IF (LHOOK) CALL DR_HOOK('LE_'//CLX//'GEMM_2',1,ZHOOK_HANDLE) diff --git a/src/trans/internal/sugaw_mod.F90 b/src/trans/internal/sugaw_mod.F90 index 410fca7b..f073f1cd 100644 --- a/src/trans/internal/sugaw_mod.F90 +++ b/src/trans/internal/sugaw_mod.F90 @@ -394,10 +394,10 @@ SUBROUTINE SUGAW(KDGL,KM,KN,PL,PW,PANM,PFN) IF(LLP2)THEN WRITE(UNIT=NOUT,FMT=& &'('' M ='',I4,'' ROW ='',I4,'' ITERATIONS='',I4,'' ROOT='',F30.20,& - &'' WEIGHT='',F30.20,'' MODIF :'',E8.2)')KM,JGL,ITER(JGL),PL(JGL)& + &'' WEIGHT='',F30.20,'' MODIF :'',E9.2)')KM,JGL,ITER(JGL),PL(JGL)& &,PW(JGL),PL(JGL)-ZLI(JGL) WRITE(UNIT=NOUT,FMT=& - &'(10X,'' LAST INC. : '',E8.2,'' MODIF IN M : '',F10.3,& + &'(10X,'' LAST INC. : '',E9.2,'' MODIF IN M : '',F10.3,& &'' FROM THE REGULAR GRID : '',F10.3,'' COLAT '',F10.3)')& &ZMOD(JGL),ZM(JGL),ZRR(JGL),ZT(JGL) ENDIF diff --git a/src/trans/internal/tpm_pol.F90 b/src/trans/internal/tpm_pol.F90 index 27eaa823..448a0f9f 100644 --- a/src/trans/internal/tpm_pol.F90 +++ b/src/trans/internal/tpm_pol.F90 @@ -33,7 +33,7 @@ SUBROUTINE INI_POL(KNSMAX,LDFAST) INTEGER(KIND=JPIM), INTENT(IN) :: KNSMAX LOGICAL, INTENT(IN), OPTIONAL :: LDFAST -REAL(KIND=JPRD) :: DA,DC,DD,DE +REAL(KIND=JPRD) :: DC,DD,DE INTEGER(KIND=JPIM) :: KKN, KKM INTEGER(KIND=JPIM) :: JN, JM @@ -49,9 +49,6 @@ SUBROUTINE INI_POL(KNSMAX,LDFAST) &*REAL(KKN+KKM-2,JPRD)) ) DE(KKN,KKM)=SQRT( (REAL(2*KKN+1,JPRD)*REAL(KKN-KKM,JPRD))& &/ (REAL(2*KKN-1,JPRD)*REAL(KKN+KKM,JPRD)) ) -DA(KKN,KKM)=SQRT( (REAL(2*KKN+1,JPRD)*REAL(KKN-KKM,JPRD)& - &*REAL(KKN+KKM,JPRD))& - &/ REAL(2*KKN-1,JPRD) ) IF (PRESENT(LDFAST)) THEN LLFAST=LDFAST