From 205d60d4664c056eca668ab83ea2995a6df55cbf Mon Sep 17 00:00:00 2001 From: Zbigniew Piotrowski Date: Thu, 16 Nov 2023 12:41:13 +0000 Subject: [PATCH] Enable nvhpc preprocessor via intdroducing JPRC so macro to replace _JPRB eg in 0.0_JPRB is not needed. C stands for constant) --- src/programs/CMakeLists.txt | 7 +- src/programs/ectrans-benchmark-driver_mod.F90 | 13 +- src/trans/CMakeLists.txt | 6 +- src/trans/algor/bluestein_mod.F90 | 14 +- src/trans/algor/fft992.F90 | 284 +++++++++--------- src/trans/algor/seefmm_mix.F90 | 13 +- src/trans/algor/set99.F90 | 3 +- src/trans/algor/set99b.F90 | 3 +- src/trans/external/setup_trans0.F90 | 3 +- src/trans/include/ectrans/renames.inc | 22 +- src/trans/internal/dist_spec_control_mod.F90 | 3 +- src/trans/internal/eq_regions_mod.F90 | 50 +-- src/trans/internal/ftdir_mod.F90 | 3 +- src/trans/internal/ftdirad_mod.F90 | 5 +- src/trans/internal/ftinv_mod.F90 | 3 +- src/trans/internal/ftinvad_mod.F90 | 3 +- src/trans/internal/gath_spec_control_mod.F90 | 5 +- src/trans/internal/gpnorm_trans_ctl_mod.F90 | 7 +- src/trans/internal/ltdirad_mod.F90 | 3 +- src/trans/internal/ltinvad_mod.F90 | 5 +- src/trans/internal/prepsnm_mod.F90 | 3 +- src/trans/internal/prfi1b_mod.F90 | 7 +- src/trans/internal/spnorm_ctl_mod.F90 | 3 +- src/trans/internal/spnormd_mod.F90 | 5 +- src/trans/internal/sustaonl_mod.F90 | 5 +- src/trans/internal/updsp_mod.F90 | 9 +- src/trans/internal/updspad_mod.F90 | 17 +- src/trans/internal/updspb_mod.F90 | 5 +- src/trans/internal/updspbad_mod.F90 | 15 +- src/trans/internal/uvtvd_mod.F90 | 5 +- src/trans/internal/vd2uv_mod.F90 | 3 +- 31 files changed, 281 insertions(+), 251 deletions(-) diff --git a/src/programs/CMakeLists.txt b/src/programs/CMakeLists.txt index 6d2c95cc..32a247ca 100644 --- a/src/programs/CMakeLists.txt +++ b/src/programs/CMakeLists.txt @@ -36,8 +36,9 @@ ecbuild_list_add_pattern( LIST driver_src ectrans-benchmark-data_mod.F90 QUIET ) -set(CMAKE_Fortran_PREPROCESS_SOURCE - " -cpp -E -o ") + #set(CMAKE_Fortran_PREPROCESS_SOURCE + # " -cpp -E -o ") + # "gcc -cpp -E -o ") # if( HAVE_${prec} ) # if( ${prec} MATCHES "sp" ) # set(precno 1) @@ -89,7 +90,7 @@ foreach( prec sp dp ) SOURCES ${driver_src} PUBLIC_LIBS fiat PRIVATE_LIBS parkind_${prec} trans_${prec} - PRIVATE_DEFINITIONS SYMBOLSUFFIX=${prec} + PRIVATE_DEFINITIONS SYMBOLSUFFIX=_${prec} PRECOPT=${precno} ) diff --git a/src/programs/ectrans-benchmark-driver_mod.F90 b/src/programs/ectrans-benchmark-driver_mod.F90 index 6127df14..60673d48 100644 --- a/src/programs/ectrans-benchmark-driver_mod.F90 +++ b/src/programs/ectrans-benchmark-driver_mod.F90 @@ -9,6 +9,7 @@ #include "renames.inc" MODULE transform_driver_mod use parkind1, only: jpim, jprb, jprd +use parkind1, only: jprc => jprb use oml_mod ,only : oml_max_threads use yomgstats, only: jpmaxstat use yomhook, only : dr_hook_init @@ -429,22 +430,22 @@ SUBROUTINE ectrans_print_norms_calc(nout,jstep,myproc,nflevg) do ifld = 1, 1 write(nout,*) "znormsp", znormsp call flush(nout) - zerr(1) = abs(znormsp1(ifld)/znormsp(ifld) - 1.0_jprb) + zerr(1) = abs(znormsp1(ifld)/znormsp(ifld) - 1.0_jprc) zmaxerr(1) = max(zmaxerr(1), zerr(1)) enddo ! Divergence do ifld = 1, nflevg - zerr(2) = abs(znormdiv1(ifld)/znormdiv(ifld) - 1.0_jprb) + zerr(2) = abs(znormdiv1(ifld)/znormdiv(ifld) - 1.0_jprc) zmaxerr(2) = max(zmaxerr(2), zerr(2)) enddo ! Vorticity do ifld = 1, nflevg - zerr(3) = abs(znormvor1(ifld)/znormvor(ifld) - 1.0_jprb) + zerr(3) = abs(znormvor1(ifld)/znormvor(ifld) - 1.0_jprc) zmaxerr(3) = max(zmaxerr(3),zerr(3)) enddo ! Temperature do ifld = 1, nflevg - zerr(4) = abs(znormt1(ifld)/znormt(ifld) - 1.0_jprb) + zerr(4) = abs(znormt1(ifld)/znormt(ifld) - 1.0_jprc) zmaxerr(4) = max(zmaxerr(4), zerr(4)) enddo write(nout,'("time step ",i6," took", f8.4," | zspvor max err="e10.3,& @@ -511,11 +512,11 @@ FUNCTION ectrans_print_norms_fails(nout,ncheck) result (ierr) integer(kind=jpim), intent(in) :: nout,ncheck integer(kind=jpim) :: ierr ierr = 0 - if (zmaxerrg > real(ncheck, jprb) * epsilon(1.0_jprb)) then + if (zmaxerrg > real(ncheck, jprb) * epsilon(1.0_jprc)) 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,1e7.2)') 'Error tolerance = ', real(ncheck, jprb) * epsilon(1.0_jprc) write(nout, '(a)') '*******************************' ierr = 1 endif diff --git a/src/trans/CMakeLists.txt b/src/trans/CMakeLists.txt index 09bf6249..bf070cf0 100644 --- a/src/trans/CMakeLists.txt +++ b/src/trans/CMakeLists.txt @@ -48,8 +48,8 @@ ecbuild_list_add_pattern( LIST trans_src if( NOT HAVE_FFTW ) ecbuild_list_exclude_pattern( LIST trans_src REGEX tpm_fftw.F90 ) endif() -set(CMAKE_Fortran_PREPROCESS_SOURCE - " -cpp -E -o ") +#set(CMAKE_Fortran_PREPROCESS_SOURCE +# " -cpp -E -o ") foreach( prec dp sp ) if( HAVE_${prec} ) @@ -69,7 +69,7 @@ foreach( prec dp sp ) $ $ PRIVATE_INCLUDES ${PROJECT_SOURCE_DIR}/src/trans/external - PRIVATE_DEFINITIONS SYMBOLSUFFIX=${prec} + PRIVATE_DEFINITIONS SYMBOLSUFFIX=_${prec} PRECOPT=${precno} PUBLIC_LIBS fiat parkind_${prec} ) diff --git a/src/trans/algor/bluestein_mod.F90 b/src/trans/algor/bluestein_mod.F90 index c935e9d2..9b8f2c07 100644 --- a/src/trans/algor/bluestein_mod.F90 +++ b/src/trans/algor/bluestein_mod.F90 @@ -7,7 +7,6 @@ ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. ! - MODULE BLUESTEIN_MOD ! Implementation of the Bluestein FFT algorithm as described in a paper titled @@ -19,6 +18,7 @@ MODULE BLUESTEIN_MOD ! The naming convention follows the algorithm description in the above paper. ! USE PARKIND1, ONLY : JPIM, JPRB +USE PARKIND1, ONLY : JPRC => JPRB IMPLICIT NONE @@ -98,7 +98,7 @@ SUBROUTINE BLUESTEIN_FFT(TB,N,KSIGN,KLOT,PDAT) ZDATAI(JLOT,K)=PDAT(JLOT,K*2+2) ZDATAI(JLOT,N-K) = -PDAT(JLOT,K*2+2) ENDDO - ZDATAI(JLOT,0)=0._JPRB + ZDATAI(JLOT,0)=0._JPRC ENDDO ENDIF @@ -138,7 +138,7 @@ SUBROUTINE BLUESTEIN_FFT(TB,N,KSIGN,KLOT,PDAT) ! zero padding of Y DO I=N,(M/2+1)*2 - ZY(:,I) = 0._JPRB + ZY(:,I) = 0._JPRC ENDDO ! FFT of Y @@ -322,8 +322,8 @@ SUBROUTINE BLUESTEIN_INIT(TB) ENDDO DO K=0,(M/2+1)*2 - TB%FFTB(N)%H2xT(1,K,ISIGN) = 0._JPRB - TB%FFTB(N)%H2xT(2,K,ISIGN) = 0._JPRB + TB%FFTB(N)%H2xT(1,K,ISIGN) = 0._JPRC + TB%FFTB(N)%H2xT(2,K,ISIGN) = 0._JPRC ENDDO TB%FFTB(N)%H2xT(1,0,ISIGN) = TB%FFTB(N)%HS(1,0,ISIGN) TB%FFTB(N)%H2xT(2,0,ISIGN) = TB%FFTB(N)%HS(2,0,ISIGN) @@ -336,8 +336,8 @@ SUBROUTINE BLUESTEIN_INIT(TB) ENDDO IF( M > 2*N-2 ) THEN DO K=N,M-N+1 - TB%FFTB(N)%H2xT(1,K,ISIGN) = 0._JPRB - TB%FFTB(N)%H2xT(2,K,ISIGN) = 0._JPRB + TB%FFTB(N)%H2xT(1,K,ISIGN) = 0._JPRC + TB%FFTB(N)%H2xT(2,K,ISIGN) = 0._JPRC ENDDO ENDIF diff --git a/src/trans/algor/fft992.F90 b/src/trans/algor/fft992.F90 index 3380812c..910daea3 100644 --- a/src/trans/algor/fft992.F90 +++ b/src/trans/algor/fft992.F90 @@ -60,6 +60,7 @@ SUBROUTINE FFT992(A,TRIGS_,IFAX_,INC,JUMP,N,LOT,ISIGN) !AUTOPROMOTE USE PARKIND1, ONLY : JPIM, JPRB + USE PARKIND1, ONLY : JPRC => JPRB USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK IMPLICIT NONE INTEGER(KIND=JPIM) :: N @@ -165,6 +166,7 @@ SUBROUTINE FFT992(A,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN) !disabled for now. REK.!DEC$ OPTIMIZE:3 !AUTOPROMOTE USE PARKIND1, ONLY : JPIM, JPRB + USE PARKIND1, ONLY : JPRC => JPRB USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK IMPLICIT NONE ! @@ -198,7 +200,7 @@ SUBROUTINE FFT992(A,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN) !OCL NOVREC !DEC$ IVDEP DO J=1,LOT - A(I+INC)=0.5_JPRB*A(I) + A(I+INC)=0.5_JPRC*A(I) I=I+JUMP ENDDO IF (MOD(N,2).EQ.0) THEN @@ -206,7 +208,7 @@ SUBROUTINE FFT992(A,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN) !OCL NOVREC !DEC$ IVDEP DO J=1,LOT - A(I)=0.5_JPRB*A(I) + A(I)=0.5_JPRC*A(I) I=I+JUMP ENDDO ENDIF @@ -275,8 +277,8 @@ SUBROUTINE FFT992(A,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN) !OCL NOVREC !DEC$ IVDEP DO J=1,LOT - A(IX)=0.0_JPRB - A(IX+INC)=0.0_JPRB + A(IX)=0.0_JPRC + A(IX+INC)=0.0_JPRC IX=IX+JUMP ENDDO ! @@ -353,13 +355,13 @@ SUBROUTINE FFT992(A,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN) !DEC$ IVDEP DO J=1,LOT A(IX)=A(IX+INC) - A(IX+INC)=0.0_JPRB + A(IX+INC)=0.0_JPRC IX=IX+JUMP ENDDO IF (MOD(N,2).EQ.0) THEN IX=(N+1)*INC+1 DO J=1,LOT - A(IX)=0.0_JPRB + A(IX)=0.0_JPRC IX=IX+JUMP ENDDO ENDIF @@ -437,8 +439,8 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & INTEGER(KIND=JPIM) :: L,M LOGICAL :: LIPL ! - DATA SIN36/0.587785252292473_JPRB/,SIN72/0.951056516295154_JPRB/, & - & QRT5/0.559016994374947_JPRB/,SIN60/0.866025403784437_JPRB/ + DATA SIN36/0.587785252292473_JPRC/,SIN72/0.951056516295154_JPRC/, & + & QRT5/0.559016994374947_JPRC/,SIN60/0.866025403784437_JPRC/ ! REAL(KIND=JPHOOK) :: ZHOOK_HANDLE M=N/IFAC @@ -549,7 +551,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !OCL NOVREC DO 292 IJK=1,ILOT T1=2.0*(A(IA+I)-A(IB+I)) - A(IA+I)=2.0_JPRB*(A(IA+I)+A(IB+I)) + A(IA+I)=2.0_JPRC*(A(IA+I)+A(IB+I)) A(IB+I)=T1 I=I+INC3 292 CONTINUE @@ -562,8 +564,8 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !OCL NOVREC !DEC$ IVDEP DO 296 IJK=1,ILOT - C(JA+J)=2.0_JPRB*(A(IA+I)+A(IB+I)) - C(JB+J)=2.0_JPRB*(A(IA+I)-A(IB+I)) + C(JA+J)=2.0_JPRC*(A(IA+I)+A(IB+I)) + C(JB+J)=2.0_JPRC*(A(IA+I)-A(IB+I)) I=I+INC3 J=J+INC4 296 CONTINUE @@ -594,8 +596,8 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !DEC$ IVDEP DO 310 IJK=1,ILOT C(JA+J)=A(IA+I)+A(IB+I) - C(JB+J)=(A(IA+I)-0.5_JPRB*A(IB+I))-(SIN60*(B(IB+I))) - C(JC+J)=(A(IA+I)-0.5_JPRB*A(IB+I))+(SIN60*(B(IB+I))) + C(JB+J)=(A(IA+I)-0.5_JPRC*A(IB+I))-(SIN60*(B(IB+I))) + C(JC+J)=(A(IA+I)-0.5_JPRC*A(IB+I))+(SIN60*(B(IB+I))) I=I+INC3 J=J+INC4 310 CONTINUE @@ -627,24 +629,24 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) D(JA+J)=B(IA+I)+(B(IB+I)-B(IC+I)) C(JB+J)= & - & C1*((A(IA+I)-0.5_JPRB*(A(IB+I)+A(IC+I)))- & + & C1*((A(IA+I)-0.5_JPRC*(A(IB+I)+A(IC+I)))- & & (SIN60*(B(IB+I)+B(IC+I)))) & - & -S1*((B(IA+I)-0.5_JPRB*(B(IB+I)-B(IC+I)))+ & + & -S1*((B(IA+I)-0.5_JPRC*(B(IB+I)-B(IC+I)))+ & & (SIN60*(A(IB+I)-A(IC+I)))) D(JB+J)= & - & S1*((A(IA+I)-0.5_JPRB*(A(IB+I)+A(IC+I)))- & + & S1*((A(IA+I)-0.5_JPRC*(A(IB+I)+A(IC+I)))- & & (SIN60*(B(IB+I)+B(IC+I)))) & - & +C1*((B(IA+I)-0.5_JPRB*(B(IB+I)-B(IC+I)))+ & + & +C1*((B(IA+I)-0.5_JPRC*(B(IB+I)-B(IC+I)))+ & & (SIN60*(A(IB+I)-A(IC+I)))) C(JC+J)= & - & C2*((A(IA+I)-0.5_JPRB*(A(IB+I)+A(IC+I)))+ & + & C2*((A(IA+I)-0.5_JPRC*(A(IB+I)+A(IC+I)))+ & & (SIN60*(B(IB+I)+B(IC+I)))) & - & -S2*((B(IA+I)-0.5_JPRB*(B(IB+I)-B(IC+I)))- & + & -S2*((B(IA+I)-0.5_JPRC*(B(IB+I)-B(IC+I)))- & & (SIN60*(A(IB+I)-A(IC+I)))) D(JC+J)= & - & S2*((A(IA+I)-0.5_JPRB*(A(IB+I)+A(IC+I)))+ & + & S2*((A(IA+I)-0.5_JPRC*(A(IB+I)+A(IC+I)))+ & & (SIN60*(B(IB+I)+B(IC+I)))) & - & +C2*((B(IA+I)-0.5_JPRB*(B(IB+I)-B(IC+I)))- & + & +C2*((B(IA+I)-0.5_JPRC*(B(IB+I)-B(IC+I)))- & & (SIN60*(A(IB+I)-A(IC+I)))) I=I+INC3 J=J+INC4 @@ -668,8 +670,8 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !DEC$ IVDEP DO 370 IJK=1,ILOT C(JA+J)=A(IA+I)+A(IB+I) - C(JB+J)=(0.5_JPRB*A(IA+I)-A(IB+I))-(SIN60*B(IA+I)) - C(JC+J)=-(0.5_JPRB*A(IA+I)-A(IB+I))-(SIN60*B(IA+I)) + C(JB+J)=(0.5_JPRC*A(IA+I)-A(IB+I))-(SIN60*B(IA+I)) + C(JC+J)=-(0.5_JPRC*A(IA+I)-A(IB+I))-(SIN60*B(IA+I)) I=I+INC3 J=J+INC4 370 CONTINUE @@ -685,9 +687,9 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & I=IBASE !OCL NOVREC DO 392 IJK=1,ILOT - T1=(2.0_JPRB*A(IA+I)-A(IB+I))-(SSIN60*B(IB+I)) - T2=(2.0_JPRB*A(IA+I)-A(IB+I))+(SSIN60*B(IB+I)) - A(IA+I)=2.0_JPRB*(A(IA+I)+A(IB+I)) + T1=(2.0_JPRC*A(IA+I)-A(IB+I))-(SSIN60*B(IB+I)) + T2=(2.0_JPRC*A(IA+I)-A(IB+I))+(SSIN60*B(IB+I)) + A(IA+I)=2.0_JPRC*(A(IA+I)+A(IB+I)) A(IB+I)=T1 B(IB+I)=T2 I=I+INC3 @@ -701,9 +703,9 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !OCL NOVREC !DEC$ IVDEP DO 396 IJK=1,ILOT - C(JA+J)=2.0_JPRB*(A(IA+I)+A(IB+I)) - C(JB+J)=(2.0_JPRB*A(IA+I)-A(IB+I))-(SSIN60*B(IB+I)) - C(JC+J)=(2.0_JPRB*A(IA+I)-A(IB+I))+(SSIN60*B(IB+I)) + C(JA+J)=2.0_JPRC*(A(IA+I)+A(IB+I)) + C(JB+J)=(2.0_JPRC*A(IA+I)-A(IB+I))-(SSIN60*B(IB+I)) + C(JC+J)=(2.0_JPRC*A(IA+I)-A(IB+I))+(SSIN60*B(IB+I)) I=I+INC3 J=J+INC4 396 CONTINUE @@ -807,7 +809,7 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & ! IF (IB.EQ.IC) THEN IBASE=0 - SIN45=SQRT(0.5_JPRB) + SIN45=SQRT(0.5_JPRC) DO 480 L=1,ILA I=IBASE J=JBASE @@ -832,10 +834,10 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & I=IBASE !OCL NOVREC DO 492 IJK=1,ILOT - T1=2.0_JPRB*((A(IA+I)-A(IC+I))-B(IB+I)) - T2=2.0_JPRB*((A(IA+I)+A(IC+I))-A(IB+I)) - T3=2.0_JPRB*((A(IA+I)-A(IC+I))+B(IB+I)) - A(IA+I)=2.0_JPRB*((A(IA+I)+A(IC+I))+A(IB+I)) + T1=2.0_JPRC*((A(IA+I)-A(IC+I))-B(IB+I)) + T2=2.0_JPRC*((A(IA+I)+A(IC+I))-A(IB+I)) + T3=2.0_JPRC*((A(IA+I)-A(IC+I))+B(IB+I)) + A(IA+I)=2.0_JPRC*((A(IA+I)+A(IC+I))+A(IB+I)) A(IB+I)=T1 B(IB+I)=T2 A(IC+I)=T3 @@ -850,10 +852,10 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !OCL NOVREC !DEC$ IVDEP DO 496 IJK=1,ILOT - C(JA+J)=2.0_JPRB*((A(IA+I)+A(IC+I))+A(IB+I)) - C(JB+J)=2.0_JPRB*((A(IA+I)-A(IC+I))-B(IB+I)) - C(JC+J)=2.0_JPRB*((A(IA+I)+A(IC+I))-A(IB+I)) - C(JD+J)=2.0_JPRB*((A(IA+I)-A(IC+I))+B(IB+I)) + C(JA+J)=2.0_JPRC*((A(IA+I)+A(IC+I))+A(IB+I)) + C(JB+J)=2.0_JPRC*((A(IA+I)-A(IC+I))-B(IB+I)) + C(JC+J)=2.0_JPRC*((A(IA+I)+A(IC+I))-A(IB+I)) + C(JD+J)=2.0_JPRC*((A(IA+I)-A(IC+I))+B(IB+I)) I=I+INC3 J=J+INC4 496 CONTINUE @@ -888,13 +890,13 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !DEC$ IVDEP DO 510 IJK=1,ILOT C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - C(JB+J)=((A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I)))+ & + C(JB+J)=((A(IA+I)-0.25_JPRC*(A(IB+I)+A(IC+I)))+ & & QRT5*(A(IB+I)-A(IC+I)))-(SIN72*B(IB+I)+SIN36*B(IC+I)) - C(JC+J)=((A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I)))- & + C(JC+J)=((A(IA+I)-0.25_JPRC*(A(IB+I)+A(IC+I)))- & & QRT5*(A(IB+I)-A(IC+I)))-(SIN36*B(IB+I)-SIN72*B(IC+I)) - C(JD+J)=((A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I)))- & + C(JD+J)=((A(IA+I)-0.25_JPRC*(A(IB+I)+A(IC+I)))- & & QRT5*(A(IB+I)-A(IC+I)))+(SIN36*B(IB+I)-SIN72*B(IC+I)) - C(JE+J)=((A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I)))+ & + C(JE+J)=((A(IA+I)-0.25_JPRC*(A(IB+I)+A(IC+I)))+ & & QRT5*(A(IB+I)-A(IC+I)))+(SIN72*B(IB+I)+SIN36*B(IC+I)) I=I+INC3 J=J+INC4 @@ -933,13 +935,13 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !DEC$ IVDEP DO 530 IJK=1,ILOT ! - A10=(A(IA+I)-0.25_JPRB*((A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)))) & + A10=(A(IA+I)-0.25_JPRC*((A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)))) & & +QRT5*((A(IB+I)+A(IE+I))-(A(IC+I)+A(ID+I))) - A20=(A(IA+I)-0.25_JPRB*((A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)))) & + A20=(A(IA+I)-0.25_JPRC*((A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)))) & & -QRT5*((A(IB+I)+A(IE+I))-(A(IC+I)+A(ID+I))) - B10=(B(IA+I)-0.25_JPRB*((B(IB+I)-B(IE+I))+(B(IC+I)-B(ID+I)))) & + B10=(B(IA+I)-0.25_JPRC*((B(IB+I)-B(IE+I))+(B(IC+I)-B(ID+I)))) & & +QRT5*((B(IB+I)-B(IE+I))-(B(IC+I)-B(ID+I))) - B20=(B(IA+I)-0.25_JPRB*((B(IB+I)-B(IE+I))+(B(IC+I)-B(ID+I)))) & + B20=(B(IA+I)-0.25_JPRC*((B(IB+I)-B(IE+I))+(B(IC+I)-B(ID+I)))) & & -QRT5*((B(IB+I)-B(IE+I))-(B(IC+I)-B(ID+I))) A11=SIN72*(B(IB+I)+B(IE+I))+SIN36*(B(IC+I)+B(ID+I)) A21=SIN36*(B(IB+I)+B(IE+I))-SIN72*(B(IC+I)+B(ID+I)) @@ -982,16 +984,16 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & DO 570 IJK=1,ILOT C(JA+J)=(A(IA+I)+A(IB+I))+A(IC+I) C(JB+J)=(QRT5*(A(IA+I)-A(IB+I))+ & - & (0.25_JPRB*(A(IA+I)+A(IB+I))-A(IC+I))) & + & (0.25_JPRC*(A(IA+I)+A(IB+I))-A(IC+I))) & & -(SIN36*B(IA+I)+SIN72*B(IB+I)) C(JE+J)=-(QRT5*(A(IA+I)-A(IB+I))+ & - & (0.25_JPRB*(A(IA+I)+A(IB+I))-A(IC+I))) & + & (0.25_JPRC*(A(IA+I)+A(IB+I))-A(IC+I))) & & -(SIN36*B(IA+I)+SIN72*B(IB+I)) C(JC+J)=(QRT5*(A(IA+I)-A(IB+I))- & - & (0.25_JPRB*(A(IA+I)+A(IB+I))-A(IC+I))) & + & (0.25_JPRC*(A(IA+I)+A(IB+I))-A(IC+I))) & & -(SIN72*B(IA+I)-SIN36*B(IB+I)) C(JD+J)=-(QRT5*(A(IA+I)-A(IB+I))- & - & (0.25_JPRB*(A(IA+I)+A(IB+I))-A(IC+I))) & + & (0.25_JPRC*(A(IA+I)+A(IB+I))-A(IC+I))) & & -(SIN72*B(IA+I)-SIN36*B(IB+I)) I=I+INC3 J=J+INC4 @@ -1010,15 +1012,15 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & I=IBASE !OCL NOVREC DO 592 IJK=1,ILOT - T1=(2.0_JPRB*(A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I))) & + T1=(2.0_JPRC*(A(IA+I)-0.25_JPRC*(A(IB+I)+A(IC+I))) & & +QQRT5*(A(IB+I)-A(IC+I)))-(SSIN72*B(IB+I)+SSIN36*B(IC+I)) - T2=(2.0_JPRB*(A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I))) & + T2=(2.0_JPRC*(A(IA+I)-0.25_JPRC*(A(IB+I)+A(IC+I))) & & -QQRT5*(A(IB+I)-A(IC+I)))-(SSIN36*B(IB+I)-SSIN72*B(IC+I)) - T3=(2.0_JPRB*(A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I))) & + T3=(2.0_JPRC*(A(IA+I)-0.25_JPRC*(A(IB+I)+A(IC+I))) & & -QQRT5*(A(IB+I)-A(IC+I)))+(SSIN36*B(IB+I)-SSIN72*B(IC+I)) - T4=(2.0_JPRB*(A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I))) & + T4=(2.0_JPRC*(A(IA+I)-0.25_JPRC*(A(IB+I)+A(IC+I))) & & +QQRT5*(A(IB+I)-A(IC+I)))+(SSIN72*B(IB+I)+SSIN36*B(IC+I)) - A(IA+I)=2.0_JPRB*(A(IA+I)+(A(IB+I)+A(IC+I))) + A(IA+I)=2.0_JPRC*(A(IA+I)+(A(IB+I)+A(IC+I))) A(IB+I)=T1 B(IB+I)=T2 A(IC+I)=T3 @@ -1034,14 +1036,14 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !OCL NOVREC !DEC$ IVDEP DO 596 IJK=1,ILOT - C(JA+J)=2.0_JPRB*(A(IA+I)+(A(IB+I)+A(IC+I))) - C(JB+J)=(2.0_JPRB*(A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I))) & + C(JA+J)=2.0_JPRC*(A(IA+I)+(A(IB+I)+A(IC+I))) + C(JB+J)=(2.0_JPRC*(A(IA+I)-0.25_JPRC*(A(IB+I)+A(IC+I))) & & +QQRT5*(A(IB+I)-A(IC+I)))-(SSIN72*B(IB+I)+SSIN36*B(IC+I)) - C(JC+J)=(2.0_JPRB*(A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I))) & + C(JC+J)=(2.0_JPRC*(A(IA+I)-0.25_JPRC*(A(IB+I)+A(IC+I))) & & -QQRT5*(A(IB+I)-A(IC+I)))-(SSIN36*B(IB+I)-SSIN72*B(IC+I)) - C(JD+J)=(2.0_JPRB*(A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I))) & + C(JD+J)=(2.0_JPRC*(A(IA+I)-0.25_JPRC*(A(IB+I)+A(IC+I))) & & -QQRT5*(A(IB+I)-A(IC+I)))+(SSIN36*B(IB+I)-SSIN72*B(IC+I)) - C(JE+J)=(2.0_JPRB*(A(IA+I)-0.25_JPRB*(A(IB+I)+A(IC+I))) & + C(JE+J)=(2.0_JPRC*(A(IA+I)-0.25_JPRC*(A(IB+I)+A(IC+I))) & & +QQRT5*(A(IB+I)-A(IC+I)))+(SSIN72*B(IB+I)+SSIN36*B(IC+I)) I=I+INC3 J=J+INC4 @@ -1080,13 +1082,13 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & DO 610 IJK=1,ILOT C(JA+J)=(A(IA+I)+A(ID+I))+(A(IB+I)+A(IC+I)) C(JD+J)=(A(IA+I)-A(ID+I))-(A(IB+I)-A(IC+I)) - C(JB+J)=((A(IA+I)-A(ID+I))+0.5_JPRB*(A(IB+I)-A(IC+I))) & + C(JB+J)=((A(IA+I)-A(ID+I))+0.5_JPRC*(A(IB+I)-A(IC+I))) & & -(SIN60*(B(IB+I)+B(IC+I))) - C(JF+J)=((A(IA+I)-A(ID+I))+0.5_JPRB*(A(IB+I)-A(IC+I))) & + C(JF+J)=((A(IA+I)-A(ID+I))+0.5_JPRC*(A(IB+I)-A(IC+I))) & & +(SIN60*(B(IB+I)+B(IC+I))) - C(JC+J)=((A(IA+I)+A(ID+I))-0.5_JPRB*(A(IB+I)+A(IC+I))) & + C(JC+J)=((A(IA+I)+A(ID+I))-0.5_JPRC*(A(IB+I)+A(IC+I))) & & -(SIN60*(B(IB+I)-B(IC+I))) - C(JE+J)=((A(IA+I)+A(ID+I))-0.5_JPRB*(A(IB+I)+A(IC+I))) & + C(JE+J)=((A(IA+I)+A(ID+I))-0.5_JPRC*(A(IB+I)+A(IC+I))) & & +(SIN60*(B(IB+I)-B(IC+I))) I=I+INC3 J=J+INC4 @@ -1130,10 +1132,10 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & DO 630 IJK=1,ILOT ! A11= (A(IE+I)+A(IB+I))+(A(IC+I)+A(IF+I)) - A20=(A(IA+I)+A(ID+I))-0.5_JPRB*A11 + A20=(A(IA+I)+A(ID+I))-0.5_JPRC*A11 A21=SIN60*((A(IE+I)+A(IB+I))-(A(IC+I)+A(IF+I))) B11= (B(IB+I)-B(IE+I))+(B(IC+I)-B(IF+I)) - B20=(B(IA+I)-B(ID+I))-0.5_JPRB*B11 + B20=(B(IA+I)-B(ID+I))-0.5_JPRC*B11 B21=SIN60*((B(IB+I)-B(IE+I))-(B(IC+I)-B(IF+I))) ! C(JA+J)=(A(IA+I)+A(ID+I))+A11 @@ -1145,9 +1147,9 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & ! A11=(A(IE+I)-A(IB+I))+(A(IC+I)-A(IF+I)) B11=(B(IE+I)+B(IB+I))-(B(IC+I)+B(IF+I)) - A20=(A(IA+I)-A(ID+I))-0.5_JPRB*A11 + A20=(A(IA+I)-A(ID+I))-0.5_JPRC*A11 A21=SIN60*((A(IE+I)-A(IB+I))-(A(IC+I)-A(IF+I))) - B20=(B(IA+I)+B(ID+I))+0.5_JPRB*B11 + B20=(B(IA+I)+B(ID+I))+0.5_JPRC*B11 B21=SIN60*((B(IE+I)+B(IB+I))+(B(IC+I)+B(IF+I))) ! C(JD+J)= & @@ -1186,13 +1188,13 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & C(JA+J)=A(IB+I)+(A(IA+I)+A(IC+I)) C(JD+J)=B(IB+I)-(B(IA+I)+B(IC+I)) C(JB+J)=(SIN60*(A(IA+I)-A(IC+I)))- & - & (0.5_JPRB*(B(IA+I)+B(IC+I))+B(IB+I)) + & (0.5_JPRC*(B(IA+I)+B(IC+I))+B(IB+I)) C(JF+J)=-(SIN60*(A(IA+I)-A(IC+I)))- & - & (0.5_JPRB*(B(IA+I)+B(IC+I))+B(IB+I)) + & (0.5_JPRC*(B(IA+I)+B(IC+I))+B(IB+I)) C(JC+J)=SIN60*(B(IC+I)-B(IA+I))+ & - & (0.5_JPRB*(A(IA+I)+A(IC+I))-A(IB+I)) + & (0.5_JPRC*(A(IA+I)+A(IC+I))-A(IB+I)) C(JE+J)=SIN60*(B(IC+I)-B(IA+I))- & - & (0.5_JPRB*(A(IA+I)+A(IC+I))-A(IB+I)) + & (0.5_JPRC*(A(IA+I)+A(IC+I))-A(IB+I)) I=I+INC3 J=J+INC4 670 CONTINUE @@ -1202,23 +1204,23 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & ENDIF ! ELSE !!! Case LA=M - SSIN60=2.0_JPRB*SIN60 + SSIN60=2.0_JPRC*SIN60 IF (LIPL) THEN DO 694 L=1,ILA I=IBASE !OCL NOVREC DO 692 IJK=1,ILOT - T1=(2.0_JPRB*(A(IA+I)-A(ID+I))+(A(IB+I)-A(IC+I))) & + T1=(2.0_JPRC*(A(IA+I)-A(ID+I))+(A(IB+I)-A(IC+I))) & & -(SSIN60*(B(IB+I)+B(IC+I))) - T5=(2.0_JPRB*(A(IA+I)-A(ID+I))+(A(IB+I)-A(IC+I))) & + T5=(2.0_JPRC*(A(IA+I)-A(ID+I))+(A(IB+I)-A(IC+I))) & & +(SSIN60*(B(IB+I)+B(IC+I))) - T2=(2.0_JPRB*(A(IA+I)+A(ID+I))-(A(IB+I)+A(IC+I))) & + T2=(2.0_JPRC*(A(IA+I)+A(ID+I))-(A(IB+I)+A(IC+I))) & & -(SSIN60*(B(IB+I)-B(IC+I))) - T4=(2.0_JPRB*(A(IA+I)+A(ID+I))-(A(IB+I)+A(IC+I))) & + T4=(2.0_JPRC*(A(IA+I)+A(ID+I))-(A(IB+I)+A(IC+I))) & & +(SSIN60*(B(IB+I)-B(IC+I))) - T3=(2.0_JPRB*(A(IA+I)-A(ID+I)))-(2.0_JPRB*(A(IB+I)-A(IC+I))) - A(IA+I)=(2.0_JPRB*(A(IA+I)+A(ID+I)))+ & - & (2.0_JPRB*(A(IB+I)+A(IC+I))) + T3=(2.0_JPRC*(A(IA+I)-A(ID+I)))-(2.0_JPRC*(A(IB+I)-A(IC+I))) + A(IA+I)=(2.0_JPRC*(A(IA+I)+A(ID+I)))+ & + & (2.0_JPRC*(A(IB+I)+A(IC+I))) A(IB+I)=T1 B(IB+I)=T2 A(IC+I)=T3 @@ -1235,17 +1237,17 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !OCL NOVREC !DEC$ IVDEP DO 696 IJK=1,ILOT - C(JA+J)=(2.0_JPRB*(A(IA+I)+A(ID+I)))+ & - & (2.0_JPRB*(A(IB+I)+A(IC+I))) - C(JD+J)=(2.0_JPRB*(A(IA+I)-A(ID+I)))- & - & (2.0_JPRB*(A(IB+I)-A(IC+I))) - C(JB+J)=(2.0_JPRB*(A(IA+I)-A(ID+I))+(A(IB+I)-A(IC+I))) & + C(JA+J)=(2.0_JPRC*(A(IA+I)+A(ID+I)))+ & + & (2.0_JPRC*(A(IB+I)+A(IC+I))) + C(JD+J)=(2.0_JPRC*(A(IA+I)-A(ID+I)))- & + & (2.0_JPRC*(A(IB+I)-A(IC+I))) + C(JB+J)=(2.0_JPRC*(A(IA+I)-A(ID+I))+(A(IB+I)-A(IC+I))) & & -(SSIN60*(B(IB+I)+B(IC+I))) - C(JF+J)=(2.0_JPRB*(A(IA+I)-A(ID+I))+(A(IB+I)-A(IC+I))) & + C(JF+J)=(2.0_JPRC*(A(IA+I)-A(ID+I))+(A(IB+I)-A(IC+I))) & & +(SSIN60*(B(IB+I)+B(IC+I))) - C(JC+J)=(2.0_JPRB*(A(IA+I)+A(ID+I))-(A(IB+I)+A(IC+I))) & + C(JC+J)=(2.0_JPRC*(A(IA+I)+A(ID+I))-(A(IB+I)+A(IC+I))) & & -(SSIN60*(B(IB+I)-B(IC+I))) - C(JE+J)=(2.0_JPRB*(A(IA+I)+A(ID+I))-(A(IB+I)+A(IC+I))) & + C(JE+J)=(2.0_JPRC*(A(IA+I)+A(ID+I))-(A(IB+I)+A(IC+I))) & & +(SSIN60*(B(IB+I)-B(IC+I))) I=I+INC3 J=J+INC4 @@ -1277,25 +1279,25 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & JF=JE+JINK JG=JF+JINK JH=JG+JINK - SSIN45=SQRT(2.0_JPRB) + SSIN45=SQRT(2.0_JPRC) ! IF (LIPL) THEN DO 820 L=1,ILA I=IBASE !OCL NOVREC DO 810 IJK=1,ILOT - T2=2.0_JPRB*(((A(IA+I)+A(IE+I))-A(IC+I))-(B(IB+I)-B(ID+I))) - T6=2.0_JPRB*(((A(IA+I)+A(IE+I))-A(IC+I))+(B(IB+I)-B(ID+I))) - T1=2.0_JPRB*((A(IA+I)-A(IE+I))-B(IC+I)) & + T2=2.0_JPRC*(((A(IA+I)+A(IE+I))-A(IC+I))-(B(IB+I)-B(ID+I))) + T6=2.0_JPRC*(((A(IA+I)+A(IE+I))-A(IC+I))+(B(IB+I)-B(ID+I))) + T1=2.0_JPRC*((A(IA+I)-A(IE+I))-B(IC+I)) & & +SSIN45*((A(IB+I)-A(ID+I))-(B(IB+I)+B(ID+I))) - T5=2.0_JPRB*((A(IA+I)-A(IE+I))-B(IC+I)) & + T5=2.0_JPRC*((A(IA+I)-A(IE+I))-B(IC+I)) & & -SSIN45*((A(IB+I)-A(ID+I))-(B(IB+I)+B(ID+I))) - T3=2.0_JPRB*((A(IA+I)-A(IE+I))+B(IC+I)) & + T3=2.0_JPRC*((A(IA+I)-A(IE+I))+B(IC+I)) & & -SSIN45*((A(IB+I)-A(ID+I))+(B(IB+I)+B(ID+I))) - T7=2.0_JPRB*((A(IA+I)-A(IE+I))+B(IC+I)) & + T7=2.0_JPRC*((A(IA+I)-A(IE+I))+B(IC+I)) & & +SSIN45*((A(IB+I)-A(ID+I))+(B(IB+I)+B(ID+I))) - T4=2.0_JPRB*(((A(IA+I)+A(IE+I))+A(IC+I))-(A(IB+I)+A(ID+I))) - A(IA+I)=2.0_JPRB*(((A(IA+I)+A(IE+I))+A(IC+I))+(A(IB+I)+A(ID+I))) + T4=2.0_JPRC*(((A(IA+I)+A(IE+I))+A(IC+I))-(A(IB+I)+A(ID+I))) + A(IA+I)=2.0_JPRC*(((A(IA+I)+A(IE+I))+A(IC+I))+(A(IB+I)+A(ID+I))) A(IB+I)=T1 B(IB+I)=T2 A(IC+I)=T3 @@ -1314,17 +1316,17 @@ SUBROUTINE RPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !OCL NOVREC !DEC$ IVDEP DO 830 IJK=1,ILOT - C(JA+J)=2.0_JPRB*(((A(IA+I)+A(IE+I))+A(IC+I))+(A(IB+I)+A(ID+I))) - C(JE+J)=2.0_JPRB*(((A(IA+I)+A(IE+I))+A(IC+I))-(A(IB+I)+A(ID+I))) - C(JC+J)=2.0_JPRB*(((A(IA+I)+A(IE+I))-A(IC+I))-(B(IB+I)-B(ID+I))) - C(JG+J)=2.0_JPRB*(((A(IA+I)+A(IE+I))-A(IC+I))+(B(IB+I)-B(ID+I))) - C(JB+J)=2.0_JPRB*((A(IA+I)-A(IE+I))-B(IC+I)) & + C(JA+J)=2.0_JPRC*(((A(IA+I)+A(IE+I))+A(IC+I))+(A(IB+I)+A(ID+I))) + C(JE+J)=2.0_JPRC*(((A(IA+I)+A(IE+I))+A(IC+I))-(A(IB+I)+A(ID+I))) + C(JC+J)=2.0_JPRC*(((A(IA+I)+A(IE+I))-A(IC+I))-(B(IB+I)-B(ID+I))) + C(JG+J)=2.0_JPRC*(((A(IA+I)+A(IE+I))-A(IC+I))+(B(IB+I)-B(ID+I))) + C(JB+J)=2.0_JPRC*((A(IA+I)-A(IE+I))-B(IC+I)) & & +SSIN45*((A(IB+I)-A(ID+I))-(B(IB+I)+B(ID+I))) - C(JF+J)=2.0_JPRB*((A(IA+I)-A(IE+I))-B(IC+I)) & + C(JF+J)=2.0_JPRC*((A(IA+I)-A(IE+I))-B(IC+I)) & & -SSIN45*((A(IB+I)-A(ID+I))-(B(IB+I)+B(ID+I))) - C(JD+J)=2.0_JPRB*((A(IA+I)-A(IE+I))+B(IC+I)) & + C(JD+J)=2.0_JPRC*((A(IA+I)-A(IE+I))+B(IC+I)) & & -SSIN45*((A(IB+I)-A(ID+I))+(B(IB+I)+B(ID+I))) - C(JH+J)=2.0_JPRB*((A(IA+I)-A(IE+I))+B(IC+I)) & + C(JH+J)=2.0_JPRC*((A(IA+I)-A(IE+I))+B(IC+I)) & & +SSIN45*((A(IB+I)-A(ID+I))+(B(IB+I)+B(ID+I))) I=I+INC3 J=J+INC4 @@ -1412,8 +1414,8 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & INTEGER(KIND=JPIM) :: L,M LOGICAL :: LIPL ! - DATA SIN36/0.587785252292473_JPRB/,SIN72/0.951056516295154_JPRB/, & - & QRT5/0.559016994374947_JPRB/,SIN60/0.866025403784437_JPRB/ + DATA SIN36/0.587785252292473_JPRC/,SIN72/0.951056516295154_JPRC/, & + & QRT5/0.559016994374947_JPRC/,SIN60/0.866025403784437_JPRC/ ! REAL(KIND=JPHOOK) :: ZHOOK_HANDLE M=N/IFAC @@ -1518,7 +1520,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & ENDIF ! ELSE !!! Case LA=M - Z=1.0_JPRB/REAL(N,KIND=JPRB) + Z=1.0_JPRC/REAL(N,KIND=JPRB) IF (LIPL) THEN DO 294 L=1,ILA I=IBASE @@ -1571,7 +1573,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !DEC$ IVDEP DO 310 IJK=1,ILOT C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - C(JB+J)=A(IA+I)-0.5_JPRB*(A(IB+I)+A(IC+I)) + C(JB+J)=A(IA+I)-0.5_JPRC*(A(IB+I)+A(IC+I)) D(JB+J)=SIN60*(A(IC+I)-A(IB+I)) I=I+INC3 J=J+INC4 @@ -1603,8 +1605,8 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & DO 330 IJK=1,ILOT A1=(C1*A(IB+I)+S1*B(IB+I))+(C2*A(IC+I)+S2*B(IC+I)) B1=(C1*B(IB+I)-S1*A(IB+I))+(C2*B(IC+I)-S2*A(IC+I)) - A2=A(IA+I)-0.5_JPRB*A1 - B2=B(IA+I)-0.5_JPRB*B1 + A2=A(IA+I)-0.5_JPRC*A1 + B2=B(IA+I)-0.5_JPRC*B1 A3=SIN60*((C1*A(IB+I)+S1*B(IB+I))-(C2*A(IC+I)+S2*B(IC+I))) B3=SIN60*((C1*B(IB+I)-S1*A(IB+I))-(C2*B(IC+I)-S2*A(IC+I))) C(JA+J)=A(IA+I)+A1 @@ -1634,7 +1636,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !OCL NOVREC !DEC$ IVDEP DO 370 IJK=1,ILOT - C(JA+J)=A(IA+I)+0.5_JPRB*(A(IB+I)-A(IC+I)) + C(JA+J)=A(IA+I)+0.5_JPRC*(A(IB+I)-A(IC+I)) D(JA+J)=-SIN60*(A(IB+I)+A(IC+I)) C(JB+J)=A(IA+I)-(A(IB+I)-A(IC+I)) I=I+INC3 @@ -1646,7 +1648,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & ENDIF ! ELSE !!! Case LA=M - Z=1.0_JPRB/REAL(N,KIND=JPRB) + Z=1.0_JPRC/REAL(N,KIND=JPRB) ZSIN60=Z*SIN60 IF (LIPL) THEN DO 394 L=1,ILA @@ -1654,7 +1656,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !OCL NOVREC !DEC$ IVDEP DO 392 IJK=1,ILOT - T1=Z*(A(IA+I)-0.5_JPRB*(A(IB+I)+A(IC+I))) + T1=Z*(A(IA+I)-0.5_JPRC*(A(IB+I)+A(IC+I))) T2=ZSIN60*(A(IC+I)-A(IB+I)) A(IA+I)=Z*(A(IA+I)+(A(IB+I)+A(IC+I))) A(IB+I)=T1 @@ -1671,7 +1673,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !DEC$ IVDEP DO 396 IJK=1,ILOT C(JA+J)=Z*(A(IA+I)+(A(IB+I)+A(IC+I))) - C(JB+J)=Z*(A(IA+I)-0.5_JPRB*(A(IB+I)+A(IC+I))) + C(JB+J)=Z*(A(IA+I)-0.5_JPRC*(A(IB+I)+A(IC+I))) D(JB+J)=ZSIN60*(A(IC+I)-A(IB+I)) I=I+INC3 J=J+INC4 @@ -1771,7 +1773,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & ENDIF ! IF (JB.EQ.JC) THEN - SIN45=SQRT(0.5_JPRB) + SIN45=SQRT(0.5_JPRC) JBASE=0 DO 480 L=1,ILA I=IBASE @@ -1792,7 +1794,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & ENDIF ! ELSE !!! Case LA=M - Z=1.0_JPRB/REAL(N,KIND=JPRB) + Z=1.0_JPRC/REAL(N,KIND=JPRB) IF (LIPL) THEN DO 494 L=1,ILA I=IBASE @@ -1858,7 +1860,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & A3=A(IB+I)-A(IE+I) A2=A(IC+I)+A(ID+I) A4=A(IC+I)-A(ID+I) - A5=A(IA+I)-0.25_JPRB*(A1+A2) + A5=A(IA+I)-0.25_JPRC*(A1+A2) A6=QRT5*(A1-A2) C(JA+J)=A(IA+I)+(A1+A2) C(JB+J)=A5+A6 @@ -1909,9 +1911,9 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & B3=(C1*B(IB+I)-S1*A(IB+I))-(C4*B(IE+I)-S4*A(IE+I)) B2=(C2*B(IC+I)-S2*A(IC+I))+(C3*B(ID+I)-S3*A(ID+I)) B4=(C2*B(IC+I)-S2*A(IC+I))-(C3*B(ID+I)-S3*A(ID+I)) - A5=A(IA+I)-0.25_JPRB*(A1+A2) + A5=A(IA+I)-0.25_JPRC*(A1+A2) A6=QRT5*(A1-A2) - B5=B(IA+I)-0.25_JPRB*(B1+B2) + B5=B(IA+I)-0.25_JPRC*(B1+B2) B6=QRT5*(B1-B2) A10=A5+A6 A20=A5-A6 @@ -1958,7 +1960,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & A3=A(IB+I)-A(IE+I) A2=A(IC+I)+A(ID+I) A4=A(IC+I)-A(ID+I) - A5=A(IA+I)+0.25_JPRB*(A3-A4) + A5=A(IA+I)+0.25_JPRC*(A3-A4) A6=QRT5*(A3+A4) C(JA+J)=A5+A6 C(JB+J)=A5-A6 @@ -1974,7 +1976,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & ENDIF ! ELSE !!! Case LA=M - Z=1.0_JPRB/REAL(N,KIND=JPRB) + Z=1.0_JPRC/REAL(N,KIND=JPRB) ZQRT5=Z*QRT5 ZSIN36=Z*SIN36 ZSIN72=Z*SIN72 @@ -1988,7 +1990,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & A3=A(IB+I)-A(IE+I) A2=A(IC+I)+A(ID+I) A4=A(IC+I)-A(ID+I) - A5=Z*(A(IA+I)-0.25_JPRB*(A1+A2)) + A5=Z*(A(IA+I)-0.25_JPRC*(A1+A2)) A6=ZQRT5*(A1-A2) A(IA+I)=Z*(A(IA+I)+(A1+A2)) A(IB+I)=A5+A6 @@ -2010,7 +2012,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & A3=A(IB+I)-A(IE+I) A2=A(IC+I)+A(ID+I) A4=A(IC+I)-A(ID+I) - A5=Z*(A(IA+I)-0.25_JPRB*(A1+A2)) + A5=Z*(A(IA+I)-0.25_JPRC*(A1+A2)) A6=ZQRT5*(A1-A2) C(JA+J)=Z*(A(IA+I)+(A1+A2)) C(JB+J)=A5+A6 @@ -2054,10 +2056,10 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & DO 610 IJK=1,ILOT A11=(A(IC+I)+A(IF+I))+(A(IB+I)+A(IE+I)) C(JA+J)=(A(IA+I)+A(ID+I))+A11 - C(JC+J)=(A(IA+I)+A(ID+I)-0.5_JPRB*A11) + C(JC+J)=(A(IA+I)+A(ID+I)-0.5_JPRC*A11) D(JC+J)=SIN60*((A(IC+I)+A(IF+I))-(A(IB+I)+A(IE+I))) A11=(A(IC+I)-A(IF+I))+(A(IE+I)-A(IB+I)) - C(JB+J)=(A(IA+I)-A(ID+I))-0.5_JPRB*A11 + C(JB+J)=(A(IA+I)-A(ID+I))-0.5_JPRC*A11 D(JB+J)=SIN60*((A(IE+I)-A(IB+I))-(A(IC+I)-A(IF+I))) C(JD+J)=(A(IA+I)-A(ID+I))+A11 I=I+INC3 @@ -2111,10 +2113,10 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & A5=C5*A(IF+I)+S5*B(IF+I) B5=C5*B(IF+I)-S5*A(IF+I) A11=(A2+A5)+(A1+A4) - A20=(A(IA+I)+A3)-0.5_JPRB*A11 + A20=(A(IA+I)+A3)-0.5_JPRC*A11 A21=SIN60*((A2+A5)-(A1+A4)) B11=(B2+B5)+(B1+B4) - B20=(B(IA+I)+B3)-0.5_JPRB*B11 + B20=(B(IA+I)+B3)-0.5_JPRC*B11 B21=SIN60*((B2+B5)-(B1+B4)) C(JA+J)=(A(IA+I)+A3)+A11 D(JA+J)=(B(IA+I)+B3)+B11 @@ -2123,10 +2125,10 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & C(JE+J)=A20+B21 D(JE+J)=A21-B20 A11=(A2-A5)+(A4-A1) - A20=(A(IA+I)-A3)-0.5_JPRB*A11 + A20=(A(IA+I)-A3)-0.5_JPRC*A11 A21=SIN60*((A4-A1)-(A2-A5)) B11=(B5-B2)-(B4-B1) - B20=(B3-B(IA+I))-0.5_JPRB*B11 + B20=(B3-B(IA+I))-0.5_JPRC*B11 B21=SIN60*((B5-B2)+(B4-B1)) C(JB+J)=A20-B21 D(JB+J)=A21-B20 @@ -2158,15 +2160,15 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !OCL NOVREC !DEC$ IVDEP DO 670 IJK=1,ILOT - C(JA+J)=(A(IA+I)+0.5_JPRB*(A(IC+I)-A(IE+I)))+ & + C(JA+J)=(A(IA+I)+0.5_JPRC*(A(IC+I)-A(IE+I)))+ & & SIN60*(A(IB+I)-A(IF+I)) - D(JA+J)=-(A(ID+I)+0.5_JPRB*(A(IB+I)+A(IF+I)))- & + D(JA+J)=-(A(ID+I)+0.5_JPRC*(A(IB+I)+A(IF+I)))- & & SIN60*(A(IC+I)+A(IE+I)) C(JB+J)=A(IA+I)-(A(IC+I)-A(IE+I)) D(JB+J)=A(ID+I)-(A(IB+I)+A(IF+I)) - C(JC+J)=(A(IA+I)+0.5_JPRB*(A(IC+I)-A(IE+I)))- & + C(JC+J)=(A(IA+I)+0.5_JPRC*(A(IC+I)-A(IE+I)))- & & SIN60*(A(IB+I)-A(IF+I)) - D(JC+J)=-(A(ID+I)+0.5_JPRB*(A(IB+I)+ & + D(JC+J)=-(A(ID+I)+0.5_JPRC*(A(IB+I)+ & & A(IF+I)))+SIN60*(A(IC+I)+A(IE+I)) I=I+INC3 J=J+INC4 @@ -2177,7 +2179,7 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & ENDIF ! ELSE !!! Case LA=M - Z=1.0_JPRB/REAL(N,KIND=JPRB) + Z=1.0_JPRC/REAL(N,KIND=JPRB) ZSIN60=Z*SIN60 IF (LIPL) THEN DO 694 L=1,ILA @@ -2186,12 +2188,12 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & !DEC$ IVDEP DO 692 IJK=1,ILOT A11=(A(IC+I)-A(IF+I))+(A(IE+I)-A(IB+I)) - T1=Z*((A(IA+I)-A(ID+I))-0.5_JPRB*A11) + T1=Z*((A(IA+I)-A(ID+I))-0.5_JPRC*A11) T5=Z*((A(IA+I)-A(ID+I))+A11) T2=ZSIN60*((A(IE+I)-A(IB+I))-(A(IC+I)-A(IF+I))) T4=ZSIN60*((A(IC+I)+A(IF+I))-(A(IB+I)+A(IE+I))) A11=(A(IC+I)+A(IF+I))+(A(IB+I)+A(IE+I)) - T3=Z*((A(IA+I)+A(ID+I))-0.5_JPRB*A11) + T3=Z*((A(IA+I)+A(ID+I))-0.5_JPRC*A11) A(IA+I)=Z*((A(IA+I)+A(ID+I))+A11) A(IB+I)=T1 A(IC+I)=T2 @@ -2211,10 +2213,10 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & DO 696 IJK=1,ILOT A11=(A(IC+I)+A(IF+I))+(A(IB+I)+A(IE+I)) C(JA+J)=Z*((A(IA+I)+A(ID+I))+A11) - C(JC+J)=Z*((A(IA+I)+A(ID+I))-0.5_JPRB*A11) + C(JC+J)=Z*((A(IA+I)+A(ID+I))-0.5_JPRC*A11) D(JC+J)=ZSIN60*((A(IC+I)+A(IF+I))-(A(IB+I)+A(IE+I))) A11=(A(IC+I)-A(IF+I))+(A(IE+I)-A(IB+I)) - C(JB+J)=Z*((A(IA+I)-A(ID+I))-0.5_JPRB*A11) + C(JB+J)=Z*((A(IA+I)-A(ID+I))-0.5_JPRC*A11) D(JB+J)=ZSIN60*((A(IE+I)-A(IB+I))-(A(IC+I)-A(IF+I))) C(JD+J)=Z*((A(IA+I)-A(ID+I))+A11) I=I+INC3 @@ -2247,8 +2249,8 @@ SUBROUTINE QPASSF(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC, & JC=JB+2*M*INC2 JD=JC+2*M*INC2 JE=JD+2*M*INC2 - Z=1.0_JPRB/REAL(N,KIND=JPRB) - ZSIN45=Z*SQRT(0.5_JPRB) + Z=1.0_JPRC/REAL(N,KIND=JPRB) + ZSIN45=Z*SQRT(0.5_JPRC) ! IF (LIPL) THEN DO 820 L=1,ILA diff --git a/src/trans/algor/seefmm_mix.F90 b/src/trans/algor/seefmm_mix.F90 index 97772358..544fec57 100644 --- a/src/trans/algor/seefmm_mix.F90 +++ b/src/trans/algor/seefmm_mix.F90 @@ -41,6 +41,7 @@ module seefmm_mix use parkind1,only : jpim ,jprb, jprd +use parkind1,only : jprc => jprb use ecsort_mix, only : keysort use wts500_mod, only: wts500 @@ -162,7 +163,7 @@ recursive subroutine potf(kn,kx,ldxout,kquad,prw,pq,prdexp,kindex,kclosel,kcik,p lxy(ik1) = (ik1 <= kx .eqv. ldxout) !------------------------------------------------------------------------- -ztheta(:)=0.0_JPRB +ztheta(:)=0.0_JPRC if(ldxout) then ix=0 iy=-kx @@ -177,7 +178,7 @@ recursive subroutine potf(kn,kx,ldxout,kquad,prw,pq,prdexp,kindex,kclosel,kcik,p if(llxy(j1)) then zq(j1)=pq(kindex(j1)+ix) else - zq(j1)=0.0_jprb + zq(j1)=0.0_jprc endif enddo @@ -294,7 +295,7 @@ recursive subroutine potfm(kn,km,kskip,kx,ldxout,kquad,prw,pq,prdexp,kindex,kclo !------------------------------------------------------------------------- !CALL GSTATS(209,0) -ptheta(:,:)=0.0_JPRB +ptheta(:,:)=0.0_JPRC if(ldxout) then ix=0 iy=-kx @@ -312,7 +313,7 @@ recursive subroutine potfm(kn,km,kskip,kx,ldxout,kquad,prw,pq,prdexp,kindex,kclo zalpha(:,jm)=pq(jm,kindex(1)+ix) enddo else - zalpha(:,:)=0.0_jprb + zalpha(:,:)=0.0_jprc endif !CALL GSTATS(209,1) !CALL GSTATS(210,0) @@ -535,11 +536,11 @@ recursive subroutine prepotf(kx,kxy,kquad,prw,prt,pr,pxy,kindex,prdexp,& kclosel(jxy)=kclosel(jxy)+1 if((i1 > kx .and. i1pd <= kx) .or. (i1pd > kx .and. i1 <= kx)) then knocik=knocik+1 - zsum=0.0_jprb + zsum=0.0_jprc do jq=1,kquad zsum=zsum+prw(jq)*exp(-zdx*prt(jq)) enddo - pcik(knocik)=1.0_jprb/zdx-zsum + pcik(knocik)=1.0_jprc/zdx-zsum endif else exit diff --git a/src/trans/algor/set99.F90 b/src/trans/algor/set99.F90 index b975971c..a6f282b6 100644 --- a/src/trans/algor/set99.F90 +++ b/src/trans/algor/set99.F90 @@ -12,6 +12,7 @@ SUBROUTINE SET99(TRIGS,IFAX,N) !AUTOPROMOTE USE PARKIND1, ONLY : JPIM, JPRB + USE PARKIND1, ONLY : JPRC => JPRB USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK ! IMPLICIT NONE @@ -34,7 +35,7 @@ SUBROUTINE SET99(TRIGS,IFAX,N) IF (LHOOK) CALL DR_HOOK('SET99',0,ZHOOK_HANDLE) IXXX=1 ! - DEL=4.0_JPRB * ASIN(1.0_JPRB)/REAL(N,KIND=JPRB) + DEL=4.0_JPRC * ASIN(1.0_JPRC)/REAL(N,KIND=JPRB) NIL=0 NHL=(N/2)-1 DO 10 K=NIL,NHL diff --git a/src/trans/algor/set99b.F90 b/src/trans/algor/set99b.F90 index bb83ab42..62831555 100644 --- a/src/trans/algor/set99b.F90 +++ b/src/trans/algor/set99b.F90 @@ -12,6 +12,7 @@ SUBROUTINE SET99B(TRIGS,IFAX,N,LDUSEFFT992) !AUTOPROMOTE USE PARKIND1, ONLY : JPIM, JPRB + USE PARKIND1, ONLY : JPRC => JPRB ! IMPLICIT NONE ! @@ -35,7 +36,7 @@ SUBROUTINE SET99B(TRIGS,IFAX,N,LDUSEFFT992) ! IXXX=1 ! - DEL=4.0_JPRB * ASIN(1.0_JPRB)/REAL(N,KIND=JPRB) + DEL=4.0_JPRC * ASIN(1.0_JPRC)/REAL(N,KIND=JPRB) NIL=0 NHL=(N/2)-1 DO 10 K=NIL,NHL diff --git a/src/trans/external/setup_trans0.F90 b/src/trans/external/setup_trans0.F90 index 6c764146..b5a171cc 100644 --- a/src/trans/external/setup_trans0.F90 +++ b/src/trans/external/setup_trans0.F90 @@ -71,6 +71,7 @@ SUBROUTINE SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1, ONLY : JPRC => JPRB !ifndef INTERFACE @@ -129,7 +130,7 @@ SUBROUTINE SETUP_TRANS0(KOUT,KERR,KPRINTLEV,KMAX_RESOL,KPROMATR,& LSYNC_TRANS=.FALSE. NTRANS_SYNC_LEVEL=0 LEQ_REGIONS=.FALSE. -RA=6371229._JPRB +RA=6371229._JPRC LALLOPERM=.FALSE. ! Optional arguments diff --git a/src/trans/include/ectrans/renames.inc b/src/trans/include/ectrans/renames.inc index f11b6b99..180624af 100644 --- a/src/trans/include/ectrans/renames.inc +++ b/src/trans/include/ectrans/renames.inc @@ -1,12 +1,12 @@ !#define PASTER(x,y) x ## _ ## y !#define EVALUATOR(x,y) PASTER(x,y) -#define PASTE2(x,y) x/**/y -#define EVALUATOR(x,y) PASTE2(PASTE2(x,_),y) -#define SUFFIXIZE(fun) EVALUATOR(fun,SYMBOLSUFFIX) -!#define __ATLAS_IO_SPLICE(a, b) __ATLAS_IO_SPLICE_1(a, b) -!#define __ATLAS_IO_SPLICE_1(a, b) __ATLAS_IO_SPLICE_2(a, b) -!#define __ATLAS_IO_SPLICE_2(a, b) a##b -!#define SUFFIXIZE(fun) __ATLAS_IO_SPLICE(fun,SYMBOLSUFFIX) +!#define PASTE2(x,y) x/**/y +!#define EVALUATOR(x,y) PASTE2(PASTE2(x,_),y) +!#define SUFFIXIZE(fun) EVALUATOR(fun,SYMBOLSUFFIX) +#define __ATLAS_IO_SPLICE(a, b) __ATLAS_IO_SPLICE_1(a, b) +#define __ATLAS_IO_SPLICE_1(a, b) __ATLAS_IO_SPLICE_2(a, b) +#define __ATLAS_IO_SPLICE_2(a, b) a##b +#define SUFFIXIZE(fun) __ATLAS_IO_SPLICE(fun,SYMBOLSUFFIX) #define ABORT_TRANS_MOD SUFFIXIZE(ABORT_TRANS_MOD) #define ASRE1AD_MOD SUFFIXIZE(ASRE1AD_MOD) #define ASRE1BAD_MOD SUFFIXIZE(ASRE1BAD_MOD) @@ -162,14 +162,14 @@ !#warning defining jprb as sp(SYMBOLSUFFIX) #define JPRB JPRM #define jprb jprm -#define _JPRB _JPRM -#define _jprb _jprm +!#define _JPRB _JPRM +!#define _jprb _jprm #elif PRECOPT == 2 !#warning defining jprb as dp #define JPRB JPRD #define jprb jprd -#define _JPRB _JPRD -#define _jprb _jprd +!#define _JPRB _JPRD +!#define _jprb _jprd #else #endif diff --git a/src/trans/internal/dist_spec_control_mod.F90 b/src/trans/internal/dist_spec_control_mod.F90 index 800e848d..57d8eda4 100644 --- a/src/trans/internal/dist_spec_control_mod.F90 +++ b/src/trans/internal/dist_spec_control_mod.F90 @@ -59,6 +59,7 @@ SUBROUTINE DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,KVSET,PSPEC,LDIM1_IS_FLD,& ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1 ,ONLY : JPRC => JPRB USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_WAIT, MPL_WAITANY, JP_NON_BLOCKING_STANDARD USE TPM_DISTR ,ONLY : MTAGDISTSP, MYSETV, MYSETW, NPRCIDS, NPRTRW, MYPROC, NPROC, NPRTRV, D USE SET2PE_MOD ,ONLY : SET2PE @@ -164,7 +165,7 @@ SUBROUTINE DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,KVSET,PSPEC,LDIM1_IS_FLD,& ! The next lines ensure the large array zbuf is allocated right here and not inside an omp loop below, ! where an extra omp synchro might be needed : IF (SIZE(ZBUF) > 0) THEN - ZBUF(LBOUND(ZBUF,DIM=1),LBOUND(ZBUF,DIM=2),LBOUND(ZBUF,DIM=3))=HUGE(1._JPRB) + ZBUF(LBOUND(ZBUF,DIM=1),LBOUND(ZBUF,DIM=2),LBOUND(ZBUF,DIM=3))=HUGE(1._JPRC) ENDIF IF (LDIM1_IS_FLD) THEN diff --git a/src/trans/internal/eq_regions_mod.F90 b/src/trans/internal/eq_regions_mod.F90 index 913065ef..8e5db0ab 100644 --- a/src/trans/internal/eq_regions_mod.F90 +++ b/src/trans/internal/eq_regions_mod.F90 @@ -72,6 +72,8 @@ MODULE eq_regions_mod !-------------------------------------------------------------------------------- ! USE PARKIND1 ,ONLY : JPIM, JPRB +USE PARKIND1 ,ONLY : JPRC => JPRB + IMPLICIT NONE @@ -152,7 +154,7 @@ subroutine eq_regions(N) real(kind=jprb),allocatable :: r_regions(:) real(kind=jprb) :: c_polar -pi=2.0_jprb*asin(1.0_jprb) +pi=2.0_jprc*asin(1.0_jprc) n_regions(:)=0 @@ -260,14 +262,14 @@ subroutine ideal_region_list(N,c_polar,n_collars,r_regions) integer(kind=jpim) :: collar_n real(kind=jprb) :: ideal_region_area,ideal_collar_area real(kind=jprb) :: a_fitting -r_regions(:)=0.0_jprb -r_regions(1) = 1.0_jprb +r_regions(:)=0.0_jprc +r_regions(1) = 1.0_jprc if( n_collars > 0 )then ! ! Based on n_collars and c_polar, determine a_fitting, ! the collar angle such that n_collars collars fit between the polar caps. ! - a_fitting = (pi-2.0_jprb*c_polar)/float(n_collars) + a_fitting = (pi-2.0_jprc*c_polar)/float(n_collars) ideal_region_area = area_of_ideal_region(N) do collar_n=1,n_collars ideal_collar_area = area_of_collar(c_polar+(collar_n-1)*a_fitting, & @@ -290,7 +292,7 @@ function ideal_collar_angle(N) result(ideal) IMPLICIT NONE integer(kind=jpim),intent(in) :: N real(kind=jprb) :: ideal -ideal = area_of_ideal_region(N)**(0.5_jprb) +ideal = area_of_ideal_region(N)**(0.5_jprc) return end function ideal_collar_angle @@ -313,7 +315,7 @@ subroutine round_to_naturals(N,n_collars,r_regions) integer(kind=jpim) :: zone_n real(kind=jprb) :: discrepancy n_regions(1:n_collars+2) = r_regions(:) -discrepancy = 0.0_jprb +discrepancy = 0.0_jprc do zone_n = 1,n_collars+2 n_regions(zone_n) = nint(r_regions(zone_n)+discrepancy); discrepancy = discrepancy+r_regions(zone_n)-float(n_regions(zone_n)); @@ -331,7 +333,7 @@ function polar_colat(N) result(polar_c) real(kind=jprb) :: area real(kind=jprb) :: polar_c if( N == 1 ) polar_c=pi -if( N == 2 ) polar_c=pi/2.0_jprb +if( N == 2 ) polar_c=pi/2.0_jprc if( N > 2 )then area=area_of_ideal_region(N) polar_c=sradius_of_cap(area) @@ -349,7 +351,7 @@ function area_of_ideal_region(N) result(area) integer(kind=jpim),intent(in) :: N real(kind=jprb) :: area_of_sphere real(kind=jprb) :: area -area_of_sphere = (2.0_jprb*pi**1.5_jprb/gamma(1.5_jprb)) +area_of_sphere = (2.0_jprc*pi**1.5_jprc/gamma(1.5_jprc)) area = area_of_sphere/float(N) return end function area_of_ideal_region @@ -363,7 +365,7 @@ function sradius_of_cap(area) result(sradius) IMPLICIT NONE real(kind=jprb),intent(in) :: area real(kind=jprb) :: sradius -sradius = 2.0_jprb*asin(sqrt(area/pi)/2.0_jprb) +sradius = 2.0_jprc*asin(sqrt(area/pi)/2.0_jprc) return end function sradius_of_cap @@ -392,7 +394,7 @@ function area_of_cap(s_cap) result(area) ! real(kind=jprb),intent(in) :: s_cap real(kind=jprb) area -area = 4.0_jprb*pi * sin(s_cap/2.0_jprb)**2 +area = 4.0_jprc*pi * sin(s_cap/2.0_jprc)**2 return end function area_of_cap @@ -406,21 +408,21 @@ function gamma(x) result(gamma_res) real(kind=jprb) :: w,y integer(kind=jpim) :: k,n parameter (& -& p0 = 0.999999999999999990e+00_jprb,& -& p1 = -0.422784335098466784e+00_jprb,& -& p2 = -0.233093736421782878e+00_jprb,& -& p3 = 0.191091101387638410e+00_jprb,& -& p4 = -0.024552490005641278e+00_jprb,& -& p5 = -0.017645244547851414e+00_jprb,& -& p6 = 0.008023273027855346e+00_jprb) +& p0 = 0.999999999999999990e+00_jprc,& +& p1 = -0.422784335098466784e+00_jprc,& +& p2 = -0.233093736421782878e+00_jprc,& +& p3 = 0.191091101387638410e+00_jprc,& +& p4 = -0.024552490005641278e+00_jprc,& +& p5 = -0.017645244547851414e+00_jprc,& +& p6 = 0.008023273027855346e+00_jprc) parameter (& -& p7 = -0.000804329819255744e+00_jprb,& -& p8 = -0.000360837876648255e+00_jprb,& -& p9 = 0.000145596568617526e+00_jprb,& -& p10 = -0.000017545539395205e+00_jprb,& -& p11 = -0.000002591225267689e+00_jprb,& -& p12 = 0.000001337767384067e+00_jprb,& -& p13 = -0.000000199542863674e+00_jprb) +& p7 = -0.000804329819255744e+00_jprc,& +& p8 = -0.000360837876648255e+00_jprc,& +& p9 = 0.000145596568617526e+00_jprc,& +& p10 = -0.000017545539395205e+00_jprc,& +& p11 = -0.000002591225267689e+00_jprc,& +& p12 = 0.000001337767384067e+00_jprc,& +& p13 = -0.000000199542863674e+00_jprc) n = nint(x - 2) w = x - (n + 2) y = ((((((((((((p13 * w + p12) * w + p11) * w + p10) *& diff --git a/src/trans/internal/ftdir_mod.F90 b/src/trans/internal/ftdir_mod.F90 index 4f3dcb3d..277930b7 100644 --- a/src/trans/internal/ftdir_mod.F90 +++ b/src/trans/internal/ftdir_mod.F90 @@ -48,6 +48,7 @@ SUBROUTINE FTDIR(PREEL,KFIELDS,KGL) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPIB, JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_GEOMETRY ,ONLY : G @@ -115,7 +116,7 @@ SUBROUTINE FTDIR(PREEL,KFIELDS,KGL) IF (G%NLOEN(IGLG)==1) IST1=0 DO JJ=IST1,ILEN DO JF=1,KFIELDS - PREEL(JF,IST+D%NSTAGTF(KGL)+JJ-1) = 0.0_JPRB + PREEL(JF,IST+D%NSTAGTF(KGL)+JJ-1) = 0.0_JPRC ENDDO ENDDO diff --git a/src/trans/internal/ftdirad_mod.F90 b/src/trans/internal/ftdirad_mod.F90 index 2ffc02a4..cacab943 100644 --- a/src/trans/internal/ftdirad_mod.F90 +++ b/src/trans/internal/ftdirad_mod.F90 @@ -47,6 +47,7 @@ SUBROUTINE FTDIRAD(PREEL,KFIELDS,KGL) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_GEOMETRY ,ONLY : G @@ -80,7 +81,7 @@ SUBROUTINE FTDIRAD(PREEL,KFIELDS,KGL) DO JJ=1,ILEN DO JF=1,KFIELDS - PREEL(JF,IST+IOFF-1+JJ-1) = 0.0_JPRB + PREEL(JF,IST+IOFF-1+JJ-1) = 0.0_JPRC ENDDO ENDDO @@ -109,7 +110,7 @@ SUBROUTINE FTDIRAD(PREEL,KFIELDS,KGL) ! Change of metric (not in forward routine) -ZMUL = 1.0_JPRB/ILOEN +ZMUL = 1.0_JPRC/ILOEN DO JJ=1,ILOEN DO JF=1,KFIELDS PREEL(JF,IOFF-1+JJ) = PREEL(JF,IOFF-1+JJ)*ZMUL diff --git a/src/trans/internal/ftinv_mod.F90 b/src/trans/internal/ftinv_mod.F90 index 9d1e7c67..1f44c193 100644 --- a/src/trans/internal/ftinv_mod.F90 +++ b/src/trans/internal/ftinv_mod.F90 @@ -46,6 +46,7 @@ SUBROUTINE FTINV(PREEL,KFIELDS,KGL) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_GEOMETRY ,ONLY : G @@ -77,7 +78,7 @@ SUBROUTINE FTINV(PREEL,KFIELDS,KGL) DO JJ=IST1,ILEN DO JF=1,KFIELDS - PREEL(JF,IST+D%NSTAGTF(KGL)+JJ-1) = 0.0_JPRB + PREEL(JF,IST+D%NSTAGTF(KGL)+JJ-1) = 0.0_JPRC ENDDO ENDDO diff --git a/src/trans/internal/ftinvad_mod.F90 b/src/trans/internal/ftinvad_mod.F90 index 6c238104..1d0edf0f 100644 --- a/src/trans/internal/ftinvad_mod.F90 +++ b/src/trans/internal/ftinvad_mod.F90 @@ -47,6 +47,7 @@ SUBROUTINE FTINVAD(PREEL,KFIELDS,KGL) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM, JPIB, JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_DISTR ,ONLY : D, MYSETW USE TPM_DIM ,ONLY : R @@ -117,7 +118,7 @@ SUBROUTINE FTINVAD(PREEL,KFIELDS,KGL) DO JJ=1,ILEN DO JF=1,KFIELDS - PREEL(JF,IST+IOFF-1+JJ-1) = 0.0_JPRB + PREEL(JF,IST+IOFF-1+JJ-1) = 0.0_JPRC ENDDO ENDDO diff --git a/src/trans/internal/gath_spec_control_mod.F90 b/src/trans/internal/gath_spec_control_mod.F90 index a97a1281..13adeab5 100644 --- a/src/trans/internal/gath_spec_control_mod.F90 +++ b/src/trans/internal/gath_spec_control_mod.F90 @@ -37,6 +37,7 @@ SUBROUTINE GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,KVSET,PSPEC,LDIM1_IS_FLD,& USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE MPL_MODULE ,ONLY : MPL_RECV, MPL_SEND, MPL_BARRIER, MPL_WAIT, & & JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD @@ -199,7 +200,7 @@ SUBROUTINE GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,KVSET,PSPEC,LDIM1_IS_FLD,& DO JN=0,KSMAX ISP = KDIM0G(0)+JN*2+1 II = II+2 - PSPECG(JFLD,II) = 0.0_JPRB + PSPECG(JFLD,II) = 0.0_JPRC ENDDO ENDIF ELSE @@ -211,7 +212,7 @@ SUBROUTINE GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,KVSET,PSPEC,LDIM1_IS_FLD,& DO JN=0,KSMAX ISP = KDIM0G(0)+JN*2+1 II = II+2 - PSPECG(II,JFLD) = 0.0_JPRB + PSPECG(II,JFLD) = 0.0_JPRC ENDDO ENDIF ENDIF diff --git a/src/trans/internal/gpnorm_trans_ctl_mod.F90 b/src/trans/internal/gpnorm_trans_ctl_mod.F90 index cfface86..68b4b403 100644 --- a/src/trans/internal/gpnorm_trans_ctl_mod.F90 +++ b/src/trans/internal/gpnorm_trans_ctl_mod.F90 @@ -52,6 +52,7 @@ SUBROUTINE GPNORM_TRANS_CTL(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,PW) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD +USE PARKIND1, ONLY : JPRC => JPRB !ifndef INTERFACE @@ -172,7 +173,7 @@ SUBROUTINE GPNORM_TRANS_CTL(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,PW) IF( IF_FS > 0 )THEN - ZAVE(:,:)=0.0_JPRB + ZAVE(:,:)=0.0_JPRC IF(.NOT.LDAVE_ONLY)THEN DO JF=1,IF_FS @@ -227,7 +228,7 @@ SUBROUTINE GPNORM_TRANS_CTL(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,PW) ALLOCATE(ZMING(KFIELDS)) ALLOCATE(ZMAXG(KFIELDS)) -ZAVEG(:,:)=0.0_JPRB +ZAVEG(:,:)=0.0_JPRC DO JF=1,IF_FS DO JGL=IBEG,IEND @@ -426,7 +427,7 @@ SUBROUTINE GPNORM_TRANS_CTL(PGP,KFIELDS,KPROMA,PAVE,PMIN,PMAX,LDAVE_ONLY,PW) IF( MYSETW == 1 .AND. MYSETV == 1 )THEN - PAVE(:)=0.0_JPRB + PAVE(:)=0.0_JPRC DO JGL=1,R%NDGL PAVE(:)=PAVE(:)+ZAVEG(JGL,:) ENDDO diff --git a/src/trans/internal/ltdirad_mod.F90 b/src/trans/internal/ltdirad_mod.F90 index 34034188..be185699 100644 --- a/src/trans/internal/ltdirad_mod.F90 +++ b/src/trans/internal/ltdirad_mod.F90 @@ -18,6 +18,7 @@ SUBROUTINE LTDIRAD(KM,KMLOC,KF_FS,KF_UV,KF_SCALARS,KLED2,& USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_DIM ,ONLY : R USE TPM_GEOMETRY @@ -150,7 +151,7 @@ SUBROUTINE LTDIRAD(KM,KMLOC,KF_FS,KF_UV,KF_SCALARS,KLED2,& IDIVS = 2*KF_UV+1 IDIVE = 4*KF_UV ! SET PART OF ZOA1 CONTAINING U AND V TO 0. - ZOA1(:,IUS:IVE) = 0.0_JPRB + ZOA1(:,IUS:IVE) = 0.0_JPRC CALL UVTVDAD(KM,KF_UV,ZEPSNM,ZOA1(:,IUS:IUE),ZOA1(:,IVS:IVE),& & ZOA2(:,IVORS:IVORE),ZOA2(:,IDIVS:IDIVE)) ENDIF diff --git a/src/trans/internal/ltinvad_mod.F90 b/src/trans/internal/ltinvad_mod.F90 index 88c5ad01..f2a03531 100644 --- a/src/trans/internal/ltinvad_mod.F90 +++ b/src/trans/internal/ltinvad_mod.F90 @@ -17,6 +17,7 @@ SUBROUTINE LTINVAD(KM,KMLOC,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,KLEI2,KDIM1,& & KFLDPTRUV,KFLDPTRSC,FSPGL_PROC) USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : LDIVGP, LVORGP, NF_SC2, NF_SC3A, NF_SC3B @@ -154,7 +155,7 @@ SUBROUTINE LTINVAD(KM,KMLOC,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,KLEI2,KDIM1,& ISTA = ISTA+2*KF_UV ENDIF -ZIA(:,ISTA:ISTA+IFC-1) = 0.0_JPRB +ZIA(:,ISTA:ISTA+IFC-1) = 0.0_JPRC IDGLU = MIN(R%NDGNH,G%NDGLU(KM)) IIFC=IFC @@ -168,7 +169,7 @@ SUBROUTINE LTINVAD(KM,KMLOC,KF_OUT_LT,KF_UV,KF_SCALARS,KF_SCDERS,KLEI2,KDIM1,& !* 3. SPECTRAL COMPUTATIONS FOR U,V AND DERIVATIVES. ! ---------------------------------------------- -ZIA(:,1:ISTA-1) = 0.0_JPRB +ZIA(:,1:ISTA-1) = 0.0_JPRC IFIRST = 1 ILAST = 4*KF_UV diff --git a/src/trans/internal/prepsnm_mod.F90 b/src/trans/internal/prepsnm_mod.F90 index f97a6255..fd9febb3 100644 --- a/src/trans/internal/prepsnm_mod.F90 +++ b/src/trans/internal/prepsnm_mod.F90 @@ -52,6 +52,7 @@ SUBROUTINE PREPSNM(KM,KMLOC,PEPSNM) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_DIM ,ONLY : R USE TPM_FIELDS ,ONLY : F @@ -73,7 +74,7 @@ SUBROUTINE PREPSNM(KM,KMLOC,PEPSNM) IF (KM > 0) THEN - PEPSNM(0:KM-1) = 0.0_JPRB + PEPSNM(0:KM-1) = 0.0_JPRC ENDIF DO JN=KM,R%NTMAX+2 diff --git a/src/trans/internal/prfi1b_mod.F90 b/src/trans/internal/prfi1b_mod.F90 index fc1c8d50..d6166715 100644 --- a/src/trans/internal/prfi1b_mod.F90 +++ b/src/trans/internal/prfi1b_mod.F90 @@ -14,6 +14,7 @@ MODULE PRFI1B_MOD SUBROUTINE PRFI1B(KM,PIA,PSPEC,KFIELDS,KFLDPTR) USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1 ,ONLY : JPRC => JPRB USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D @@ -110,9 +111,9 @@ SUBROUTINE PRFI1B(KM,PIA,PSPEC,KFIELDS,KFLDPTR) ENDIF DO JFLD=1,2*KFIELDS - PIA(1,JFLD) = 0.0_JPRB - PIA(2,JFLD) = 0.0_JPRB - PIA(ILCM+3,JFLD) = 0.0_JPRB + PIA(1,JFLD) = 0.0_JPRC + PIA(2,JFLD) = 0.0_JPRC + PIA(ILCM+3,JFLD) = 0.0_JPRC ENDDO diff --git a/src/trans/internal/spnorm_ctl_mod.F90 b/src/trans/internal/spnorm_ctl_mod.F90 index caf75a11..a1c91ab7 100644 --- a/src/trans/internal/spnorm_ctl_mod.F90 +++ b/src/trans/internal/spnorm_ctl_mod.F90 @@ -14,6 +14,7 @@ MODULE SPNORM_CTL_MOD SUBROUTINE SPNORM_CTL(PSPEC,KFLD,KFLD_G,KVSET,KMASTER,PMET,PNORM) USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D, MYPROC, MYSETV @@ -46,7 +47,7 @@ SUBROUTINE SPNORM_CTL(PSPEC,KFLD,KFLD_G,KVSET,KMASTER,PMET,PNORM) IF(PRESENT(PMET)) THEN ZMET(:) = PMET(:) ELSE - ZMET(:) = 1.0_JPRB + ZMET(:) = 1.0_JPRC ENDIF CALL SPNORMD(PSPEC,KFLD,ZMET,ZSM) diff --git a/src/trans/internal/spnormd_mod.F90 b/src/trans/internal/spnormd_mod.F90 index 878f6179..46ca2d67 100644 --- a/src/trans/internal/spnormd_mod.F90 +++ b/src/trans/internal/spnormd_mod.F90 @@ -14,6 +14,7 @@ MODULE SPNORMD_MOD SUBROUTINE SPNORMD(PSPEC,KFLD,PMET,PSM) USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_DIM ,ONLY : R USE TPM_DISTR ,ONLY : D @@ -34,7 +35,7 @@ SUBROUTINE SPNORMD(PSPEC,KFLD,PMET,PSM) CALL GSTATS(1651,0) !$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JM,IM,JN,ISP,JFLD) DO JM=1,D%NUMP - PSM(:,JM) = 0.0_JPRB + PSM(:,JM) = 0.0_JPRC IM = D%MYMS(JM) IF(IM == 0)THEN DO JN=0,R%NSMAX @@ -47,7 +48,7 @@ SUBROUTINE SPNORMD(PSPEC,KFLD,PMET,PSM) DO JN=IM,R%NSMAX ISP = D%NASM0(IM)+(JN-IM)*2 DO JFLD=1,KFLD - PSM(JFLD,JM) = PSM(JFLD,JM)+2.0_JPRB*PMET(JN)*& + PSM(JFLD,JM) = PSM(JFLD,JM)+2.0_JPRC*PMET(JN)*& &(PSPEC(JFLD,ISP)**2+PSPEC(JFLD,ISP+1)**2) ENDDO ENDDO diff --git a/src/trans/internal/sustaonl_mod.F90 b/src/trans/internal/sustaonl_mod.F90 index ca1b5352..49dd693e 100644 --- a/src/trans/internal/sustaonl_mod.F90 +++ b/src/trans/internal/sustaonl_mod.F90 @@ -66,6 +66,7 @@ SUBROUTINE SUSTAONL(KMEDIAP,KRESTM,LDWEIGHTED_DISTR,PWEIGHT,PMEDIAP,KPROCAGP) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB, JPRD +USE PARKIND1, ONLY : JPRC => JPRB USE MPL_MODULE ,ONLY : MPL_ALLGATHERV, MPL_RECV, MPL_SEND USE TPM_GEN ,ONLY : NOUT, NPRINTLEV @@ -114,7 +115,7 @@ SUBROUTINE SUSTAONL(KMEDIAP,KRESTM,LDWEIGHTED_DISTR,PWEIGHT,PMEDIAP,KPROCAGP) ! ----------------------------------------------------------------- -ZPI = 2.0_JPRB*ASIN(1.0_JPRB) +ZPI = 2.0_JPRC*ASIN(1.0_JPRC) IXPTLAT (:)=999999 ILSTPTLAT(:)=999999 @@ -178,7 +179,7 @@ SUBROUTINE SUSTAONL(KMEDIAP,KRESTM,LDWEIGHTED_DISTR,PWEIGHT,PMEDIAP,KPROCAGP) ! --------------------------------------- IF( NPROC > 1 )THEN DO JGL=1,ILEN - ZDIVID(JGL) = 360000.0_JPRB/REAL(G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1),JPRB) + ZDIVID(JGL) = 360000.0_JPRC/REAL(G%NLOEN(D%NFRSTLAT(MY_REGION_NS)+JGL-1),JPRB) ENDDO IF( LDWEIGHTED_DISTR )THEN ALLOCATE(ZWEIGHT(G%NLOEN(R%NDGL/2),R%NDGL)) diff --git a/src/trans/internal/updsp_mod.F90 b/src/trans/internal/updsp_mod.F90 index b50412d1..c2e708ec 100644 --- a/src/trans/internal/updsp_mod.F90 +++ b/src/trans/internal/updsp_mod.F90 @@ -65,6 +65,7 @@ SUBROUTINE UPDSP(KM,KF_UV,KF_SCALARS,POA1,POA2, & ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_TRANS ,ONLY : NF_SC2, NF_SC3A, NF_SC3B USE TPM_DISTR ,ONLY : D @@ -115,13 +116,13 @@ SUBROUTINE UPDSP(KM,KF_UV,KF_SCALARS,POA1,POA2, & IF(PRESENT(KFLDPTRUV)) THEN DO JFLD=1,KF_UV IFLD = KFLDPTRUV(JFLD) - PSPVOR(IFLD,D%NASM0(0)) = 0.0_JPRB - PSPDIV(IFLD,D%NASM0(0)) = 0.0_JPRB + PSPVOR(IFLD,D%NASM0(0)) = 0.0_JPRC + PSPDIV(IFLD,D%NASM0(0)) = 0.0_JPRC ENDDO ELSE DO JFLD=1,KF_UV - PSPVOR(JFLD,D%NASM0(0)) = 0.0_JPRB - PSPDIV(JFLD,D%NASM0(0)) = 0.0_JPRB + PSPVOR(JFLD,D%NASM0(0)) = 0.0_JPRC + PSPDIV(JFLD,D%NASM0(0)) = 0.0_JPRC ENDDO ENDIF ENDIF diff --git a/src/trans/internal/updspad_mod.F90 b/src/trans/internal/updspad_mod.F90 index 887d3940..90550047 100644 --- a/src/trans/internal/updspad_mod.F90 +++ b/src/trans/internal/updspad_mod.F90 @@ -65,6 +65,7 @@ SUBROUTINE UPDSPAD(KM,KF_UV,KF_SCALARS,POA1,POA2, & ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_DIM ,ONLY : R USE TPM_TRANS ,ONLY : NF_SC2, NF_SC3A, NF_SC3B @@ -114,24 +115,24 @@ SUBROUTINE UPDSPAD(KM,KF_UV,KF_SCALARS,POA1,POA2, & IF(PRESENT(KFLDPTRUV)) THEN DO JFLD=1,KF_UV IFLD = KFLDPTRUV(JFLD) - PSPVOR(IFLD,D%NASM0(0)) = 0.0_JPRB - PSPDIV(IFLD,D%NASM0(0)) = 0.0_JPRB + PSPVOR(IFLD,D%NASM0(0)) = 0.0_JPRC + PSPDIV(IFLD,D%NASM0(0)) = 0.0_JPRC ENDDO DO JN=0,R%NSMAX ISE = 1+JN*2+1 DO JFLD=1,KF_UV IFLD = KFLDPTRUV(JFLD) - PSPDIV(IFLD,ISE) = 0.0_JPRB - PSPVOR(IFLD,ISE) = 0.0_JPRB + PSPDIV(IFLD,ISE) = 0.0_JPRC + PSPVOR(IFLD,ISE) = 0.0_JPRC ENDDO ENDDO ELSE - PSPVOR(:,D%NASM0(0)) = 0.0_JPRB - PSPDIV(:,D%NASM0(0)) = 0.0_JPRB + PSPVOR(:,D%NASM0(0)) = 0.0_JPRC + PSPDIV(:,D%NASM0(0)) = 0.0_JPRC DO JN=0,R%NSMAX ISE = 1+JN*2+1 - PSPDIV(:,ISE) = 0.0_JPRB - PSPVOR(:,ISE) = 0.0_JPRB + PSPDIV(:,ISE) = 0.0_JPRC + PSPVOR(:,ISE) = 0.0_JPRC ENDDO ENDIF ENDIF diff --git a/src/trans/internal/updspb_mod.F90 b/src/trans/internal/updspb_mod.F90 index 01354715..7445e5c6 100644 --- a/src/trans/internal/updspb_mod.F90 +++ b/src/trans/internal/updspb_mod.F90 @@ -57,6 +57,7 @@ SUBROUTINE UPDSPB(KM,KFIELD,POA,PSPEC,KFLDPTR) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_DIM ,ONLY : R !USE TPM_FIELDS @@ -105,7 +106,7 @@ SUBROUTINE UPDSPB(KM,KFIELD,POA,PSPEC,KFLDPTR) DO JN=ITMAX+2-ISMAX,ITMAX+2-KM INM = IASM0+(ITMAX+2-JN)*2 PSPEC(IFLD,INM) = POA(JN,IR) - PSPEC(IFLD,INM+1) = 0.0_JPRB + PSPEC(IFLD,INM+1) = 0.0_JPRC ENDDO ENDDO ELSE @@ -116,7 +117,7 @@ SUBROUTINE UPDSPB(KM,KFIELD,POA,PSPEC,KFLDPTR) DO JFLD=1,KFIELD IR = 2*JFLD-1 PSPEC(JFLD,INM) = POA(JN,IR) - PSPEC(JFLD,INM+1) = 0.0_JPRB + PSPEC(JFLD,INM+1) = 0.0_JPRC ENDDO ENDDO ENDIF diff --git a/src/trans/internal/updspbad_mod.F90 b/src/trans/internal/updspbad_mod.F90 index ccfe57a9..bd341d6f 100644 --- a/src/trans/internal/updspbad_mod.F90 +++ b/src/trans/internal/updspbad_mod.F90 @@ -57,6 +57,7 @@ SUBROUTINE UPDSPBAD(KM,KFIELD,POA,PSPEC,KFLDPTR) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_DIM ,ONLY : R !USE TPM_FIELDS @@ -95,7 +96,7 @@ SUBROUTINE UPDSPBAD(KM,KFIELD,POA,PSPEC,KFLDPTR) IASM0 = D%NASM0(KM) -POA(:,:) = 0.0_JPRB +POA(:,:) = 0.0_JPRC !* 1.1 KM=0 @@ -107,7 +108,7 @@ SUBROUTINE UPDSPBAD(KM,KFIELD,POA,PSPEC,KFLDPTR) DO JN=ITMAX+2-ISMAX,ITMAX+2-KM INM = IASM0+(ITMAX+2-JN)*2 POA(JN,IR) = PSPEC(IFLD,INM) - PSPEC(IFLD,INM) = 0.0_JPRB + PSPEC(IFLD,INM) = 0.0_JPRC ENDDO ENDDO ELSE @@ -118,7 +119,7 @@ SUBROUTINE UPDSPBAD(KM,KFIELD,POA,PSPEC,KFLDPTR) DO JFLD=1,KFIELD IR = 2*JFLD-1 POA(JN,IR) = PSPEC(JFLD,INM) - PSPEC(JFLD,INM) = 0.0_JPRB + PSPEC(JFLD,INM) = 0.0_JPRC ENDDO ENDDO ENDIF @@ -134,8 +135,8 @@ SUBROUTINE UPDSPBAD(KM,KFIELD,POA,PSPEC,KFLDPTR) INM = IASM0+((ITMAX+2-JN)-KM)*2 POA(JN,IR) = PSPEC(IFLD,INM) POA(JN,II) = PSPEC(IFLD,INM+1) - PSPEC(IFLD,INM) = 0.0_JPRB - PSPEC(IFLD,INM+1) = 0.0_JPRB + PSPEC(IFLD,INM) = 0.0_JPRC + PSPEC(IFLD,INM+1) = 0.0_JPRC ENDDO ENDDO ELSE @@ -148,8 +149,8 @@ SUBROUTINE UPDSPBAD(KM,KFIELD,POA,PSPEC,KFLDPTR) II = IR+1 POA(JN,IR) = PSPEC(JFLD,INM) POA(JN,II) = PSPEC(JFLD,INM+1) - PSPEC(JFLD,INM) = 0.0_JPRB - PSPEC(JFLD,INM+1) = 0.0_JPRB + PSPEC(JFLD,INM) = 0.0_JPRC + PSPEC(JFLD,INM+1) = 0.0_JPRC ENDDO ENDDO ENDIF diff --git a/src/trans/internal/uvtvd_mod.F90 b/src/trans/internal/uvtvd_mod.F90 index c9a7933c..efb3491a 100644 --- a/src/trans/internal/uvtvd_mod.F90 +++ b/src/trans/internal/uvtvd_mod.F90 @@ -59,6 +59,7 @@ SUBROUTINE UVTVD(KM,KFIELD,PEPSNM,PU,PV,PVOR,PDIV) ! ------------------------------------------------------------------ USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE TPM_DIM ,ONLY : R USE TPM_FIELDS ,ONLY : F @@ -96,8 +97,8 @@ SUBROUTINE UVTVD(KM,KFIELD,PEPSNM,PU,PV,PVOR,PDIV) IN = F%NLTN(KM-1) DO J=1,2*KFIELD - PU(IN,J) = 0.0_JPRB - PV(IN,J) = 0.0_JPRB + PU(IN,J) = 0.0_JPRC + PV(IN,J) = 0.0_JPRC ENDDO !* 1.2 COMPUTE VORTICITY AND DIVERGENCE. diff --git a/src/trans/internal/vd2uv_mod.F90 b/src/trans/internal/vd2uv_mod.F90 index 342d9228..a85ec42d 100644 --- a/src/trans/internal/vd2uv_mod.F90 +++ b/src/trans/internal/vd2uv_mod.F90 @@ -14,6 +14,7 @@ MODULE VD2UV_MOD SUBROUTINE VD2UV(KM,KMLOC,KF_UV,KLEI2,PSPVOR,PSPDIV,PU,PV) USE PARKIND1 ,ONLY : JPIM ,JPRB +USE PARKIND1, ONLY : JPRC => JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK USE TPM_CONSTANTS @@ -131,7 +132,7 @@ SUBROUTINE VD2UV(KM,KMLOC,KF_UV,KLEI2,PSPVOR,PSPDIV,PU,PV) & ZIA(:,IUL:IUU),ZIA(:,IVL:IVU)) ILCM = R%NSMAX+1-KM IOFF = D%NASM0(KM) - ZA_R = 1.0_JPRB/RA + ZA_R = 1.0_JPRC/RA DO J=1,ILCM INM = IOFF+(ILCM-J)*2 DO JFLD=1,KF_UV