Skip to content

Commit

Permalink
Merge pull request #44 from ecmwf-ifs/napz-blascalls-constantype-fix
Browse files Browse the repository at this point in the history 
Consistent definition of explicit constants in BLAS calls + warnings removal(explicit type conversion in gpnorm, format W=>D+7, unused statement function)
  • Loading branch information
@wdeconinck
wdeconinck authored Nov 30, 2023
2 parents aa1e484 + 17e876f commit f83ba32
Show file tree
Hide file tree
Showing 9 changed files with 95 additions and 98 deletions.
4 changes: 2 additions & 2 deletions src/programs/ectrans-benchmark.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
96 changes: 48 additions & 48 deletions src/trans/algor/butterfly_alg_mod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -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))
Expand All @@ -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
Expand All @@ -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))
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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,&
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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,&
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down
12 changes: 6 additions & 6 deletions src/trans/internal/gpnorm_trans_ctl_mod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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)
Expand Down
18 changes: 9 additions & 9 deletions src/trans/internal/ledir_mod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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))
Expand Down Expand Up @@ -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))
Expand Down
18 changes: 9 additions & 9 deletions src/trans/internal/ledirad_mod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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)

Expand Down Expand Up @@ -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)
Expand Down
Loading

0 comments on commit f83ba32

Please sign in to comment.