diff --git a/CMakeLists.txt b/CMakeLists.txt index 1b1888d3..76a38335 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -67,7 +67,7 @@ elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") set(fortran_d_flags "-fdefault-real-8") set(fortran_8_flags "-fdefault-integer-8 -fdefault-real-8") if(${CMAKE_Fortran_COMPILER_VERSION} VERSION_GREATER_EQUAL 10) - set(CMAKE_Fortran_FLAGS "-w -fallow-argument-mismatch -fallow-invalid-boz ${CMAKE_Fortran_FLAGS}") + set(CMAKE_Fortran_FLAGS "-w ${CMAKE_Fortran_FLAGS}") endif() endif() diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index a3b0fff9..1a97fa6c 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -14,35 +14,22 @@ ip_mercator_grid_mod.F90 ip_polar_stereo_grid_mod.F90 ip_rot_equid_cylind_egrid_mod.F90 ip_rot_equid_cylind_grid_mod.F90 ip_constants_mod.F90 ip_grids_mod.F90 ip_grid_factory_mod.F90 ip_interpolators_mod.F90 earth_radius_mod.F90 polfix_mod.F90 -fftpack.F ncpus.F spanaly.f spdz2uv.f speps.f spfft1.f spffte.f -spfftpt.f splaplac.f splat.F splegend.f sppad.f spsynth.f sptezd.f sptez.f -sptezmd.f sptezm.f sptezmv.f sptezv.f sptgpm.f sptgpmv.f sptgps.f sptgpsv.f -sptgpt.f sptgptv.f sptrand.f sptran.f sptranf0.f sptranf1.f sptranf.f sptranfv.f -sptranv.f sptrun.f sptrung.f sptrungv.f sptrunm.f sptrunmv.f sptruns.f -sptrunsv.f sptrunv.f spuv2dz.f spwget.f) - -if(BUILD_DEPRECATED) - set(fortran_src ${fortran_src} spfft.f spgradq.f spgradx.f spgrady.f sptgpmd.f - sptgpsd.f sptgptd.f sptgptsd.f sptgptvd.f sptrund.f sptrunl.f spvar.f) -endif() +sp_mod.F) # Set compiler flags. if(CMAKE_BUILD_TYPE MATCHES "Debug") # Bounds checking is turned on for all files for the "Debug" build in the # main CMakeLists.txt. - # Need to turn off bounds checking for fftpack.F, sptranf.f, and sptranfv.f - # in order to pass tests. - foreach(filename fftpack.F sptranf.f sptranfv.f) - if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel|IntelLLVM)$") - set_source_files_properties(${filename} PROPERTIES COMPILE_FLAGS -check=nobounds) - elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") - if(${CMAKE_Fortran_COMPILER_VERSION} VERSION_GREATER_EQUAL 6) - set_source_files_properties(${filename} PROPERTIES COMPILE_FLAGS -fcheck=no-bounds) - else() - set_source_files_properties(${filename} PROPERTIES COMPILE_FLAGS -fno-bounds-check) - endif() + # Need to turn off bounds checking because of fftpack.F, sptranf.f, and sptranfv.f. + if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel|IntelLLVM)$") + set_source_files_properties(sp_mod.F PROPERTIES COMPILE_FLAGS -check=nobounds) + elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") + if(${CMAKE_Fortran_COMPILER_VERSION} VERSION_GREATER_EQUAL 6) + set_source_files_properties(sp_mod.F PROPERTIES COMPILE_FLAGS -fcheck=no-bounds) + else() + set_source_files_properties(sp_mod.F PROPERTIES COMPILE_FLAGS -fno-bounds-check) endif() - endforeach() + endif() endif() # Build _4, _d, and/or _8 depending on options provided to CMake @@ -68,6 +55,9 @@ foreach(kind ${kinds}) # Set compiler flags. target_compile_definitions(${lib_name} PRIVATE "LSIZE=${kind_definition}") + if(BUILD_DEPRECATED) + target_compile_definitions(${lib_name} PRIVATE BUILD_DEPRECATED) + endif() set_target_properties(${lib_name} PROPERTIES COMPILE_FLAGS "${fortran_${kind}_flags}") set_target_properties(${lib_name} PROPERTIES Fortran_MODULE_DIRECTORY "${module_dir}") target_include_directories(${lib_name} diff --git a/src/fftpack.F b/src/fftpack.F index bb415a6a..1b3b14dd 100644 --- a/src/fftpack.F +++ b/src/fftpack.F @@ -33,8 +33,10 @@ SUBROUTINE dcrft(init,x,ldx,y,ldy,n,m,isign,scale, & table,n1,wrk,n2,z,nz) implicit none - integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j - real x(2*ldx,*),y(ldy,*),scale,table(44002),wrk,z + integer init,ldx,ldy,n,m,isign,n1,n2,i,j + real x(2*ldx,*),y(ldy,*),scale,table(44002),wrk(*) + real, optional :: z + integer, optional :: nz IF (init.ne.0) THEN CALL rffti(n,table) @@ -79,8 +81,10 @@ SUBROUTINE scrft(init,x,ldx,y,ldy,n,m,isign,scale, & table,n1,wrk,n2,z,nz) implicit none - integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j - real x(2*ldx,*),y(ldy,*),scale,table(44002),wrk,z + integer init,ldx,ldy,n,m,isign,n1,n2,i,j + real x(2*ldx,*),y(ldy,*),scale,table(44002),wrk(*) + real, optional :: z + integer, optional :: nz IF (init.ne.0) THEN CALL rffti(n,table) @@ -159,8 +163,10 @@ SUBROUTINE drcft(init,x,ldx,y,ldy,n,m,isign,scale, & table,n1,wrk,n2,z,nz) implicit none - integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j - real x(ldx,*),y(2*ldy,*),scale,table(44002),wrk,z + integer init,ldx,ldy,n,m,isign,n1,n2,i,j + real x(ldx,*),y(2*ldy,*),scale,table(44002),wrk(*) + real, optional :: z + integer, optional :: nz IF (init.ne.0) THEN CALL rffti(n,table) @@ -208,8 +214,10 @@ SUBROUTINE srcft(init,x,ldx,y,ldy,n,m,isign,scale, & table,n1,wrk,n2,z,nz) implicit none - integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j - real x(ldx,*),y(2*ldy,*),scale,table(44002),wrk,z + integer init,ldx,ldy,n,m,isign,n1,n2,i,j + real x(ldx,*),y(2*ldy,*),scale,table(44002),wrk(*) + real, optional :: z + integer, optional :: nz IF (init.ne.0) THEN CALL rffti(n,table) @@ -280,7 +288,7 @@ SUBROUTINE scfft(isign,n,scale,x,y,table,work,isys) C> C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RFFTF (N,R,WSAVE) - DIMENSION R(1) ,WSAVE(1) + DIMENSION R(*) ,WSAVE(*) IF (N .EQ. 1) RETURN CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) RETURN @@ -294,7 +302,7 @@ SUBROUTINE RFFTF (N,R,WSAVE) C> C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RFFTB (N,R,WSAVE) - DIMENSION R(1) ,WSAVE(1) + DIMENSION R(*) ,WSAVE(*) IF (N .EQ. 1) RETURN CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) RETURN @@ -307,7 +315,7 @@ SUBROUTINE RFFTB (N,R,WSAVE) C> C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RFFTI (N,WSAVE) - DIMENSION WSAVE(1) + DIMENSION WSAVE(*) IF (N .EQ. 1) RETURN CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1)) RETURN @@ -323,7 +331,7 @@ SUBROUTINE RFFTI (N,WSAVE) C> C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RFFTB1 (N,C,CH,WA,IFAC) - DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(*) + REAL CH(*) ,C(*) ,WA(*) ,IFAC(*) NF = IFAC(2) NA = 0 L1 = 1 @@ -392,7 +400,7 @@ SUBROUTINE RFFTB1 (N,C,CH,WA,IFAC) C> C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC) - DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(*) + REAL CH(*) ,C(*) ,WA(*) ,IFAC(*) NF = IFAC(2) NA = 1 L2 = N @@ -459,7 +467,7 @@ SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC) C> C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RFFTI1 (N,WA,IFAC) - DIMENSION WA(1) ,IFAC(*) ,NTRYH(4) + REAL WA(*) ,IFAC(*) ,NTRYH(4) DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ NL = N NF = 0 @@ -529,7 +537,7 @@ SUBROUTINE RFFTI1 (N,WA,IFAC) C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RADB2 (IDO,L1,CC,CH,WA1) DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , - 1 WA1(1) + 1 WA1(*) DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) @@ -568,7 +576,7 @@ SUBROUTINE RADB2 (IDO,L1,CC,CH,WA1) C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RADB3 (IDO,L1,CC,CH,WA1,WA2) DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , - 1 WA1(1) ,WA2(1) + 1 WA1(*) ,WA2(*) DATA TAUR,TAUI /-.5,.866025403784439/ DO 101 K=1,L1 TR2 = CC(IDO,2,K)+CC(IDO,2,K) @@ -618,7 +626,7 @@ SUBROUTINE RADB3 (IDO,L1,CC,CH,WA1,WA2) C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RADB4 (IDO,L1,CC,CH,WA1,WA2,WA3) DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , - 1 WA1(1) ,WA2(1) ,WA3(1) + 1 WA1(*) ,WA2(*) ,WA3(*) DATA SQRT2 /1.414213562373095/ DO 101 K=1,L1 TR1 = CC(1,1,K)-CC(IDO,4,K) @@ -689,7 +697,7 @@ SUBROUTINE RADB4 (IDO,L1,CC,CH,WA1,WA2,WA3) C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , - 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) + 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, 1-.809016994374947,.587785252292473/ DO 101 K=1,L1 @@ -768,7 +776,7 @@ SUBROUTINE RADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,C2(IDL1,IP), - 2 CH2(IDL1,IP) ,WA(1) + 2 CH2(IDL1,IP) ,WA(*) DATA TPI/6.28318530717959/ ARG = TPI/FLOAT(IP) DCP = COS(ARG) @@ -945,7 +953,7 @@ SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1) DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) , - 1 WA1(1) + 1 WA1(*) DO 101 K=1,L1 CH(1,1,K) = CC(1,K,1)+CC(1,K,2) CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) @@ -983,7 +991,7 @@ SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1) C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2) DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) , - 1 WA1(1) ,WA2(1) + 1 WA1(*) ,WA2(*) DATA TAUR,TAUI /-.5,.866025403784439/ DO 101 K=1,L1 CR2 = CC(1,K,2)+CC(1,K,3) @@ -1030,7 +1038,7 @@ SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2) C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) , - 1 WA1(1) ,WA2(1) ,WA3(1) + 1 WA1(*) ,WA2(*) ,WA3(*) DATA HSQT2 /.7071067811865475/ DO 101 K=1,L1 TR1 = CC(1,K,2)+CC(1,K,4) @@ -1097,7 +1105,7 @@ SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) C> @author Paul N. Swarztrauber, National Center for Atmospheric Research, Boulder, CO SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) , - 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) + 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, 1-.809016994374947,.587785252292473/ DO 101 K=1,L1 @@ -1172,7 +1180,7 @@ SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,C2(IDL1,IP), - 2 CH2(IDL1,IP) ,WA(1) + 2 CH2(IDL1,IP) ,WA(*) DATA TPI/6.28318530717959/ ARG = TPI/FLOAT(IP) DCP = COS(ARG) diff --git a/src/ip_gaussian_grid_mod.F90 b/src/ip_gaussian_grid_mod.F90 index 890c61df..e5438b49 100644 --- a/src/ip_gaussian_grid_mod.F90 +++ b/src/ip_gaussian_grid_mod.F90 @@ -16,6 +16,7 @@ module ip_gaussian_grid_mod use ip_grid_mod use earth_radius_mod use ip_constants_mod + use sp_mod implicit none private diff --git a/src/sp_mod.F b/src/sp_mod.F new file mode 100644 index 00000000..39a53370 --- /dev/null +++ b/src/sp_mod.F @@ -0,0 +1,63 @@ + module sp_mod + + contains + +#include "fftpack.F" +#include "ncpus.F" +#include "spanaly.f" +#include "spdz2uv.f" +#include "speps.f" +#include "spfft1.f" +#include "spffte.f" +#include "spfftpt.f" +#include "splaplac.f" +#include "splat.F" +#include "splegend.f" +#include "sppad.f" +#include "spsynth.f" +#include "sptezd.f" +#include "sptez.f" +#include "sptezmd.f" +#include "sptezm.f" +#include "sptezmv.f" +#include "sptezv.f" +#include "sptgpm.f" +#include "sptgpmv.f" +#include "sptgps.f" +#include "sptgpsv.f" +#include "sptgpt.f" +#include "sptgptv.f" +#include "sptrand.f" +#include "sptran.f" +#include "sptranf0.f" +#include "sptranf1.f" +#include "sptranf.f" +#include "sptranfv.f" +#include "sptranv.f" +#include "sptrun.f" +#include "sptrung.f" +#include "sptrungv.f" +#include "sptrunm.f" +#include "sptrunmv.f" +#include "sptruns.f" +#include "sptrunsv.f" +#include "sptrunv.f" +#include "spuv2dz.f" +#include "spwget.f" + +#ifdef BUILD_DEPRECATED +#include "spfft.f" +#include "spgradq.f" +#include "spgradx.f" +#include "spgrady.f" +#include "sptgpmd.f" +#include "sptgpsd.f" +#include "sptgptd.f" +#include "sptgptsd.f" +#include "sptgptvd.f" +#include "sptrund.f" +#include "sptrunl.f" +#include "spvar.f" +#endif + + end module diff --git a/src/spectral_interp_mod.F90 b/src/spectral_interp_mod.F90 index 03d58125..4cb87b12 100644 --- a/src/spectral_interp_mod.F90 +++ b/src/spectral_interp_mod.F90 @@ -11,6 +11,7 @@ module spectral_interp_mod use ip_grid_descriptor_mod use ip_grid_factory_mod use earth_radius_mod + use sp_mod implicit none private @@ -916,11 +917,11 @@ SUBROUTINE POLATEV4_grib2(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, & INTEGER :: K, MAXWV, N, NI, NJ, NPS ! REAL :: DLAT, DLON, DLATO, DLONO, DE, DR, DY - REAL :: DUM, E2, H, HI, HJ + REAL :: DUM, E2, H, HI, HJ, DUMM(1) REAL :: ORIENT, RERTH, SLAT REAL :: RLAT1, RLON1, RLAT2, RLON2, RLATI REAL :: UROT, VROT, UO2(MO,KM),VO2(MO,KM) - REAL :: XMESH, X, XP, YP, XPTS(MO),YPTS(MO) + REAL :: XMESH, XP, YP, XPTS(MO),YPTS(MO) type(grib2_descriptor) :: desc_in, desc_out class(ip_grid), allocatable :: grid_in, grid_out @@ -1043,7 +1044,7 @@ SUBROUTINE POLATEV4_grib2(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, & IF(ISPEC.EQ.1) THEN CALL SPTRUNV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,IDRTO,IMO,JMO, & KM,IPRIME,ISKIPI,JSKIPI,MI,0,0,MO,0,UI,VI, & - .TRUE.,UO,VO,.FALSE.,DUM,DUM,.FALSE.,DUM,DUM) + .TRUE.,UO,VO,.FALSE.,DUMM,DUMM,.FALSE.,DUMM,DUMM) ENDIF ! SPECIAL CASE OF POLAR STEREOGRAPHIC GRID ELSEIF(IGDTNUMO.EQ.20.AND. & @@ -1069,14 +1070,14 @@ SUBROUTINE POLATEV4_grib2(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, & CALL SPTRUNSV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NPS, & IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0, & SLAT,XMESH,ORIENT,UI,VI,.TRUE.,UO,VO,UO2,VO2, & - .FALSE.,DUM,DUM,DUM,DUM, & - .FALSE.,DUM,DUM,DUM,DUM) + .FALSE.,DUMM,DUMM,DUMM,DUMM, & + .FALSE.,DUMM,DUMM,DUMM,DUMM) ELSE CALL SPTRUNSV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NPS, & IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0, & SLAT,XMESH,ORIENT,UI,VI,.TRUE.,UO2,VO2,UO,VO, & - .FALSE.,DUM,DUM,DUM,DUM, & - .FALSE.,DUM,DUM,DUM,DUM) + .FALSE.,DUMM,DUMM,DUMM,DUMM, & + .FALSE.,DUMM,DUMM,DUMM,DUMM) ENDIF ISPEC=1 ENDIF @@ -1101,7 +1102,7 @@ SUBROUTINE POLATEV4_grib2(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, & CALL SPTRUNMV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NI,NJ, & IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0, & RLAT1,RLON1,DLATO,DLONO,UI,VI, & - .TRUE.,UO,VO,.FALSE.,DUM,DUM,.FALSE.,DUM,DUM) + .TRUE.,UO,VO,.FALSE.,DUMM,DUMM,.FALSE.,DUMM,DUMM) ISPEC=1 ENDIF ENDIF @@ -1109,7 +1110,7 @@ SUBROUTINE POLATEV4_grib2(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, & IF(ISPEC.EQ.0) THEN CALL SPTRUNGV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NO, & IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0,RLAT,RLON, & - UI,VI,.TRUE.,UO,VO,.FALSE.,X,X,.FALSE.,X,X) + UI,VI,.TRUE.,UO,VO,.FALSE.,DUMM,DUMM,.FALSE.,DUMM,DUMM) DO K=1,KM IBO(K)=0 DO N=1,NO @@ -1246,11 +1247,11 @@ SUBROUTINE POLATEV4_grib1(IPOPT,KGDSI,KGDSO,MI,MO,KM,IBI,UI,VI, & INTEGER :: K, MAXWV, N, NI, NJ, NO, NPS ! REAL :: DLAT, DLON, DLATO, DLONO, DE, DR, DY - REAL :: DUM, H, HI, HJ + REAL :: DUM, H, HI, HJ, DUMM(1) REAL :: ORIENT REAL :: RLAT1, RLON1, RLAT2, RLON2, RLATI REAL :: UROT, VROT, UO2(MO,KM),VO2(MO,KM) - REAL :: XMESH, X, XP, YP, XPTS(MO),YPTS(MO) + REAL :: XMESH, XP, YP, XPTS(MO),YPTS(MO) type(grib1_descriptor) :: desc_in, desc_out class(ip_grid), allocatable :: grid_in, grid_out @@ -1360,7 +1361,7 @@ SUBROUTINE POLATEV4_grib1(IPOPT,KGDSI,KGDSO,MI,MO,KM,IBI,UI,VI, & IF(ISPEC.EQ.1) THEN CALL SPTRUNV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,IDRTO,IMO,JMO, & KM,IPRIME,ISKIPI,JSKIPI,MI,0,0,MO,0,UI,VI, & - .TRUE.,UO,VO,.FALSE.,DUM,DUM,.FALSE.,DUM,DUM) + .TRUE.,UO,VO,.FALSE.,DUMM,DUMM,.FALSE.,DUMM,DUMM) ENDIF ! SPECIAL CASE OF POLAR STEREOGRAPHIC GRID ELSEIF(KGDSO(1).EQ.5.AND. & @@ -1384,14 +1385,14 @@ SUBROUTINE POLATEV4_grib1(IPOPT,KGDSI,KGDSO,MI,MO,KM,IBI,UI,VI, & CALL SPTRUNSV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NPS, & IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0, & 60.,XMESH,ORIENT,UI,VI,.TRUE.,UO,VO,UO2,VO2, & - .FALSE.,DUM,DUM,DUM,DUM, & - .FALSE.,DUM,DUM,DUM,DUM) + .FALSE.,DUMM,DUMM,DUMM,DUMM, & + .FALSE.,DUMM,DUMM,DUMM,DUMM) ELSE CALL SPTRUNSV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NPS, & IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0, & 60.,XMESH,ORIENT,UI,VI,.TRUE.,UO2,VO2,UO,VO, & - .FALSE.,DUM,DUM,DUM,DUM, & - .FALSE.,DUM,DUM,DUM,DUM) + .FALSE.,DUMM,DUMM,DUMM,DUMM, & + .FALSE.,DUMM,DUMM,DUMM,DUMM) ENDIF ISPEC=1 ENDIF @@ -1415,7 +1416,7 @@ SUBROUTINE POLATEV4_grib1(IPOPT,KGDSI,KGDSO,MI,MO,KM,IBI,UI,VI, & CALL SPTRUNMV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NI,NJ, & IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0, & RLAT1,RLON1,DLATO,DLONO,UI,VI, & - .TRUE.,UO,VO,.FALSE.,DUM,DUM,.FALSE.,DUM,DUM) + .TRUE.,UO,VO,.FALSE.,DUMM,DUMM,.FALSE.,DUMM,DUMM) ISPEC=1 ENDIF ENDIF @@ -1423,7 +1424,7 @@ SUBROUTINE POLATEV4_grib1(IPOPT,KGDSI,KGDSO,MI,MO,KM,IBI,UI,VI, & IF(ISPEC.EQ.0) THEN CALL SPTRUNGV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KM,NO, & IPRIME,ISKIPI,JSKIPI,MI,MO,0,0,0,RLAT,RLON, & - UI,VI,.TRUE.,UO,VO,.FALSE.,X,X,.FALSE.,X,X) + UI,VI,.TRUE.,UO,VO,.FALSE.,DUMM,DUMM,.FALSE.,DUMM,DUMM) DO K=1,KM IBO(K)=0 DO N=1,NO diff --git a/src/spfft.f b/src/spfft.f index 672bb025..3146487d 100644 --- a/src/spfft.f +++ b/src/spfft.f @@ -42,6 +42,7 @@ SUBROUTINE SPFFT(IMAX,INCW,INCG,KMAX,W,G,IDIR) IMPLICIT NONE INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR COMPLEX,INTENT(INOUT):: W(INCW,KMAX) + REAL:: WREAL(INCW,KMAX) REAL,INTENT(INOUT):: G(INCG,KMAX) INTEGER,SAVE:: NAUX1=0 REAL,SAVE,ALLOCATABLE:: AUX1CR(:),AUX1RC(:) @@ -50,6 +51,7 @@ SUBROUTINE SPFFT(IMAX,INCW,INCG,KMAX,W,G,IDIR) NAUX2=20000+INT(0.57*IMAX) + WREAL=REAL(W) C INITIALIZATION. C ALLOCATE AND FILL AUXILIARY ARRAYS WITH TRIGONOMETRIC DATA SELECT CASE(IDIR) @@ -57,19 +59,20 @@ SUBROUTINE SPFFT(IMAX,INCW,INCG,KMAX,W,G,IDIR) IF(NAUX1.GT.0) DEALLOCATE(AUX1CR,AUX1RC) NAUX1=25000+INT(0.82*IMAX) ALLOCATE(AUX1CR(NAUX1),AUX1RC(NAUX1)) - CALL SCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1., + CALL SCRFT(1,WREAL,INCW,G,INCG,IMAX,KMAX,-1,1., & AUX1CR,NAUX1,AUX2,NAUX2,0.,0) - CALL SRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, + CALL SRCFT(1,G,INCG,WREAL,INCW,IMAX,KMAX,+1,1./IMAX, & AUX1RC,NAUX1,AUX2,NAUX2,0.,0) C FOURIER TO PHYSICAL TRANSFORM. CASE(1:) - CALL SCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1., + CALL SCRFT(0,WREAL,INCW,G,INCG,IMAX,KMAX,-1,1., & AUX1CR,NAUX1,AUX2,NAUX2,0.,0) C PHYSICAL TO FOURIER TRANSFORM. CASE(:-1) - CALL SRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, + CALL SRCFT(0,G,INCG,WREAL,INCW,IMAX,KMAX,+1,1./IMAX, & AUX1RC,NAUX1,AUX2,NAUX2,0.,0) END SELECT + W=CMPLX(WREAL) END SUBROUTINE diff --git a/src/spfft1.f b/src/spfft1.f index 4800356a..7f9ae70b 100644 --- a/src/spfft1.f +++ b/src/spfft1.f @@ -33,6 +33,7 @@ SUBROUTINE SPFFT1(IMAX,INCW,INCG,KMAX,W,G,IDIR) IMPLICIT NONE INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR COMPLEX,INTENT(INOUT):: W(INCW,KMAX) + REAL:: WREAL(INCW,KMAX) REAL,INTENT(INOUT):: G(INCG,KMAX) REAL:: AUX1(25000+INT(0.82*IMAX)) REAL:: AUX2(20000+INT(0.57*IMAX)) @@ -40,20 +41,22 @@ SUBROUTINE SPFFT1(IMAX,INCW,INCG,KMAX,W,G,IDIR) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NAUX1=25000+INT(0.82*IMAX) NAUX2=20000+INT(0.57*IMAX) + WREAL=REAL(W) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C FOURIER TO PHYSICAL TRANSFORM. SELECT CASE(IDIR) CASE(1:) - CALL SCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1., + CALL SCRFT(1,REAL(W),INCW,G,INCG,IMAX,KMAX,-1,1., & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL SCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1., + CALL SCRFT(0,REAL(W),INCW,G,INCG,IMAX,KMAX,-1,1., & AUX1,NAUX1,AUX2,NAUX2,0.,0) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C PHYSICAL TO FOURIER TRANSFORM. CASE(:-1) - CALL SRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, + CALL SRCFT(1,G,INCG,WREAL,INCW,IMAX,KMAX,+1,1./IMAX, & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL SRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, + CALL SRCFT(0,G,INCG,WREAL,INCW,IMAX,KMAX,+1,1./IMAX, & AUX1,NAUX1,AUX2,NAUX2,0.,0) END SELECT + W=CMPLX(WREAL,0.0) END SUBROUTINE diff --git a/src/spffte.f b/src/spffte.f index d7beb288..0dbb39ce 100644 --- a/src/spffte.f +++ b/src/spffte.f @@ -51,10 +51,12 @@ SUBROUTINE SPFFTE(IMAX,INCW,INCG,KMAX,W,G,IDIR,AFFT) REAL,INTENT(INOUT):: W(2*INCW,KMAX) REAL,INTENT(INOUT):: G(INCG,KMAX) REAL(8),INTENT(INOUT):: AFFT(50000+4*IMAX) + REAL:: AFFTR(50000+4*IMAX) INTEGER:: INIT,INC2X,INC2Y,N,M,ISIGN,NAUX1,NAUX2,NAUX3 C ==EM== ^(4) REAL:: SCALE REAL(8):: AUX2(20000+2*IMAX),AUX3 + REAL :: AUX2R(20000+2*IMAX),AUX3R INTEGER:: IACR,IARC NAUX1=25000+2*IMAX @@ -62,6 +64,9 @@ SUBROUTINE SPFFTE(IMAX,INCW,INCG,KMAX,W,G,IDIR,AFFT) NAUX3=1 IACR=1 IARC=1+NAUX1 + AFFTR=REAL(AFFT) + AUX2R=REAL(AUX2) + AUX3R=REAL(AUX3) C INITIALIZATION. C FILL AUXILIARY ARRAYS WITH TRIGONOMETRIC DATA @@ -76,10 +81,10 @@ SUBROUTINE SPFFTE(IMAX,INCW,INCG,KMAX,W,G,IDIR,AFFT) SCALE=1. IF(DIGITS(1.).LT.DIGITS(1._8)) THEN CALL SCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IACR),NAUX1,AUX2,NAUX2,AUX3,NAUX3) + & AFFTR(IACR),NAUX1,AUX2R,NAUX2,AUX3R,NAUX3) ELSE CALL DCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IACR),NAUX1,AUX2,NAUX2) + & AFFTR(IACR),NAUX1,AUX2R,NAUX2) ENDIF INIT=1 INC2X=INCG @@ -90,10 +95,10 @@ SUBROUTINE SPFFTE(IMAX,INCW,INCG,KMAX,W,G,IDIR,AFFT) SCALE=1./IMAX IF(DIGITS(1.).LT.DIGITS(1._8)) THEN CALL SRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IARC),NAUX1,AUX2,NAUX2,AUX3,NAUX3) + & AFFTR(IARC),NAUX1,AUX2R,NAUX2,AUX3R,NAUX3) ELSE CALL DRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IARC),NAUX1,AUX2,NAUX2) + & AFFTR(IARC),NAUX1,AUX2R,NAUX2) ENDIF C FOURIER TO PHYSICAL TRANSFORM. @@ -107,10 +112,10 @@ SUBROUTINE SPFFTE(IMAX,INCW,INCG,KMAX,W,G,IDIR,AFFT) SCALE=1. IF(DIGITS(1.).LT.DIGITS(1._8)) THEN CALL SCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IACR),NAUX1,AUX2,NAUX2,AUX3,NAUX3) + & AFFTR(IACR),NAUX1,AUX2R,NAUX2,AUX3R,NAUX3) ELSE CALL DCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IACR),NAUX1,AUX2,NAUX2) + & AFFTR(IACR),NAUX1,AUX2R,NAUX2) ENDIF C PHYSICAL TO FOURIER TRANSFORM. @@ -124,10 +129,13 @@ SUBROUTINE SPFFTE(IMAX,INCW,INCG,KMAX,W,G,IDIR,AFFT) SCALE=1./IMAX IF(DIGITS(1.).LT.DIGITS(1._8)) THEN CALL SRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IARC),NAUX1,AUX2,NAUX2,AUX3,NAUX3) + & AFFTR(IARC),NAUX1,AUX2R,NAUX2,AUX3R,NAUX3) ELSE CALL DRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IARC),NAUX1,AUX2,NAUX2) + & AFFTR(IARC),NAUX1,AUX2R,NAUX2) ENDIF END SELECT + AFFT=REAL(AFFTR,KIND=8) + AUX2=REAL(AUX2R,KIND=8) + AUX3=REAL(AUX3R,KIND=8) END SUBROUTINE diff --git a/src/sptezd.f b/src/sptezd.f index 0c0eaf3c..9015dd72 100644 --- a/src/sptezd.f +++ b/src/sptezd.f @@ -50,7 +50,7 @@ SUBROUTINE SPTEZD(IROMB,MAXWV,IDRT,IMAX,JMAX, & WAVE,GRIDMN,GRIDX,GRIDY,IDIR) - REAL WAVE(*),GRIDX(IMAX,JMAX),GRIDY(IMAX,JMAX) + REAL WAVE(*),GRIDX(IMAX,JMAX),GRIDY(IMAX,JMAX),GRIDMN(*) JC=NCPUS() CALL SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,1, diff --git a/src/sptranf0.f b/src/sptranf0.f index 4feb90df..b4f4838b 100644 --- a/src/sptranf0.f +++ b/src/sptranf0.f @@ -44,9 +44,11 @@ SUBROUTINE SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE) REAL PLNTOP(MAXWV+1,JB:JE) REAL SLATX(JMAX),WLATX(JMAX) + REAL W(IMAX+2,2),G(IMAX,2) + W = 0.0 CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - CALL SPFFTE(IMAX,(IMAX+2)/2,IMAX,2,0.,0.,0,AFFT) + CALL SPFFTE(IMAX,(IMAX+2)/2,IMAX,2,W,G,0,AFFT) CALL SPLAT(IDRT,JMAX,SLATX,WLATX) JHE=(JMAX+1)/2 IF(JHE.GT.JMAX/2) WLATX(JHE)=WLATX(JHE)/2 diff --git a/src/sptranf1.f b/src/sptranf1.f index 37a07bde..e13f723f 100644 --- a/src/sptranf1.f +++ b/src/sptranf1.f @@ -60,7 +60,7 @@ SUBROUTINE SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, IF(IDIR.GT.0) THEN DO J=JB,JE CALL SPSYNTH(IROMB,MAXWV,IMAX,IMAX+2,KW,KWTOP,1, - & CLAT(J),PLN(1,J),PLNTOP(1,J),MP, + & CLAT(J),PLN(1,J),PLNTOP(1,J),(/MP/), & W,WTOP,F) CALL SPFFTE(IMAX,(IMAX+2)/2,IMAX,2,F,G(1,1,J),+1,AFFT) ENDDO @@ -68,7 +68,7 @@ SUBROUTINE SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, DO J=JB,JE CALL SPFFTE(IMAX,(IMAX+2)/2,IMAX,2,F,G(1,1,J),-1,AFFT) CALL SPANALY(IROMB,MAXWV,IMAX,IMAX+2,KW,KWTOP,1, - & WLAT(J),CLAT(J),PLN(1,J),PLNTOP(1,J),MP, + & WLAT(J),CLAT(J),PLN(1,J),PLNTOP(1,J),(/MP/), & F,W,WTOP) ENDDO ENDIF diff --git a/src/sptranfv.f b/src/sptranfv.f index 26e9d4ef..6361c343 100644 --- a/src/sptranfv.f +++ b/src/sptranfv.f @@ -90,7 +90,7 @@ SUBROUTINE SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE) REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE) REAL PLNTOP(MAXWV+1,JB:JE) - INTEGER MP(2) + INTEGER MP REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,2) REAL WTOP(2*(MAXWV+1),2) REAL G(IMAX,2,2) diff --git a/src/sptrund.f b/src/sptrund.f index dc1c157b..427e879f 100644 --- a/src/sptrund.f +++ b/src/sptrund.f @@ -74,7 +74,7 @@ SUBROUTINE SPTRUND(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, & ISKIPO,JSKIPO,KSKIPO,JCPU,GRID, & GRIDMN,GRIDX,GRIDY) - REAL GRID(*),GRIDX(*),GRIDY(*) + REAL GRID(*),GRIDX(*),GRIDY(*),GRIDMN(*) REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C TRANSFORM INPUT GRID TO WAVE diff --git a/tests/test_fft.F90 b/tests/test_fft.F90 index 15b2b11d..738de531 100644 --- a/tests/test_fft.F90 +++ b/tests/test_fft.F90 @@ -2,6 +2,7 @@ ! ! Kyle Gerheiser program test_fft + use sp_mod use iso_fortran_env, only: real32, real64 implicit none diff --git a/tests/test_ncpus.F90 b/tests/test_ncpus.F90 index 53d798cb..3c259f79 100644 --- a/tests/test_ncpus.F90 +++ b/tests/test_ncpus.F90 @@ -4,9 +4,11 @@ ! ! Kyle Gerheiser program test_ncpus + use sp_mod + implicit none - integer :: n, ncpus + integer :: n n = ncpus() #ifndef OPENMP diff --git a/tests/test_splaplac.F90 b/tests/test_splaplac.F90 index b733e330..18d5018f 100644 --- a/tests/test_splaplac.F90 +++ b/tests/test_splaplac.F90 @@ -4,6 +4,7 @@ ! ! Alex Richert, Oct 2023 PROGRAM TEST_SPLAPLAC + USE SP_MOD IMPLICIT NONE INTEGER I, M, J, QSIZE, QD2SIZE diff --git a/tests/test_splat.F90 b/tests/test_splat.F90 index 29685b1c..cb564def 100644 --- a/tests/test_splat.F90 +++ b/tests/test_splat.F90 @@ -4,6 +4,8 @@ ! ! Kyle Gerheiser program test_splat + + use sp_mod use iso_fortran_env, only: real64 implicit none diff --git a/tests/test_sppad.F90 b/tests/test_sppad.F90 index f1b69edf..b593c95b 100644 --- a/tests/test_sppad.F90 +++ b/tests/test_sppad.F90 @@ -4,6 +4,7 @@ ! ! Alex Richert, Oct 2023 PROGRAM TEST_SPPAD + USE SP_MOD IMPLICIT NONE INTEGER WHICH, I, IMAX1, IMAX2 diff --git a/tests/test_sptezv.F90 b/tests/test_sptezv.F90 index 0e9b82be..e1979b07 100644 --- a/tests/test_sptezv.F90 +++ b/tests/test_sptezv.F90 @@ -4,6 +4,7 @@ ! ! Kyle Gerheiser program test_sptezv + use sp_mod use iso_fortran_env, only: real64 implicit none diff --git a/tests/test_sptrung.F90 b/tests/test_sptrung.F90 index 8f0c30b8..cff823c7 100644 --- a/tests/test_sptrung.F90 +++ b/tests/test_sptrung.F90 @@ -4,6 +4,7 @@ ! ! Alex Richert, Oct 2023 program test_sptrung + use sp_mod implicit none INTEGER :: I diff --git a/tests/test_sptrungv.F90 b/tests/test_sptrungv.F90 index fb772369..9c9cbdb2 100644 --- a/tests/test_sptrungv.F90 +++ b/tests/test_sptrungv.F90 @@ -4,6 +4,7 @@ ! ! Alex Richert, Oct 2023 program test_sptrungv + use sp_mod implicit none ! @@ -21,7 +22,7 @@ program test_sptrungv REAL*4 :: RDRLAT(MO),RDRLON(MO) REAL*4 :: RDUI(MI,KM),RDVI(MI,KM) REAL*4 :: RDUOREF(MO,KM),RDVOREF(MO,KM) - REAL :: X=0.0 + REAL :: X(1)=0.0 REAL :: TOL=1e-2 OPEN (12, file="data/sptrungv.uv.in", access='direct', recl=MI*KM*4, convert='little_endian')