diff --git a/CMakeLists.txt b/CMakeLists.txt index c81c7d1f..51504c16 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -11,7 +11,7 @@ if ( NOT HERMES_LIGHT ) GMAO_mpeu GMAO_pilgrim GMAO_etc - GEOS_Util + @GEOS_Util LANL_Shared GMAO_perllib GMAO_transf diff --git a/GEOS_Shared/G3_MPI_Util_Mod.F90 b/GEOS_Shared/G3_MPI_Util_Mod.F90 index a14d0b59..2b7ec0cd 100644 --- a/GEOS_Shared/G3_MPI_Util_Mod.F90 +++ b/GEOS_Shared/G3_MPI_Util_Mod.F90 @@ -2,6 +2,7 @@ module G3_MPI_Util_Mod use MAPL + use iso_fortran_env implicit none ! Define Lattice @@ -345,12 +346,12 @@ subroutine g3_scatter_1d_r4 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=4) qglobal( lattice%imglobal ) - real(kind=4) qlocal ( lattice%im(lattice%myid) ) + real(kind=REAL32) qglobal( lattice%imglobal ) + real(kind=REAL32) qlocal ( lattice%im(lattice%myid) ) integer status(mpi_status_size) integer comm integer i,n,loc,im,imx,imglobal,myid,npes,ierror,mpi_rkind - real(kind=4), allocatable :: buf(:) + real(kind=REAL32), allocatable :: buf(:) comm = lattice%comm myid = lattice%myid @@ -386,12 +387,12 @@ subroutine g3_scatter_1d_r8 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=8) qglobal( lattice%imglobal ) - real(kind=8) qlocal ( lattice%im(lattice%myid) ) + real(kind=REAL64) qglobal( lattice%imglobal ) + real(kind=REAL64) qlocal ( lattice%im(lattice%myid) ) integer status(mpi_status_size) integer comm integer i,n,loc,im,imx,imglobal,myid,npes,ierror,mpi_rkind - real(kind=8), allocatable :: buf(:) + real(kind=REAL64), allocatable :: buf(:) comm = lattice%comm myid = lattice%myid @@ -427,14 +428,14 @@ subroutine g3_scatter_2d_r4 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=4) qglobal( lattice%imglobal,lattice%jmglobal ) - real(kind=4) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) + real(kind=REAL32) qglobal( lattice%imglobal,lattice%jmglobal ) + real(kind=REAL32) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) integer status(mpi_status_size) integer comm integer myid,npe,ierror,mpi_rkind integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=4), allocatable :: buf(:,:) + real(kind=REAL32), allocatable :: buf(:,:) comm = lattice%comm myid = lattice%myid @@ -490,14 +491,14 @@ subroutine g3_scatter_2d_r8 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=8) qglobal( lattice%imglobal,lattice%jmglobal ) - real(kind=8) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) + real(kind=REAL64) qglobal( lattice%imglobal,lattice%jmglobal ) + real(kind=REAL64) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) integer status(mpi_status_size) integer comm integer myid,npe,ierror,mpi_rkind integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=8), allocatable :: buf(:,:) + real(kind=REAL64), allocatable :: buf(:,:) comm = lattice%comm myid = lattice%myid @@ -615,14 +616,14 @@ subroutine g3_scatter_3d_r4 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=4) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) - real(kind=4) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) + real(kind=REAL32) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) + real(kind=REAL32) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) integer status(mpi_status_size) integer comm,lm,L integer myid,npe,ierror,mpi_rkind integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=4), allocatable :: buf(:,:,:) + real(kind=REAL32), allocatable :: buf(:,:,:) comm = lattice%comm myid = lattice%myid @@ -683,14 +684,14 @@ subroutine g3_scatter_3d_r8 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=8) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) - real(kind=8) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) + real(kind=REAL64) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) + real(kind=REAL64) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) integer status(mpi_status_size) integer comm,lm,L integer myid,npe,ierror,mpi_rkind integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=8), allocatable :: buf(:,:,:) + real(kind=REAL64), allocatable :: buf(:,:,:) comm = lattice%comm myid = lattice%myid @@ -751,8 +752,8 @@ subroutine g3_gather_1d_r4 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=4) qglobal( lattice%imglobal ) - real(kind=4) qlocal ( lattice%im(lattice%myid) ) + real(kind=REAL32) qglobal( lattice%imglobal ) + real(kind=REAL32) qlocal ( lattice%im(lattice%myid) ) integer status(mpi_status_size) integer comm, mpi_rkind integer i,n,loc,im,imx,myid,npes,ierror @@ -786,8 +787,8 @@ subroutine g3_gather_1d_r8 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=8) qglobal( lattice%imglobal ) - real(kind=8) qlocal ( lattice%im(lattice%myid) ) + real(kind=REAL64) qglobal( lattice%imglobal ) + real(kind=REAL64) qlocal ( lattice%im(lattice%myid) ) integer status(mpi_status_size) integer comm, mpi_rkind integer i,n,loc,im,imx,myid,npes,ierror @@ -821,14 +822,14 @@ subroutine g3_gather_2d_r4 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=4) qglobal( lattice%imglobal,lattice%jmglobal ) - real(kind=4) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) + real(kind=REAL32) qglobal( lattice%imglobal,lattice%jmglobal ) + real(kind=REAL32) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) integer status(mpi_status_size) integer comm, mpi_rkind integer myid,npe,ierror integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=4), allocatable :: buf(:,:) + real(kind=REAL32), allocatable :: buf(:,:) mpi_rkind = mpi_real comm = lattice%comm @@ -883,14 +884,14 @@ subroutine g3_gather_2d_r8 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=8) qglobal( lattice%imglobal,lattice%jmglobal ) - real(kind=8) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) + real(kind=REAL64) qglobal( lattice%imglobal,lattice%jmglobal ) + real(kind=REAL64) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) integer status(mpi_status_size) integer comm, mpi_rkind integer myid,npe,ierror integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=8), allocatable :: buf(:,:) + real(kind=REAL64), allocatable :: buf(:,:) mpi_rkind = mpi_double_precision comm = lattice%comm @@ -945,14 +946,14 @@ subroutine g3_gather_3d_r4 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=4) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) - real(kind=4) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) + real(kind=REAL32) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) + real(kind=REAL32) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) integer status(mpi_status_size) integer comm,lm,L integer myid,npe,ierror, mpi_rkind integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=4), allocatable :: buf(:,:,:) + real(kind=REAL32), allocatable :: buf(:,:,:) mpi_rkind = mpi_real comm = lattice%comm @@ -1012,14 +1013,14 @@ subroutine g3_gather_3d_r8 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=8) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) - real(kind=8) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) + real(kind=REAL64) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) + real(kind=REAL64) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) integer status(mpi_status_size) integer comm,lm,L integer myid,npe,ierror, mpi_rkind integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=8), allocatable :: buf(:,:,:) + real(kind=REAL64), allocatable :: buf(:,:,:) mpi_rkind = mpi_double_precision comm = lattice%comm @@ -1651,26 +1652,26 @@ subroutine g3_gmean_2d_r4 ( q,qave4,lattice ) implicit none type ( dynamics_lattice_type ) lattice real q( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) - real*8 cosp( lattice%jm(lattice%pej) ) - real*8 qdum - real*8 qave + real(kind=REAL64) cosp( lattice%jm(lattice%pej) ) + real(kind=REAL64) qdum + real(kind=REAL64) qave real qave4 - real*8 dlat,dlon,phi + real(kind=REAL64) dlat,dlon,phi integer i,j,ierror integer im,jm im = lattice%im(lattice%pei) jm = lattice%jm(lattice%pej) - dlon = 2_8*MAPL_PI/ lattice%imglobal + dlon = 2_REAL64*MAPL_PI/ lattice%imglobal dlat = MAPL_PI/(lattice%jmglobal-1) do j=1,jm - phi = -0.5_8*MAPL_PI + (lattice%jglobal(j)-1)*dlat + phi = -0.5_REAL64*MAPL_PI + (lattice%jglobal(j)-1)*dlat cosp(j) = dcos(phi) enddo - qdum = 0.0_8 + qdum = 0.0_REAL64 do j=1,jm do i=1,im qdum = qdum + q(i,j) * cosp(j)*dlon*dlat @@ -1698,12 +1699,12 @@ subroutine g3_gmean_3d_r4 ( q,qave4,dp,lattice ) type ( dynamics_lattice_type ) lattice real q( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) real dp( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) - real*8 cosp( lattice%jm(lattice%pej) ) - real*8 qdum - real*8 qave + real(kind=REAL64) cosp( lattice%jm(lattice%pej) ) + real(kind=REAL64) qdum + real(kind=REAL64) qave real qave4 - real*8 dlat,dlon,phi + real(kind=REAL64) dlat,dlon,phi integer i,j,L,ierror integer im,jm,lm @@ -1711,14 +1712,14 @@ subroutine g3_gmean_3d_r4 ( q,qave4,dp,lattice ) jm = lattice%jm(lattice%pej) lm = lattice%lm - dlon = 2_8*MAPL_PI/ lattice%imglobal + dlon = 2_REAL64*MAPL_PI/ lattice%imglobal dlat = MAPL_PI/(lattice%jmglobal-1) do j=1,jm - phi = -0.5_8*MAPL_PI + (lattice%jglobal(j)-1)*dlat + phi = -0.5_REAL64*MAPL_PI + (lattice%jglobal(j)-1)*dlat cosp(j) = dcos(phi) enddo - qdum = 0.0_8 + qdum = 0.0_REAL64 do L=1,lm do j=1,jm do i=1,im @@ -1747,25 +1748,25 @@ subroutine g3_gmean_2d_r8 ( q,qave,lattice ) implicit none type ( dynamics_lattice_type ) lattice real q( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) - real*8 cosp( lattice%jm(lattice%pej) ) - real*8 qdum - real*8 qave + real(kind=REAL64) cosp( lattice%jm(lattice%pej) ) + real(kind=REAL64) qdum + real(kind=REAL64) qave - real*8 dlat,dlon,phi + real(kind=REAL64) dlat,dlon,phi integer i,j,ierror integer im,jm im = lattice%im(lattice%pei) jm = lattice%jm(lattice%pej) - dlon = 2_8*MAPL_PI/ lattice%imglobal + dlon = 2_REAL64*MAPL_PI/ lattice%imglobal dlat = MAPL_PI/(lattice%jmglobal-1) do j=1,jm - phi = -0.5_8*MAPL_PI + (lattice%jglobal(j)-1)*dlat + phi = -0.5_REAL64*MAPL_PI + (lattice%jglobal(j)-1)*dlat cosp(j) = dcos(phi) enddo - qdum = 0.0_8 + qdum = 0.0_REAL64 do j=1,jm do i=1,im qdum = qdum + q(i,j) * cosp(j)*dlon*dlat @@ -1792,11 +1793,11 @@ subroutine g3_gmean_3d_r8 ( q,qave,dp,lattice ) type ( dynamics_lattice_type ) lattice real q( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) real dp( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) - real*8 cosp( lattice%jm(lattice%pej) ) - real*8 qdum - real*8 qave + real(kind=REAL64) cosp( lattice%jm(lattice%pej) ) + real(kind=REAL64) qdum + real(kind=REAL64) qave - real*8 dlat,dlon,phi + real(kind=REAL64) dlat,dlon,phi integer i,j,L,ierror integer im,jm,lm @@ -1804,14 +1805,14 @@ subroutine g3_gmean_3d_r8 ( q,qave,dp,lattice ) jm = lattice%jm(lattice%pej) lm = lattice%lm - dlon = 2_8*MAPL_PI/ lattice%imglobal + dlon = 2_REAL64*MAPL_PI/ lattice%imglobal dlat = MAPL_PI/(lattice%jmglobal-1) do j=1,jm - phi = -0.5_8*MAPL_PI + (lattice%jglobal(j)-1)*dlat + phi = -0.5_REAL64*MAPL_PI + (lattice%jglobal(j)-1)*dlat cosp(j) = dcos(phi) enddo - qdum = 0.0_8 + qdum = 0.0_REAL64 do L=1,lm do j=1,jm do i=1,im @@ -1841,23 +1842,23 @@ subroutine gmean ( q,qave4,dp,im,jm,lm,n,lattice ) integer im,jm,lm real q(im,jm,lm) real dp(im,jm,lm) - real*8 cosp(jm) - real*8 qdum - real*8 qave + real(kind=REAL64) cosp(jm) + real(kind=REAL64) qdum + real(kind=REAL64) qave real qave4 - real*8 dlat,dlon,phi + real(kind=REAL64) dlat,dlon,phi integer i,j,L,n,ierror - dlon = 2_8*MAPL_PI/ lattice%imglobal + dlon = 2_REAL64*MAPL_PI/ lattice%imglobal dlat = MAPL_PI/(lattice%jmglobal-1) do j=1,jm - phi = -0.5_8*MAPL_PI + (lattice%jglobal(j)-1)*dlat + phi = -0.5_REAL64*MAPL_PI + (lattice%jglobal(j)-1)*dlat cosp(j) = dcos(phi) enddo if( lm.gt.1 ) then - qdum = 0.0_8 + qdum = 0.0_REAL64 do L=1,lm do j=1,jm do i=1,im @@ -1866,7 +1867,7 @@ subroutine gmean ( q,qave4,dp,im,jm,lm,n,lattice ) enddo enddo else - qdum = 0.0_8 + qdum = 0.0_REAL64 do j=1,jm do i=1,im qdum = qdum + q(i,j,1)**n * cosp(j)*dlon*dlat @@ -1894,16 +1895,16 @@ subroutine g3_amean_2d_r8 ( q,qave,area,im,jm,comm ) integer im,jm, comm real q( im,jm ) real area( im,jm ) - real*8 qdum1 - real*8 qdum2 - real*8 qave1 - real*8 qave2 - real*8 qave + real(kind=REAL64) qdum1 + real(kind=REAL64) qdum2 + real(kind=REAL64) qave1 + real(kind=REAL64) qave2 + real(kind=REAL64) qave integer i,j,ierror - qdum1 = 0.0_8 - qdum2 = 0.0_8 + qdum1 = 0.0_REAL64 + qdum2 = 0.0_REAL64 do j=1,jm do i=1,im qdum1 = qdum1 + q(i,j)*area(i,j) @@ -2000,7 +2001,7 @@ end subroutine destroy_dynamics_lattice subroutine malloc_1d_r (a,im) implicit none - real(kind=8), dimension(:), pointer :: a + real(kind=REAL64), dimension(:), pointer :: a integer i,im,m if(.not.associated(a)) then allocate(a(im)) @@ -2020,7 +2021,7 @@ end subroutine malloc_1d_r subroutine malloc_2d_r (a,im,jm) implicit none - real(kind=8), dimension(:,:), pointer :: a + real(kind=REAL64), dimension(:,:), pointer :: a integer i,j,m,im,jm if(.not.associated(a)) then allocate(a(im,jm)) @@ -2042,7 +2043,7 @@ end subroutine malloc_2d_r subroutine malloc_3d_r (a,im,jm,lm) implicit none - real(kind=8), dimension(:,:,:), pointer :: a + real(kind=REAL64), dimension(:,:,:), pointer :: a integer i,j,l,im,jm,lm,m if(.not.associated(a)) then allocate(a(im,jm,lm)) @@ -2066,7 +2067,7 @@ end subroutine malloc_3d_r subroutine malloc_4d_r (a,im,jm,lm,nm) implicit none - real(kind=8), dimension(:,:,:,:), pointer :: a + real(kind=REAL64), dimension(:,:,:,:), pointer :: a integer i,j,l,n,im,jm,lm,nm,m if(.not.associated(a)) then allocate(a(im,jm,lm,nm)) diff --git a/GEOS_Shared/OVP.F90 b/GEOS_Shared/OVP.F90 index 61c2bbc8..e5deedbe 100644 --- a/GEOS_Shared/OVP.F90 +++ b/GEOS_Shared/OVP.F90 @@ -14,6 +14,7 @@ module OVP use ESMF use MAPL + use iso_fortran_env implicit none private @@ -185,7 +186,7 @@ subroutine OVP_mask ( LONS, DELTA_TIME, OVERPASS_HOUR, MASK ) ALLOCATE( MASK( SIZE(LONS(:,1)), SIZE(LONS(1,:)) ) ) ! RETURN VALUE - SECONDS_AWAY = LONS*(180._8/MAPL_PI_R8)*240. - OVERPASS_HOUR*60*60 + SECONDS_AWAY = LONS*(180._REAL64/MAPL_PI_R8)*240. - OVERPASS_HOUR*60*60 CALL RESET_TIME_RANGE(SECONDS_AWAY) diff --git a/GEOS_Shared/calcdbz.F b/GEOS_Shared/calcdbz.F index 88cbd3a6..da4aabb7 100644 --- a/GEOS_Shared/calcdbz.F +++ b/GEOS_Shared/calcdbz.F @@ -160,8 +160,8 @@ SUBROUTINE CALCDBZ(DBZ,PRS,TMK,QVP,QRA,QSN,QGR,WEDIM,SNDIM,BTDIM, IF (IVARINT.EQ.1) THEN - TEMP_C = DMIN1(-0.001D0,TMK(I,J,K)-CELKEL) - SONV = DMIN1(2.0D8,2.0D6*EXP(-0.12D0*TEMP_C)) + TEMP_C = MIN(-0.001D0,TMK(I,J,K)-CELKEL) + SONV = MIN(2.0D8,2.0D6*EXP(-0.12D0*TEMP_C)) GONV = GON IF (QGR(I,J,K).GT.R1) THEN diff --git a/GEOS_Shared/windfix.F90 b/GEOS_Shared/windfix.F90 index 16f7dabc..5ea13e39 100644 --- a/GEOS_Shared/windfix.F90 +++ b/GEOS_Shared/windfix.F90 @@ -104,7 +104,7 @@ subroutine windfix ( ua,va,plea, & ! -------------------------------- if (size(uglo)>1) then do l=1,size(uglo,3) - call getdiv (uglo(1,1,l),vglo(1,1,l),dpglo(1,1,l),dglo(1,1,l),img,jmg ) + call getdiv (uglo(:,:,l),vglo(:,:,l),dpglo(:,:,l),dglo(:,:,l),img,jmg ) enddo end if @@ -134,7 +134,7 @@ subroutine windfix ( ua,va,plea, & ! -------------------------------- if (size(dpglo)>1) then do l=1,size(uglo,3) - call getdiv (uglo(1,1,l),vglo(1,1,l),dpglo(1,1,l),dglo(1,1,l),img,jmg ) + call getdiv (uglo(:,:,l),vglo(:,:,l),dpglo(:,:,l),dglo(:,:,l),img,jmg ) enddo end if @@ -211,7 +211,7 @@ subroutine windfix ( ua,va,plea, & ! ------------------------------------------------------------ if (size(dpglo)>1) then do l=1,size(dglo,3) - call VELPOT_SP (dglo(1,1,l),chi,img,jmg) + call VELPOT_SP (dglo(:,:,l),chi,img,jmg) call gradq (chi, uchi,vchi,img,jmg) uglo(:,:,l) = uglo(:,:,l) + uchi(:,:)/dpglo(:,:,l) vglo(:,:,l) = vglo(:,:,l) + vchi(:,:)/dpglo(:,:,l) diff --git a/GMAO_etc/mkdrstdate.f b/GMAO_etc/mkdrstdate.f index f06ad63f..8b331cf2 100644 --- a/GMAO_etc/mkdrstdate.f +++ b/GMAO_etc/mkdrstdate.f @@ -7,15 +7,15 @@ character(len=255) :: fname integer :: nymd, nhms, n, argc, iargc - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) then print*, 'GEOS-5 temporary and specific program ' print*, 'to create d_rst file with date and time' print*, ' Usage: mkdrstdate.x nymd nhms' - call exit(0) + stop endif do n=1,argc - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo read(arg(1), * ) nymd read(arg(2), * ) nhms diff --git a/GMAO_etc/rst_date.f b/GMAO_etc/rst_date.f index cfb7c133..3867a9f3 100644 --- a/GMAO_etc/rst_date.f +++ b/GMAO_etc/rst_date.f @@ -6,7 +6,7 @@ integer :: ndummy, nymd, nhms, n do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo drst = trim(arg(1)) diff --git a/GMAO_gfio/CMakeLists.txt b/GMAO_gfio/CMakeLists.txt index 5fe73bf6..a957c6d5 100644 --- a/GMAO_gfio/CMakeLists.txt +++ b/GMAO_gfio/CMakeLists.txt @@ -27,6 +27,12 @@ if (EXTENDED_SOURCE) endif() set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) +# NAG: legacy NetCDF-2 C API (NCVDEF, NCAPT, NCVPT, NCAGT, NCVGT, NCVGT1) is +# called with varying Fortran types intentionally — suppress type mismatch errors +if (CMAKE_Fortran_COMPILER_ID MATCHES "NAG") + target_compile_options(${this} PRIVATE $<$:-wmismatch=NCVDEF,NCAPT,NCVPT,NCAGT,NCVGT,NCVGT1>) +endif() + # Specs for r8 version if (precision STREQUAL "r8") string(REPLACE " " ";" tmp ${FREAL8}) @@ -65,6 +71,11 @@ endif () ecbuild_add_executable(TARGET GFIO_mean_${precision}.x SOURCES GFIO_mean.f90 LIBS GMAO_gfio_${precision} ) +# NAG: GFIO_mean compiled with -r8 calls GFIO_INQUIRE/GFIO_CREATE with promoted-real args +if (CMAKE_Fortran_COMPILER_ID MATCHES "NAG") + target_compile_options(GFIO_mean_${precision}.x PRIVATE $<$:-wmismatch=GFIO_INQUIRE,GFIO_CREATE>) +endif() + install( PROGRAMS gfio.py DESTINATION lib/Python diff --git a/GMAO_gfio/GFIO_mean.f90 b/GMAO_gfio/GFIO_mean.f90 index 0bf4b18f..5f8ddb3b 100644 --- a/GMAO_gfio/GFIO_mean.f90 +++ b/GMAO_gfio/GFIO_mean.f90 @@ -685,7 +685,7 @@ Program GFIO_mean ! All done ! -------- - call exit(0) + stop CONTAINS @@ -767,7 +767,6 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, & !------------------------------------------------------------------------- integer iarg, argc - integer :: iargc character(len=2048) argv character(len=255) Vars(mVars) @@ -784,7 +783,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, & print *, "-------------------------------------------------------------------" print * - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) call usage_() ! Defaults @@ -815,36 +814,36 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, & do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) then - exit + stop endif - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if(index(argv,'-o') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, outFile ) + call get_command_argument ( iArg, outFile ) elseif(index(argv,'-tfile') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, out_total_file ) + call get_command_argument ( iArg, out_total_file ) elseif(index(argv,'-cfile') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, out_counter_file ) + call get_command_argument ( iArg, out_counter_file ) else if(index(argv,'-inc') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) inc_hhmmss else if(index(argv,'-date') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) ndate yyyymmdd_new = ndate else if(index(argv,'-time') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) ntime hhmmss_new = ntime else if(index(argv,'-xswap') .gt. 0 ) then @@ -854,22 +853,22 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, & else if(index(argv,'-iflag') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) iflag else if(index(argv,'-irflag') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) irflag else if(index(argv,'-vars') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) call split_ ( ',', argv, mVars, Vars, nVars ) else if(index(argv,'-levels') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) call split_ ( ',', argv, mLevs, cLevs, nLevs ) allocate( Levs(nLevs), stat = rc) if ( rc /= 0 ) call die (myname, 'wrong in allocating nLevs') @@ -881,7 +880,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, & else if(index(argv,'-prec') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) outPrec else if(index(argv,'-d') .gt. 0 ) then debug = .true. @@ -922,7 +921,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, & read(inFiles(n)(1:i-1),*,iostat=ios) alpha(n) if ( ios /= 0 ) then print *, 'GFIO_mean: invalid alpha in '//trim(inFiles(n)) - call exit(1) + error stop 1 else infiles(n) = inFiles(n)(i+1:) linear_comb = .true. @@ -1051,13 +1050,13 @@ subroutine split_ ( tok, str, mList, List, nList ) if ( j < 1 ) then nList = nList + 1 List(nList) = str(i:) - exit + stop end if nList = nList + 1 List(nList) = str(i:i+j-1) i = i + j + 1 if ( i > l ) then - exit + stop endif end do @@ -1072,7 +1071,7 @@ subroutine die(myname,string) print *, ' ',myname print *, ' ',string print *, ' --------------------------------' - call exit(1) + error stop 1 return end subroutine die ! diff --git a/GMAO_gfio/ut_cyclic.f90 b/GMAO_gfio/ut_cyclic.f90 index fcd3a28b..c81061eb 100644 --- a/GMAO_gfio/ut_cyclic.f90 +++ b/GMAO_gfio/ut_cyclic.f90 @@ -39,7 +39,7 @@ program ut ! print *, 'Open, rc = ', rc if ( nymd < 0 ) then - call exit(0) + error stop 0 else if ( nymd == 0 ) then do m = 100, 1200, 100 diff --git a/GMAO_hermes/CMakeLists.txt b/GMAO_hermes/CMakeLists.txt index b06cc58c..0b3360a9 100644 --- a/GMAO_hermes/CMakeLists.txt +++ b/GMAO_hermes/CMakeLists.txt @@ -3,7 +3,7 @@ esma_set_this() add_definitions (-DHERMES -DDEBUG_SHAVE -Dunix -D__unix__) string (REPLACE " " ";" flags ${FREAL8}) add_compile_options(${flags}) -set (CMAKE_Fortran_FLAGS_RELEASE "-O3 ${common_Fortran_flags} ${ALIGNCOM} ${MISMATCH}") +set (CMAKE_Fortran_FLAGS_RELEASE "-O3 ${common_Fortran_flags} ${ALIGNCOM}") if ( NOT HERMES_LIGHT ) @@ -20,6 +20,10 @@ if ( NOT HERMES_LIGHT ) esma_add_library(${this} SRCS ${srcs} DEPENDENCIES GMAO_mpeu GMAO_gfio_r8) target_compile_options(${this} PRIVATE ${flags}) + # NAG: suppress GFIO type-punning mismatches + if (CMAKE_Fortran_COMPILER_ID MATCHES "NAG") + target_compile_options(${this} PRIVATE $<$:-wmismatch=GFIO_PUTREALATT,GFIO_GETREALATT>) + endif() if (EXTENDED_SOURCE) set_source_files_properties (m_interpack.F PROPERTIES COMPILE_FLAGS ${EXTENDED_SOURCE}) @@ -77,7 +81,15 @@ if ( NOT HERMES_LIGHT ) ecbuild_add_executable (TARGET dyn_blob.x SOURCES dyn_blob.f90 LIBS ${this}) ecbuild_add_executable (TARGET dyn_fsens_conv.x SOURCES dyn_fsens_conv.f90 LIBS ${this}) - install(PROGRAMS cnv2prs.pl ana5sfc echorc.pl DESTINATION bin) + install(PROGRAMS cnv2prs.pl ana5sfc echorc.pl DESTINATION bin) + + # NAG: executable sources also call GFIO_PUTREALATT/GFIO_GETREALATT with + # varying types (compiled with -r8); suppress type mismatch errors + if (CMAKE_Fortran_COMPILER_ID MATCHES "NAG") + foreach(_tgt GFIO_remap.x dyn52dyn.x fvsubset.x gcmbkg2ana.x) + target_compile_options(${_tgt} PRIVATE $<$:-wmismatch=GFIO_PUTREALATT,GFIO_GETREALATT>) + endforeach() + endif() else () diff --git a/GMAO_hermes/GFIO_remap.f90 b/GMAO_hermes/GFIO_remap.f90 index 27a09de4..2842bee8 100644 --- a/GMAO_hermes/GFIO_remap.f90 +++ b/GMAO_hermes/GFIO_remap.f90 @@ -2311,7 +2311,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile,psFile,resolution, & if ( prefProvided .gt. 0 ) then write (*,*) - write (*,'(X,A,X,I6,X,A)') "Using a provided reference pressure of", prefProvided, "Pascals." + write (*,'(1X,A,1X,I6,1X,A)') "Using a provided reference pressure of", prefProvided, "Pascals." end if if ( nLevs .gt. 0 ) then diff --git a/GMAO_hermes/ana5sfc.F90 b/GMAO_hermes/ana5sfc.F90 index 3d4c4ba0..50b0df64 100644 --- a/GMAO_hermes/ana5sfc.F90 +++ b/GMAO_hermes/ana5sfc.F90 @@ -489,7 +489,7 @@ program Ana5sfc ! call fremem_(x_a) - call exit(0) + stop !............................................................................ @@ -1280,7 +1280,7 @@ subroutine Init_ () character(len=*), parameter :: myname = 'init' - integer i, iarg, argc, iargc, n + integer i, iarg, argc, n character(len=255) argv print * @@ -1297,7 +1297,7 @@ subroutine Init_ () ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 3 ) call usage() iarg = 0 @@ -1307,7 +1307,7 @@ subroutine Init_ () if ( iarg .gt. argc ) then exit endif - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if (index(argv,'-v' ) .gt. 0 ) then debug = .true. else if (index(argv,'-noFlip' ) .gt. 0 ) then @@ -1317,7 +1317,7 @@ subroutine Init_ () else if (index(argv,'-o' ) .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, ana_sfc_tn ) ! not ana_sfc_fn + call get_command_argument ( iArg, ana_sfc_tn ) ! not ana_sfc_fn else n = n + 1 if ( n .eq. 1 ) then diff --git a/GMAO_hermes/blendq.f90 b/GMAO_hermes/blendq.f90 index 111dbefb..6ac420d7 100644 --- a/GMAO_hermes/blendq.f90 +++ b/GMAO_hermes/blendq.f90 @@ -41,7 +41,7 @@ program blend if ( k1 .gt. k2 .or. k1 .lt. 1 .or. k2 .gt. km ) then print *, 'invalid k1, k2 = ', k1, k2 - call exit(1) + stop 1 end if ! Allocated memory @@ -50,7 +50,7 @@ program blend pt(im,jm,km), q(im,jm,km,3), q32(im,jm), stat=ios ) if ( ios .ne. 0 ) then print *, 'cannot allocate memory' - call exit(1) + stop 1 endif ! Read AMIP file diff --git a/GMAO_hermes/diag2dyn.F b/GMAO_hermes/diag2dyn.F index 13810689..973bc5f6 100644 --- a/GMAO_hermes/diag2dyn.F +++ b/GMAO_hermes/diag2dyn.F @@ -876,7 +876,7 @@ subroutine parse ( diag1_fn, diag2_fn, ana_fn, in_res, out_res, logical, intent(out) :: verbose integer, intent(out) :: time(2), date(2) - integer :: i, iarg, argc, iargc, n, fid, rc, nhms1, vid + integer :: i, iarg, argc, n, fid, rc, nhms1, vid integer :: ntimes, nvars, ngatts character(len=255) argv, out_template, basen @@ -895,7 +895,7 @@ subroutine parse ( diag1_fn, diag2_fn, ana_fn, in_res, out_res, expid = 'unknown' verbose = .false. - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage_() iarg = 0 @@ -903,15 +903,15 @@ subroutine parse ( diag1_fn, diag2_fn, ana_fn, in_res, out_res, do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if (index(argv,'-o' ) .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, out_template ) + call get_command_argument ( iArg, out_template ) else if (index(argv,'-r' ) .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) out_res = argv(1:3) else if (index(argv,'-v' ) .gt. 0 ) then verbose = .true. @@ -920,7 +920,7 @@ subroutine parse ( diag1_fn, diag2_fn, ana_fn, in_res, out_res, diag1_fn = argv if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, diag2_fn ) + call get_command_argument ( iArg, diag2_fn ) n = n + 1 end if end do diff --git a/GMAO_hermes/drs2dyn.f90 b/GMAO_hermes/drs2dyn.f90 index 0409dff1..e50af479 100644 --- a/GMAO_hermes/drs2dyn.f90 +++ b/GMAO_hermes/drs2dyn.f90 @@ -91,7 +91,7 @@ program drs2dyn write(6,'(3a,i8.8,a,i2.2,a)') ' Created ', trim(dynfile), & ' with dyn-vect for ', nymd, ' at ', nhms/10000, 'Z' print *, '--------------------------------------------------------------------' - call exit(0) + stop CONTAINS @@ -132,7 +132,7 @@ subroutine Init_ ( drsfile, phyfile, bcsfile, dynftmpl, expid, & character*4, parameter :: myname = 'init' - integer nfiles, i, iarg, argc, iargc + integer nfiles, i, iarg, argc integer ires character(len=255) :: etafile, argv, res character*10 str @@ -158,7 +158,7 @@ subroutine Init_ ( drsfile, phyfile, bcsfile, dynftmpl, expid, & ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg = 0 @@ -169,20 +169,20 @@ subroutine Init_ ( drsfile, phyfile, bcsfile, dynftmpl, expid, & if ( iarg .gt. argc ) then exit end if - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, dynftmpl ) + call get_command_argument ( iarg, dynftmpl ) case ("-expid") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, expid ) + call get_command_argument ( iarg, expid ) case ("-res") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, res ) + call get_command_argument ( iarg, res ) select case (res) case ("a") ires=1 @@ -194,37 +194,37 @@ subroutine Init_ ( drsfile, phyfile, bcsfile, dynftmpl, expid, & ires=4 case default print *, 'Sorry this resolutio not supported' - call exit(1) + error stop 1 end select in = ims(ires) jn = jms(ires) case ('-freq') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) freq case ('-prec') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) prec case ('-nlevs') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) kn if (count(kn==KMS).eq.0) then print *, 'Cannot handle this vertical number of levels' - call exit(1) + error stop 1 endif case ('-ntrac') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) ln if (count(ln==LMS).eq.0) then print *, 'Cannot handle this number of tracers' - call exit(1) + error stop 1 endif case default nfiles = nfiles + 1 @@ -282,7 +282,7 @@ subroutine usage() print * print *, ' Last updated: 30 Sep 2004; Todling ' print * - call exit(1) + error stop 1 end subroutine usage !------------------------------------------------------------------------- diff --git a/GMAO_hermes/dyn2drs.f90 b/GMAO_hermes/dyn2drs.f90 index 6a5b5a25..35373cba 100644 --- a/GMAO_hermes/dyn2drs.f90 +++ b/GMAO_hermes/dyn2drs.f90 @@ -68,7 +68,7 @@ program dyn2drs print *, ' Ozone not found in eta file' ! not really an error else print *, ' Cannot read eta file' - call exit (1) + error stop 1 endif end if @@ -83,7 +83,7 @@ program dyn2drs ! done if(verbose) print *, ' -- dyn2drs.x has successfully ended -- ' - call exit(0) + stop CONTAINS @@ -123,7 +123,7 @@ subroutine init ( etafile, binfile, pick, nymd, nhms, oldana, skipo3, verbose ) integer, parameter :: nfiles_max = 1 character(len=255) :: infile(nfiles_max) character*4, parameter :: myname = 'init' - integer :: i,argc,iarg,iargc,nfiles,leta + integer :: i,argc,iarg,nfiles,leta character*255 :: argv ! defaults @@ -134,14 +134,14 @@ subroutine init ( etafile, binfile, pick, nymd, nhms, oldana, skipo3, verbose ) verbose = .false. skipo3 = .false. - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() nfiles = 0 iarg = 0 lp: do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit lp - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if (index(argv,'-oldana') .gt. 0 ) then oldana = .TRUE. elseif (index(argv,'-verbose') .gt. 0 ) then @@ -151,16 +151,16 @@ subroutine init ( etafile, binfile, pick, nymd, nhms, oldana, skipo3, verbose ) elseif (index(argv,'-pick') .gt. 0 ) then if ( iarg+2 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nymd iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nhms pick = .true. elseif (index(argv,'-o') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, binfile ) + call get_command_argument ( iArg, binfile ) else nfiles = nfiles + 1 if ( nfiles .gt. nfiles_max ) then diff --git a/GMAO_hermes/dyn2dyn.f90 b/GMAO_hermes/dyn2dyn.f90 index d89c4fd5..93b4151c 100644 --- a/GMAO_hermes/dyn2dyn.f90 +++ b/GMAO_hermes/dyn2dyn.f90 @@ -200,7 +200,7 @@ program dyn2dyn ! All done ! -------- if(associated(xtrnames)) deallocate(xtrnames) - call exit(0) + stop CONTAINS @@ -272,7 +272,7 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & character*4, parameter :: myname = 'init' - integer iret, i, iarg, argc, iargc + integer iret, i, iarg, argc integer ii,jj,ie,il integer im_usr,jm_usr integer uprec, iprec, ires, jcapusr @@ -333,7 +333,7 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & ! Parse command line ! ------------------ dynfile = 'DEFAULT' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg = 0 @@ -342,30 +342,30 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-vdc") dophys = .true. case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, dynfile ) + call get_command_argument ( iarg, dynfile ) case ("-lwi") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, lwifile ) + call get_command_argument ( iarg, lwifile ) case ("-rc") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, RCfile ) + call get_command_argument ( iarg, RCfile ) case ("-expid") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, expid ) + call get_command_argument ( iarg, expid ) case ("-res") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, res ) + call get_command_argument ( iarg, res ) select case (res) case ("a") ires=1 @@ -382,10 +382,10 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & case ("u") ! user specified ires=99 iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) read(argv,*) im_usr iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) read(argv,*) jm_usr case ("x") ires=size(IMS5)-2 @@ -395,13 +395,13 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & ires=size(IMS5) case default print *, 'Sorry this resolution not supported' - call exit(1) + error stop 1 end select setres = .true. case ("-jcap") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) jcapusr select case (jcapusr) case (62) @@ -418,7 +418,7 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & ires=6 case default print *, 'Sorry this resolution not supported' - call exit(1) + error stop 1 end select setjcap = .true. case ('-verb') @@ -434,38 +434,38 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & case ('-nlevs') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) kn if (count(kn==KMS).eq.0) then print *, 'Cannot handle this vertical number of levels' - call exit(1) + error stop 1 endif case ('-tracers') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, trnames ) + call get_command_argument ( iarg, trnames ) case ('-pick') if ( iarg+2 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nymd iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nhms pick = .true. case ('-fakedate') if ( iarg+2 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nymdf iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nhmsf fakedate = .true. case ('-freq') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) myfreq case ('-indxlevs') indxlevs = .true. @@ -479,11 +479,11 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & case ("-phfile") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, phfile ) + call get_command_argument( iarg, phfile ) case ('-prec') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) iprec if(iprec==32)prec=0 if(iprec==64)prec=1 @@ -641,7 +641,7 @@ subroutine usage() print * print *, ' Last updated: 05 Jan 2006; Todling ' print * - call exit(1) + error stop 1 end subroutine usage !................................................................. @@ -649,7 +649,7 @@ end subroutine usage subroutine die ( myname, msg ) character(len=*) :: myname, msg write(*,'(a)') trim(myname) // ': ' // trim(msg) - call exit(1) + error stop 1 end subroutine die !................................................................. diff --git a/GMAO_hermes/dyn2prs.f90 b/GMAO_hermes/dyn2prs.f90 index e2fb486e..7ea6994d 100644 --- a/GMAO_hermes/dyn2prs.f90 +++ b/GMAO_hermes/dyn2prs.f90 @@ -223,7 +223,7 @@ program dyn2prs ! All done ! -------- - call exit(0) + stop CONTAINS @@ -266,7 +266,7 @@ subroutine Init_ ( mfiles, etafiles, nfiles, prsfile, & character*4, parameter :: myname = 'init' - integer i, iarg, argc, iargc + integer i, iarg, argc character(len=255) :: etafile, argv print * @@ -278,7 +278,7 @@ subroutine Init_ ( mfiles, etafiles, nfiles, prsfile, & ! Parse command line ! ------------------ prsfile = 'dyn.prs.hdf' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg = 0 @@ -291,32 +291,32 @@ subroutine Init_ ( mfiles, etafiles, nfiles, prsfile, & do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-South") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv, *) ySouth if (ySouth .ne. 90. .and. ySouth .ne. -90.) call usage() case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, prsfile ) + call get_command_argument ( iarg, prsfile ) case ("-im") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv, *) imOut case ("-jm") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv, *) jmOut case ("-West") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv, *) xWest if (xWest .gt. 0.0) xWest = xWest - 360. case default @@ -388,7 +388,7 @@ subroutine usage() print *, '-etafile(s) input dynamics vector file in' print *, ' hybrid (eta) coordinates' print * - call exit(1) + error stop 1 end subroutine usage !................................................................. @@ -396,7 +396,7 @@ end subroutine usage subroutine die ( myname, msg ) character(len=*) :: myname, msg write(*,'(a)') trim(myname) // ': ' // trim(msg) - call exit(1) + error stop 1 end subroutine die !................................................................. diff --git a/GMAO_hermes/dyn2real_eta.f90 b/GMAO_hermes/dyn2real_eta.f90 index 0dc2a214..c7954d18 100644 --- a/GMAO_hermes/dyn2real_eta.f90 +++ b/GMAO_hermes/dyn2real_eta.f90 @@ -59,9 +59,9 @@ program dyn2real_eta subroutine init_ -integer :: argc,iarg,iargc +integer :: argc,iarg -argc = iargc() +argc = command_argument_count() if ( argc < 1 ) then print * print *, "Usage: dyn_realeta.x dyn_input dyn_output" @@ -70,9 +70,9 @@ subroutine init_ endif iarg = 1 -call GetArg ( iarg, files(1) ) +call get_command_argument ( iarg, files(1) ) iarg = iarg + 1 -call GetArg ( iarg, files(2) ) +call get_command_argument ( iarg, files(2) ) end subroutine init_ diff --git a/GMAO_hermes/dyn2rs5.f90 b/GMAO_hermes/dyn2rs5.f90 index 69e45d36..d31e7fd5 100644 --- a/GMAO_hermes/dyn2rs5.f90 +++ b/GMAO_hermes/dyn2rs5.f90 @@ -67,7 +67,7 @@ program main character*120, allocatable :: arg(:) character*8 date character*2 hour - integer n,nargs,iargc,i,j,L,ID,rc + integer n,nargs,i,j,L,ID,rc ! ********************************************************************** ! **** Initialize Filenames **** @@ -84,11 +84,11 @@ program main nymd_ana = -999 nhms_ana = -999 - nargs = iargc() + nargs = command_argument_count() if(nargs==0) call usage() allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) call usage() @@ -406,5 +406,5 @@ subroutine usage() print *, " moist_internal_restart.ana.yyyymmdd_hhz" print *, " pchem_internal_restart.ana.yyyymmdd_hhz" print * - call exit(7) + error stop 7 end diff --git a/GMAO_hermes/dyn52dyn.f90 b/GMAO_hermes/dyn52dyn.f90 index 7e3b9e99..9783ab3e 100755 --- a/GMAO_hermes/dyn52dyn.f90 +++ b/GMAO_hermes/dyn52dyn.f90 @@ -52,7 +52,7 @@ program main character*120, allocatable :: arg(:) character*8 date character*2 hour - integer n,nargs,iargc,i,j,L + integer n,nargs,i,j,L integer id,rc,timinc,nmax,kbeg,kend,freq integer ntime,nvars,ngatts @@ -67,11 +67,11 @@ program main freq = 6 ! default: frequency of bkg is 6-hrs - nargs = iargc() + nargs = command_argument_count() if(nargs==0) call usage() allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) call usage() @@ -461,6 +461,6 @@ subroutine usage() print *, " -prec PREC where PREC=32 or 64 for 32 or 64 bits output" print *, " -freq FREQ specify frequency of background; default: 6 (hr)" print * - call exit(7) + error stop 7 end diff --git a/GMAO_hermes/dyn_blob.f90 b/GMAO_hermes/dyn_blob.f90 index 9dcd97e5..416ac4fc 100644 --- a/GMAO_hermes/dyn_blob.f90 +++ b/GMAO_hermes/dyn_blob.f90 @@ -7,6 +7,8 @@ program dyn_blob use m_const, only: radius_earth use m_die, only: die +use iso_fortran_env + implicit none character(len=*), parameter :: fname = 'bkg.eta.nc4' @@ -99,7 +101,7 @@ program dyn_blob subroutine wrtout_(lu,fld) integer, intent(in) :: lu real, intent(in) :: fld(:,:) - real(4),allocatable:: fld4(:,:) + real(REAL32),allocatable:: fld4(:,:) integer myim,myjm,ndim myim=size(fld,1) myjm=size(fld,2) @@ -115,7 +117,7 @@ end subroutine wrtout_ subroutine readin_(lu,fld) integer, intent(in) :: lu real, intent(in) :: fld(:,:) - real(4),allocatable:: fld4(:,:) + real(REAL32),allocatable:: fld4(:,:) integer myim,myjm,ndim myim=size(fld,1) myjm=size(fld,2) @@ -366,9 +368,9 @@ subroutine lon_shift(field,im,jm) integer, intent(in) :: im integer, intent(in) :: jm - real(4), intent(inout) :: field(im,jm) + real(REAL32), intent(inout) :: field(im,jm) integer i, j - real(4) tmp + real(REAL32) tmp do j = 1, jm do i = 1, im/2 diff --git a/GMAO_hermes/dyn_boot.f90 b/GMAO_hermes/dyn_boot.f90 index f6ddda56..682bd9b8 100644 --- a/GMAO_hermes/dyn_boot.f90 +++ b/GMAO_hermes/dyn_boot.f90 @@ -25,14 +25,14 @@ program dyn_boot call dyn_init ( idyn, odyn, ier, copy=.true., vectype=vectype, lm=lm ) if ( ier/=0 ) then print *, trim(myname), ': Error duplicating dyn vector(odyn), ier=', ier - call exit(998) + error stop 998 endif print *, 'writing to: ', ofile call dyn_put ( ofile, nymd, nhms, prec, odyn, ier, freq=freq, nstep=nstep, vectype=vectype ) if ( ier .ne. 0 ) then print *, trim(myname), ': cannot write interpolated ETA file' - call exit(999) + error stop 999 endif call dyn_clean ( odyn ) diff --git a/GMAO_hermes/dyn_cov.f90 b/GMAO_hermes/dyn_cov.f90 index cd2239ed..26b5e8e9 100644 --- a/GMAO_hermes/dyn_cov.f90 +++ b/GMAO_hermes/dyn_cov.f90 @@ -259,7 +259,7 @@ program dyn_cov subroutine init_() implicit none - integer i, iarg, argc, iargc + integer i, iarg, argc integer ncount,nc character(len=255) :: argv real corrlen @@ -272,7 +272,7 @@ subroutine init_() adrate = -9999. corrlen = 800. ! to be read from file - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg=0 @@ -280,43 +280,43 @@ subroutine init_() do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ('-fcstlen') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) fcstlen case ('-mem') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) members case ('-adrate') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) adrate case ('-corrlen') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) corrlen case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) ofile(1) = trim(argv) case ("-ox") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) ofile(2) = trim(argv) case ('-nolocal') @@ -328,10 +328,10 @@ subroutine init_() case default ncount = ncount + 1 if (ncount==1) then - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nymd(1) else if (ncount==2 ) then - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nhms(1) else nc=nc+1 @@ -396,7 +396,7 @@ subroutine usage() print *, ' 1. This program requires error files to have been generated' print *, ' prior to attempting to run it. E.g., see dyndiff.x' print * - call exit(1) + error stop 1 end subroutine usage subroutine globeloc (aloc,lat,lon) diff --git a/GMAO_hermes/dyn_efsens.f90 b/GMAO_hermes/dyn_efsens.f90 index 2ffb4388..f28b9b91 100644 --- a/GMAO_hermes/dyn_efsens.f90 +++ b/GMAO_hermes/dyn_efsens.f90 @@ -153,7 +153,7 @@ program dyn_efsens subroutine init_() implicit none - integer i, iarg, argc, iargc + integer i, iarg, argc integer ncount,nc character(len=255) :: argv real corrlen @@ -168,7 +168,7 @@ subroutine init_() ofile = 'efsens.eta.nc4' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg=0 @@ -176,37 +176,37 @@ subroutine init_() do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ('-fcstlen') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) fcstlen case ('-mem') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) members case ('-adrate') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) adrate case ('-corrlen') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) corrlen case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) ofile = trim(argv) case ('-nolocal') @@ -218,10 +218,10 @@ subroutine init_() case default ncount = ncount + 1 if (ncount==1) then - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nymd(1) else if (ncount==2 ) then - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nhms(1) else nc=nc+1 @@ -291,7 +291,7 @@ subroutine usage() print *, ' 1. This program requires error files to have been generated' print *, ' prior to attempting to run it. E.g., see dyndiff.x' print * - call exit(1) + error stop 1 end subroutine usage subroutine globeloc (aloc,lat,lon) diff --git a/GMAO_hermes/dyn_fsens_conv.f90 b/GMAO_hermes/dyn_fsens_conv.f90 index e2ac6989..11fe95e1 100644 --- a/GMAO_hermes/dyn_fsens_conv.f90 +++ b/GMAO_hermes/dyn_fsens_conv.f90 @@ -11,7 +11,7 @@ program dyn_fsens_conv integer,parameter :: dyntype=5 integer,parameter :: nfiles=2 integer nymd, nhms, lu, n, freq, vectype, prec, ier, nstep - integer i, nf, iarg, argc, ndim2, ndim3, intarg, iargc + integer i, nf, iarg, argc, ndim2, ndim3, intarg character(len=255) :: ofile character(len=255) :: dynfile(nfiles) character(len=255) argv @@ -31,20 +31,20 @@ program dyn_fsens_conv verbose = .false. iarg=0 - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) call usage_() nf=0 do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (trim(argv)) case ("-verbose") verbose = .true. case ("-o") if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iarg, ofile ) + call get_command_argument ( iarg, ofile ) case default nf = nf + 1 if ( nf .gt. nfiles ) call die(myname,'too many eta files:',nf) diff --git a/GMAO_hermes/dyn_hydro.f90 b/GMAO_hermes/dyn_hydro.f90 index 57dedf9e..7671392e 100644 --- a/GMAO_hermes/dyn_hydro.f90 +++ b/GMAO_hermes/dyn_hydro.f90 @@ -46,7 +46,7 @@ subroutine init_ (rc) character(len=256) :: argv integer argc,i,iarg,iargc,nfiles rc=0 - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) then rc=-1 return @@ -61,7 +61,7 @@ subroutine init_ (rc) do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) select case (argv) case ("-o") if ( iarg+1 .gt. argc ) then @@ -69,7 +69,7 @@ subroutine init_ (rc) return endif iarg = iarg + 1 - call GetArg ( iarg, odyn_file ) + call get_command_argument( iarg, odyn_file ) case default nfiles = nfiles + 1 if ( nfiles .gt. mfiles ) call die(myname_,': too many eta files') diff --git a/GMAO_hermes/dyn_inflate.f90 b/GMAO_hermes/dyn_inflate.f90 index 4cab7038..bf7766d9 100644 --- a/GMAO_hermes/dyn_inflate.f90 +++ b/GMAO_hermes/dyn_inflate.f90 @@ -56,7 +56,7 @@ program dyn_inflate if(.not.allocated(ainf)) then print *, 'ainf not defined, aborting ...' - call exit(99) + error stop 99 endif do iv=1,size(vars) if(trim(vars(iv))=='u')then @@ -189,7 +189,7 @@ subroutine init_ (dyntype,files) character(len=*),intent(out) :: files(:) character(len=*), parameter :: myname='init_' - integer iret, i, iarg, argc, iargc + integer iret, i, iarg, argc integer irow,nlevs, ier, nfiles, iv, nivars character(len=255) :: argv character(len=255) :: token @@ -204,14 +204,14 @@ subroutine init_ (dyntype,files) ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() nfiles=0 iarg=0 do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-g4") @@ -219,11 +219,11 @@ subroutine init_ (dyntype,files) case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, ofile ) + call get_command_argument ( iArg, ofile ) case ("-rc") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, RCfile ) + call get_command_argument ( iArg, RCfile ) case default nfiles = nfiles + 1 if ( nfiles .gt. mfiles ) call usage() @@ -253,7 +253,7 @@ subroutine init_ (dyntype,files) nlevs = I90_GInt(iret) else write(stderr,'(2a,i5)') trim(myname),': cannot determine no. of levels, aborting ... ' - call exit(1) + error stop 1 end if write(stdout,'(2a,i5)') trim(myname),': number of inflation vertical levels = ', nlevs @@ -287,7 +287,7 @@ subroutine init_ (dyntype,files) if (iret/=0) then write(stderr,'(2a,i5,2a)') myname, ': I90_label error, iret=', iret, & ': trying to read ', trim(tablename) - call exit(2) + error stop 2 end if irow = 0 write(stdout,'(3a)') ' Reading vertically varying inflation ', trim(vars(iv)), '...' @@ -299,19 +299,19 @@ subroutine init_ (dyntype,files) call I90_GToken(token, ier ) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot read 1st entry in table, aborting ...' - call exit(3) + error stop 3 endif call I90_GToken(token, ier ) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot read 2nd entry in table, aborting ...' - call exit(4) + error stop 4 endif read(token,*) ainf(irow,iv) end if end do if(irow/=nlevs) then write(stderr,'(2a,i5)') trim(myname),': inconsistent number of levels in table, aborting ...' - call exit(4) + error stop 4 endif end do ! iv @@ -322,7 +322,7 @@ subroutine init_ (dyntype,files) ainf_ps = I90_GFloat(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot addinf_coeff(ps), aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get addinf_coeff(ps) from RC, using default ... ' @@ -336,7 +336,7 @@ subroutine init_ (dyntype,files) ainf_ts = I90_GFloat(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot addinf_coeff(ts), aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get addinf_coeff(ts) from RC, using default ... ' @@ -350,7 +350,7 @@ subroutine init_ (dyntype,files) pkthresh = I90_GFloat(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot pkthresh, aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get pthreshold from RC, using default ... ' @@ -377,7 +377,7 @@ subroutine init_ (dyntype,files) m_star = I90_GInt(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot adaptive_smooth_factor(), aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get adaptive_smooth_factor() from RC, no smoothing ... ' @@ -399,7 +399,7 @@ subroutine init_ (dyntype,files) print * else print *, 'not enough input files, aborting ...' - call exit(1) + error stop 1 endif end subroutine init_ @@ -471,7 +471,7 @@ subroutine usage() print *, ' xm_a - ensemble mean analysis file' print *, ' xs_b - ensemble background spread file' print * - call exit(1) + error stop 1 end subroutine usage diff --git a/GMAO_hermes/dyn_iupd.F90 b/GMAO_hermes/dyn_iupd.F90 index 2f69c255..a027195d 100644 --- a/GMAO_hermes/dyn_iupd.F90 +++ b/GMAO_hermes/dyn_iupd.F90 @@ -128,10 +128,10 @@ program dyn_iupd subroutine init_ integer, parameter :: mfiles=2 - integer iargc,argc,nfiles,iarg,i + integer argc,nfiles,iarg,i character(len=256) str,argv - argc = iargc() + argc = command_argument_count() if ( argc < 2 ) then print *, "Usage: dyn_iupd.x [-scale SCALE] finput foutput" print *, " " @@ -144,7 +144,7 @@ subroutine init_ do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ('-scale') if ( iarg+1 .gt. argc ) then @@ -152,7 +152,7 @@ subroutine init_ stop endif iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) rscale case default nfiles = nfiles + 1 diff --git a/GMAO_hermes/dyn_jediupd.f90 b/GMAO_hermes/dyn_jediupd.f90 index fb7ecce6..da284e65 100644 --- a/GMAO_hermes/dyn_jediupd.f90 +++ b/GMAO_hermes/dyn_jediupd.f90 @@ -39,7 +39,7 @@ program dyn_jediupd if ( rc .ne. 0 ) then ! call die(myname,'cannot read background file') print *, myname,'cannot read background file' - call exit(1) + stop 1 else print *, trim(myname), ': read background ', trim(files(1)) end if @@ -62,7 +62,7 @@ program dyn_jediupd x_a%grid%bk, vectype=dyntype ) if ( size(y_i%t,1)/=nlon .or. size(y_i%t,2)/=nlat ) then print *, myname,'field transpose in unexpected way' - call exit(1) + stop 1 endif print *, 'sum(ts) = ', sum(y_i%ts) x_x%ts = y_i%ts @@ -122,7 +122,7 @@ program dyn_jediupd enddo if (any(x_a%delp<0.0)) then print *, myname, 'unacceptable delp' - call exit(1) + stop 1 endif t = t + x_i%pt x_a%u = x_a%u + x_i%u @@ -139,7 +139,7 @@ program dyn_jediupd if ( rc .ne. 0 ) then ! call die(myname,'cannot write analysis file') print *, myname,'cannot write analysis file' - call exit(1) + stop 1 else print *, trim(myname), ': wrote analysis ', trim(files(3)) end if @@ -160,7 +160,7 @@ subroutine init_() dyntype = 5 outinc = 'NULL' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage_() iarg=0 @@ -168,7 +168,7 @@ subroutine init_() do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) select case (argv) case ('-verb') @@ -177,21 +177,21 @@ subroutine init_() case ("-o") if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iarg, outinc ) + call get_command_argument( iarg, outinc ) case default ncount = ncount + 1 if (ncount==1) then - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) read(argv,*) nymd else if (ncount==2 ) then - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) read(argv,*) nhms else nc=nc+1 if(nc .gt. 3) then ! call die(myname,'too many cases') print *, myname,'too many cases' - call exit(1) + stop 1 endif files(nc) = trim(argv) endif diff --git a/GMAO_hermes/dyn_ncf2dyn.f90 b/GMAO_hermes/dyn_ncf2dyn.f90 index c2b2803a..408a001f 100644 --- a/GMAO_hermes/dyn_ncf2dyn.f90 +++ b/GMAO_hermes/dyn_ncf2dyn.f90 @@ -59,9 +59,9 @@ subroutine init_ (rc) character(len=*),parameter :: myname_ = 'init_' character(len=256) :: argv - integer argc,i,iarg,iargc,nfiles + integer argc,i,iarg,nfiles rc=0 - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) then rc=-1 return @@ -76,7 +76,7 @@ subroutine init_ (rc) do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-o") if ( iarg+1 .gt. argc ) then @@ -84,7 +84,7 @@ subroutine init_ (rc) return endif iarg = iarg + 1 - call GetArg ( iarg, odyn_file ) + call get_command_argument ( iarg, odyn_file ) case default nfiles = nfiles + 1 if ( nfiles .gt. mfiles ) call die(myname_,': too many eta files') diff --git a/GMAO_hermes/dyn_pert_remap.F90 b/GMAO_hermes/dyn_pert_remap.F90 index a10e00ff..1bb7d12d 100644 --- a/GMAO_hermes/dyn_pert_remap.F90 +++ b/GMAO_hermes/dyn_pert_remap.F90 @@ -23,14 +23,13 @@ program dyn_pert_remap character(len=255) argv character(len=3) opt - integer iargc integer iarg,argc,nymd,nhms,freq integer im,jm integer ierr integer idim,odim real dotp0(1),dotp1(1),dotp2(1) !,ddot_ - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) then print * print *, "Purpose: interpolate perturbation vector." @@ -48,17 +47,17 @@ program dyn_pert_remap end if iarg = 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) im iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) jm iarg = iarg + 1 - call GetArg ( iarg, opt ) + call get_command_argument ( iarg, opt ) iarg = iarg + 1 - call GetArg ( iarg, ifile ) + call get_command_argument ( iarg, ifile ) iarg = iarg + 1 - call GetArg ( iarg, ofile ) + call get_command_argument ( iarg, ofile ) ! read input dyn vector ! --------------------- @@ -76,7 +75,7 @@ program dyn_pert_remap idyn%grid%ptop, idyn%grid%ks, idyn%grid%ak, idyn%grid%bk, vectype=5 ) if(ierr/=0)then print *, 'trouble in init ', ierr - call exit(99) + error stop 99 endif if ( opt == 'ppm' ) then @@ -97,7 +96,7 @@ program dyn_pert_remap idyn%grid%ptop, idyn%grid%ks, idyn%grid%ak, idyn%grid%bk, vectype=5 ) if(ierr/=0)then print *, 'trouble in init ', ierr - call exit(99) + error stop 99 endif idim = idyn%grid%im * idyn%grid%jm * idyn%grid%km odim = odyn%grid%im * odyn%grid%jm * odyn%grid%km diff --git a/GMAO_hermes/dyn_rankhist.F90 b/GMAO_hermes/dyn_rankhist.F90 index 0c2c517a..5e04e1b7 100644 --- a/GMAO_hermes/dyn_rankhist.F90 +++ b/GMAO_hermes/dyn_rankhist.F90 @@ -247,7 +247,7 @@ program dyn_rankhist print*, 'Error: something is not adding up' print*, 'sum(hist) = ', sum(hist) print*, 'total samples = ', icnt - call exit(1) + error stop 1 endif print *, 'total number of samples: ', icnt write(fnout,'(2a,i3.3,2a)') & @@ -278,7 +278,7 @@ program dyn_rankhist close(999) open (999,file='DYN_RANKHIST',form='formatted') close(999) - call exit(0) + stop CONTAINS @@ -320,7 +320,7 @@ subroutine Init_ ( dyntype, mfiles, files, members, seed, mean, sigma, & character*4, parameter :: myname = 'init' - integer i, iarg, argc, iargc + integer i, iarg, argc character(len=255) :: argv files = 'NONE' @@ -343,7 +343,7 @@ subroutine Init_ ( dyntype, mfiles, files, members, seed, mean, sigma, & ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg = 0 @@ -352,7 +352,7 @@ subroutine Init_ ( dyntype, mfiles, files, members, seed, mean, sigma, & do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-g5") @@ -360,39 +360,39 @@ subroutine Init_ ( dyntype, mfiles, files, members, seed, mean, sigma, & case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, dyn_out ) + call get_command_argument ( iArg, dyn_out ) case ("-mem") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) members case ("-plev") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) plev case ("-normal") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) mean if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) sigma case ("-reg") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, reg ) + call get_command_argument ( iArg, reg ) case ("-seed") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) seed case ("-var") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, var ) + call get_command_argument ( iArg, var ) case ("-h") if ( iarg+1 .gt. argc ) call usage() case ("-verbose") @@ -449,7 +449,7 @@ subroutine usage() print * print *, ' Remarks: ' print * - call exit(1) + error stop 1 end subroutine usage !................................................................. diff --git a/GMAO_hermes/dyn_recenter.f90 b/GMAO_hermes/dyn_recenter.f90 index ba5f508e..20e9f7b8 100644 --- a/GMAO_hermes/dyn_recenter.f90 +++ b/GMAO_hermes/dyn_recenter.f90 @@ -28,6 +28,8 @@ program dyn_recenter use m_inpak90 use m_stdio, only : stdout,stderr + use iso_fortran_env + implicit NONE ! !DESCRIPTION: Used in context of ensemble DAS to recenter dyn-vector @@ -111,8 +113,8 @@ program dyn_recenter integer ks integer lm_mean,lm_pert,lm_central real pabove,pbelow,pkthresh,alpha - real(8) ptop,pint - real(8),allocatable:: ak(:),bk(:) + real(REAL64) ptop,pint + real(REAL64),allocatable:: ak(:),bk(:) real,allocatable:: phis(:,:) real,pointer:: frocean(:,:) real,pointer:: ainf(:,:) @@ -511,7 +513,7 @@ program dyn_recenter close(999) open (999,file='DYNRECENTER_EGRESS',form='formatted') close(999) - call exit(0) + stop CONTAINS @@ -557,7 +559,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & character*4, parameter :: myname = 'init' - integer iret, i, iarg, argc, iargc + integer iret, i, iarg, argc integer irow,nlevs, ier, iv, nivars character(len=255) :: argv character(len=255) :: token @@ -590,7 +592,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg = 0 @@ -599,7 +601,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-g5") @@ -607,16 +609,16 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, dyn_out ) + call get_command_argument ( iArg, dyn_out ) case ("-a") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) alpha case ("-inflate") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, dyn_inflate ) + call get_command_argument ( iArg, dyn_inflate ) case ("-h") if ( iarg+1 .gt. argc ) call usage() case ("-verbose") @@ -633,7 +635,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & case ("-rc") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, RCfile ) + call get_command_argument ( iArg, RCfile ) case default nfiles = nfiles + 1 if ( nfiles .gt. mfiles ) call usage() @@ -675,7 +677,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & nlevs = I90_GInt(iret) else write(stderr,'(2a,i5)') trim(myname),': cannot determine no. of levels, aborting ... ' - call exit(1) + error stop 1 end if ! Read in ocean-only option @@ -721,7 +723,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & if (iret/=0) then write(stderr,'(2a,i5,2a)') myname, ': I90_label error, iret=', iret, & ': trying to read ', trim(tablename) - call exit(2) + error stop 2 end if irow = 0 write(stdout,'(a)') ' Reading vertically varying inflation ...' @@ -733,19 +735,19 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & call I90_GToken(token, ier ) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot read 1st entry in table, aborting ...' - call exit(3) + error stop 3 endif call I90_GToken(token, ier ) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot read 2nd entry in table, aborting ...' - call exit(4) + error stop 4 endif read(token,*) ainf(irow,iv) end if end do if(irow/=nlevs) then write(stderr,'(2a,i5)') trim(myname),': inconsistent number of levels in table, aborting ...' - call exit(4) + error stop 4 endif end do ! iv @@ -756,7 +758,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & ainf_ps = I90_GFloat(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot addinf_coeff(ps), aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get addinf_coeff(ps) from RC, using default ... ' @@ -770,7 +772,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & ainf_ts = I90_GFloat(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot addinf_coeff(ts), aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get addinf_coeff(ts) from RC, using default ... ' @@ -784,7 +786,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & pkthresh = I90_GFloat(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot pkthresh, aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get pthreshold from RC, using default ... ' @@ -870,7 +872,7 @@ subroutine usage() print *, ' for this - indeed one might need to do this using ESMF' print *, ' to better handle high-resolution fields.' print * - call exit(1) + error stop 1 end subroutine usage !................................................................. @@ -1065,7 +1067,7 @@ end subroutine my_sscal_ subroutine die ( myname, msg ) character(len=*) :: myname, msg write(*,'(a)') trim(myname) // ': ' // trim(msg) - call exit(1) + error stop 1 end subroutine die !................................................................. @@ -1172,7 +1174,7 @@ subroutine vinter_pert_ (xpi,xpo,ak,bk,dyntype,rc) type(dyn_vect) :: xpi ! input vector type(dyn_vect) :: xpo ! output vector - real(8), intent(in) :: ak(:),bk(:) + real(REAL64), intent(in) :: ak(:),bk(:) integer,intent(in) :: dyntype integer,intent(out) :: rc diff --git a/GMAO_hermes/dyndiff.f90 b/GMAO_hermes/dyndiff.f90 index 2587e732..ebad996f 100644 --- a/GMAO_hermes/dyndiff.f90 +++ b/GMAO_hermes/dyndiff.f90 @@ -14,6 +14,7 @@ program dyndiff use m_dyn use m_dyn_util, only: Dyn_Util_Tv2T use m_dyn_util, only: Dyn_Scale_by_TotEne + use iso_fortran_env use m_dyn_util, only: Dyn_Get_Energy implicit NONE @@ -60,7 +61,7 @@ program dyndiff integer ios, rc, iopt, ifile integer ntimes, n, freq, nymd, nhms, prec integer freq_d, nymd_d, nhms_d, prec_d !Timetag for newly created diff in *.hdf format - integer im, jm, km, lm, system, dyntype, irh + integer im, jm, km, lm, dyntype, irh logical dominmax,verb,sbyene,tv2t integer addrh integer vnorm @@ -226,7 +227,7 @@ program dyndiff end do ! loop over files st = "rm -f " // trim(binfiles(1)) // " " // trim(binfiles(2)) - rc = system(st) ! rc == 0 for success + call execute_command_line(st,exitstat=rc) ! rc == 0 for success if (rc .ne. 0 ) then print *, "Unable to remove binary files." end if @@ -238,7 +239,7 @@ program dyndiff close(999) open (999,file=trim(egress),form='formatted') close(999) - call exit(0) + stop CONTAINS @@ -293,7 +294,7 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & character(len=256) :: rcfile character(len=255) :: etafile, argv - integer iret, i, iarg, argc, iargc + integer iret, i, iarg, argc real pnext logical dout logical invalid @@ -334,7 +335,7 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg = 0 @@ -343,7 +344,7 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-g5") @@ -353,26 +354,26 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & case ("-a") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) acoeff case ("-egress") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, egress ) + call get_command_argument ( iArg, egress ) case ("-o") dout = .true. if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, dyn_dout ) + call get_command_argument ( iArg, dyn_dout ) case ("-txt") dout = .true. if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, jnorm ) + call get_command_argument ( iArg, jnorm ) case ("-addrh") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) addrh case ("-tv2t") tv2t = .true. @@ -385,11 +386,11 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & case ("-ntype") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, ntype ) + call get_command_argument ( iArg, ntype ) case ("-rc") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, rcfile ) + call get_command_argument ( iArg, rcfile ) case default nfiles = nfiles + 1 if ( nfiles .gt. mfiles ) call usage() @@ -416,7 +417,7 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & call i90_loadf (trim(rcfile), iret) if( iret .ne. 0) then write(6,'(2a,i5)') myname_,': I90_loadf error, iret =',iret - call exit (1) + error stop 1 endif ! Read in norm type @@ -439,7 +440,7 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & eps_eer = I90_GFloat(iret) if( iret .ne. 0) then write(6,'(3a,i5)') myname_,': I90_GFloat error, ', ' iret =',iret - call exit (1) + error stop 1 end if end if write(6,'(a,1p,e13.6)') 'Ehrendorfer, Errico, and Raeder eps: ',eps_eer @@ -520,7 +521,7 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & if (iret .ne. 0) then write(6,'(2a,i5)') myname_, & ': I90_Gtoken error, iret =',iret - call exit(2) + error stop 2 end if end if @@ -593,7 +594,7 @@ subroutine usage() print *, ' for the fact that sometimes file1-file2 not possible, but' print *, ' file2-file1 is possible due to nc4-header issues' print *, ' 3. If addrh<0, mean rh is added to the file (serves BeCov code)' - call exit(1) + error stop 1 end subroutine usage !................................................................. @@ -601,7 +602,7 @@ end subroutine usage subroutine die ( myname, msg ) character(len=*) :: myname, msg write(*,'(a)') trim(myname) // ': ' // trim(msg) - call exit(1) + error stop 1 end subroutine die subroutine getrh_(rh,tv,qv,ps,ak,bk) @@ -612,7 +613,7 @@ subroutine getrh_(rh,tv,qv,ps,ak,bk) real,intent(out):: rh(:,:,:) real,intent(in) :: tv(:,:,:), qv(:,:,:), ps(:,:) real,intent(in) :: ak(:), bk(:) - real(4),allocatable :: tmp(:,:,:),pmk(:,:,:),qs(:,:,:) + real(REAL32),allocatable :: tmp(:,:,:),pmk(:,:,:),qs(:,:,:) integer i,j,k,kb select case (abs(addrh)) case (1) diff --git a/GMAO_hermes/dyndims.f b/GMAO_hermes/dyndims.f index d0b62935..b810b311 100644 --- a/GMAO_hermes/dyndims.f +++ b/GMAO_hermes/dyndims.f @@ -3,7 +3,7 @@ integer im, jm, km integer fid, rc - integer iarg, iargc, argc + integer iarg, argc character*255 fname, argv argc = command_argument_count() diff --git a/GMAO_hermes/dyndot.f90 b/GMAO_hermes/dyndot.f90 index c143eba5..1a8fd96e 100644 --- a/GMAO_hermes/dyndot.f90 +++ b/GMAO_hermes/dyndot.f90 @@ -7,7 +7,7 @@ program dyndot integer,parameter :: dyntype=5 integer,parameter :: nfiles=2 integer nymd, nhms, lu, n, freq, vectype, prec, ier, nstep - integer i, nf, iarg, argc, ndim2, ndim3, intarg, iargc + integer i, nf, iarg, argc, ndim2, ndim3, intarg character(len=255) :: dynfile(nfiles) character(len=255) argv type(dyn_vect) w_1 @@ -26,13 +26,13 @@ program dyndot adm=.false. pncf=.false. - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) call usage_() nf=0; iarg=0 do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-use_ps") use_ps = .true. @@ -45,11 +45,11 @@ program dyndot ! case ("-adm") ! if ( iarg+1 .gt. argc ) call usage_() ! iarg = iarg + 1 -! call GetArg ( iarg, argv ) +! call get_command_argument ( iarg, argv ) ! read(argv,*) intarg ! if(intarg>0) adm(1)=.true. ! iarg = iarg + 1 -! call GetArg ( iarg, argv ) +! call get_command_argument ( iarg, argv ) ! read(argv,*) intarg ! if(intarg>0) adm(2)=.true. case default diff --git a/GMAO_hermes/dynp.f90 b/GMAO_hermes/dynp.f90 index c9f7acba..d8c6e113 100644 --- a/GMAO_hermes/dynp.f90 +++ b/GMAO_hermes/dynp.f90 @@ -393,7 +393,7 @@ program dynp print *, '--------------------------' print * - call exit(0) + stop !................................................................................... @@ -429,7 +429,7 @@ subroutine init_ () !EOP !----------------------------------------------------------------------- - integer i, iarg, argc, iargc, ires + integer i, iarg, argc, ires character(len=255) argv logical sin, sout, pin, pout, geos4res, gsires @@ -451,23 +451,23 @@ subroutine init_ () dyn_sout = 'NONE' dyn_pout = 'NONE' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage_() iarg = 0 do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) select case ( argv ) case ("-pick") pick = .true. if ( iarg+2 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nymd_s iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nhms_s case ("-realp") realp = .true. @@ -494,7 +494,7 @@ subroutine init_ () case ("-res") if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, res ) + call get_command_argument ( iArg, res ) select case (res) case ("a") ires=1 @@ -508,38 +508,38 @@ subroutine init_ () ires=5 case default print *, 'Sorry this resolution not supported' - call exit(1) + error stop 1 end select interp = .true. case ("-os") sout = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_sout ) + call get_command_argument ( iArg, dyn_sout ) case ("-op") pout = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_pout ) + call get_command_argument ( iArg, dyn_pout ) case ("-s") sin = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_sin ) + call get_command_argument ( iArg, dyn_sin ) case ("-p") pin = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_pin ) + call get_command_argument ( iArg, dyn_pin ) case ("-a") if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) pcoef case ("-scale") if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) pscal end select end do @@ -670,7 +670,7 @@ subroutine die ( myname, msg ) print * print *, trim(myname) // ': ' // trim(msg) print * - call exit(1) + error stop 1 end subroutine die !....................................................................... diff --git a/GMAO_hermes/eta_echo.f90 b/GMAO_hermes/eta_echo.f90 index fea874a3..b69407af 100644 --- a/GMAO_hermes/eta_echo.f90 +++ b/GMAO_hermes/eta_echo.f90 @@ -2,17 +2,19 @@ program eta_echo use m_set_eta, only: set_eta use m_set_eta, only: get_ref_plevs use m_spline, only: spline +use iso_fortran_env use m_nc_akbk, only: write_nc_akbk + implicit none integer :: nlevs,mlevs integer :: k,km,ks,ii logical :: bot2top, lsingle, lplevs -real(8) :: ptop8, pint8 -real(8),allocatable :: ak8(:),bk8(:) -real(4),allocatable :: hloc(:),zloc(:),betac(:),betae(:) -real(4) :: ak4,bk4 -real(4) :: pbottom +real(REAL64) :: ptop8, pint8 +real(REAL64),allocatable :: ak8(:),bk8(:) +real(REAL32),allocatable :: hloc(:),zloc(:),betac(:),betae(:) +real(REAL32) :: ak4,bk4 +real(REAL32) :: pbottom character(len=255) :: locfname character(len=255) :: akbkfname @@ -38,9 +40,8 @@ program eta_echo subroutine init_ integer argc, iarg - integer iargc character(len=255) :: argv - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) then print *, "Usage: eta_echo.x [options] nlevs" print *, " " @@ -67,18 +68,18 @@ subroutine init_ mlevs=0 iarg = 1 do while (iarg<=argc) - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-bot2top") bot2top = .true. case ("-p0") iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) pbottom pbottom=pbottom*100. case ("-mlevs") iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) mlevs case ("-plevs") lplevs = .true. @@ -86,11 +87,11 @@ subroutine init_ lsingle = .true. case ("-loc") iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) locfname = trim(argv) case ("-nc") iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) akbkfname = trim(argv) case default read(argv,*) nlevs @@ -108,7 +109,7 @@ subroutine get_locs_ if(km/=nlevs) then print *, 'Inconsistent levels: km/nlevs', km, nlevs print *, 'Aborting ...' - call exit(1) + error stop 1 else do k=1,nlevs read(10,*) hloc(k), zloc(k), betac(k), betae(k) @@ -117,11 +118,11 @@ subroutine get_locs_ end subroutine get_locs_ subroutine write_plevs_ - real(8),allocatable :: levn(:) - real(8),allocatable :: levm(:) - real(8),allocatable :: xak(:),xbk(:) - real(4),allocatable :: hlocm(:), zlocm(:), betacm(:), betaem(:) - real(4),allocatable :: dp(:),dz(:),pe(:) + real(REAL64),allocatable :: levn(:) + real(REAL64),allocatable :: levm(:) + real(REAL64),allocatable :: xak(:),xbk(:) + real(REAL32),allocatable :: hlocm(:), zlocm(:), betacm(:), betaem(:) + real(REAL32),allocatable :: dp(:),dz(:),pe(:) integer :: ksm print* print*, "Ref. pressure levels" @@ -129,7 +130,7 @@ subroutine write_plevs_ allocate(levn(nlevs)) allocate(pe(nlevs+1),dp(nlevs),dz(nlevs)) if(pbottom>0.) then - call get_ref_plevs ( ak8, bk8, ptop8, levn, p0=real(pbottom,8) ) + call get_ref_plevs ( ak8, bk8, ptop8, levn, p0=real(pbottom,REAL64) ) pe(1)=ptop8 do k=1,nlevs dp(k) = (ak8(k+1)-ak8(k))+(pbottom-ptop8)*(bk8(k+1)-bk8(k)) @@ -164,31 +165,31 @@ subroutine write_plevs_ write(6,'(i5,3(2x,f20.10))') k,levn(k),dp(k),dz(k) enddo endif - call weights2grads_(real(levn(nlevs:1:-1),4),dp(nlevs:1:-1), dz(nlevs:1:-1)) + call weights2grads_(real(levn(nlevs:1:-1),REAL32),dp(nlevs:1:-1), dz(nlevs:1:-1)) else levn=levn(nlevs:1:-1) do k = 1, nlevs write(6,'(i5,2x,f20.10,2x,f7.1,3x,f4.1,2(3x,f7.4))') k,levn(k),hloc(k), zloc(k), betac(k), betae(k) enddo - call loc2grads_(real(levn,4),hloc, zloc, betac, betae) + call loc2grads_(real(levn,REAL32),hloc, zloc, betac, betae) if (mlevs>0) then allocate(levm(mlevs)) allocate(xak(mlevs+1),xbk(mlevs+1)) call set_eta ( mlevs, ksm, ptop8, pint8, xak, xbk ) if(pbottom>0.) then - call get_ref_plevs ( xak, xbk, ptop8, levm, p0=real(pbottom,8) ) + call get_ref_plevs ( xak, xbk, ptop8, levm, p0=real(pbottom,REAL64) ) else call get_ref_plevs ( xak, xbk, ptop8, levm ) endif deallocate(xak,xbk) allocate(hlocm(mlevs), zlocm(mlevs), betacm(mlevs), betaem(mlevs)) levm=levm(mlevs:1:-1) - call spline ( real(levn,4), real(levm,4), hloc, hlocm ) - call spline ( real(levn,4), real(levm,4), zloc, zlocm ) - call spline ( real(levn,4), real(levm,4), betac, betacm ) - call spline ( real(levn,4), real(levm,4), betae, betaem ) - call loc2grads_(real(levm,4),hlocm, zlocm, betacm, betaem) + call spline ( real(levn,REAL32), real(levm,REAL32), hloc, hlocm ) + call spline ( real(levn,REAL32), real(levm,REAL32), zloc, zlocm ) + call spline ( real(levn,REAL32), real(levm,REAL32), betac, betacm ) + call spline ( real(levn,REAL32), real(levm,REAL32), betae, betaem ) + call loc2grads_(real(levm,REAL32),hlocm, zlocm, betacm, betaem) write(6,*) write(6,*) do k = 1, mlevs @@ -236,7 +237,7 @@ end subroutine write_akbk_ subroutine loc2grads_(lev,hloc, zloc, betac, betae) use m_ioutil, only : luavail implicit none - real(4),intent(in) :: lev(:),hloc(:),zloc(:),betac(:),betae(:) + real(REAL32),intent(in) :: lev(:),hloc(:),zloc(:),betac(:),betae(:) integer lo,km character(len=80) :: fctl,fgrd lo=luavail() @@ -279,7 +280,7 @@ end subroutine loc2grads_ subroutine weights2grads_(lev,dp,dz) use m_ioutil, only : luavail implicit none - real(4),intent(in) :: lev(:),dp(:),dz(:) + real(REAL32),intent(in) :: lev(:),dp(:),dz(:) integer lo,km,ii character(len=80) :: fctl,fgrd lo=luavail() diff --git a/GMAO_hermes/extract_stations.F90 b/GMAO_hermes/extract_stations.F90 index 47498d9d..4b0dfbbb 100644 --- a/GMAO_hermes/extract_stations.F90 +++ b/GMAO_hermes/extract_stations.F90 @@ -23,7 +23,7 @@ Program extract_stations implicit NONE ! Command line inputs - integer iarg, iargc, argc + integer iarg, argc character(len=256) :: argv character(len=256) :: rcfile, inpTemplate, fname, outTemplate, & expid, forcefirstname @@ -76,7 +76,7 @@ Program extract_stations ! Parse the command line (see usage() below) - argc = iargc() + argc = command_argument_count() if(argc .lt. 1) call usage() iarg = 0 nymd = 20000101 @@ -463,7 +463,7 @@ subroutine usage() print *, ' one time per day if timestep is not specified' print *, ' Right now only deals with time steps in increments of hours' print * - call exit(1) + stop 1 end subroutine usage diff --git a/GMAO_hermes/fv2prs.F90 b/GMAO_hermes/fv2prs.F90 index 9118b20f..6929cf6f 100644 --- a/GMAO_hermes/fv2prs.F90 +++ b/GMAO_hermes/fv2prs.F90 @@ -484,7 +484,7 @@ Program fv2prs ! All done ! -------- - call exit(0) + stop 0 CONTAINS @@ -585,7 +585,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& !------------------------------------------------------------------------- integer iarg, argc - integer :: iargc + character(len=4096) argv, srfFile, bkgFile character(len=257) rcfile, label, var, Vars(mVars), tmp, tmp1 @@ -598,7 +598,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& real xWest, p logical :: debug = .false. - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) call usage_() ! Defaults @@ -3082,7 +3082,7 @@ subroutine comp_slp(im,jm,km,pt,phis,delp,pe,pm,cappa,grav,inField) end do if ( k_bot .lt. 2 ) then print *, ': got k_bot<2 while computing T_ref' - call exit(1) + stop 1 else k1 = k_bot - 1 k2 = k_bot diff --git a/GMAO_hermes/gcmbkg2ana.F b/GMAO_hermes/gcmbkg2ana.F index 2c0337ef..3b469b2a 100644 --- a/GMAO_hermes/gcmbkg2ana.F +++ b/GMAO_hermes/gcmbkg2ana.F @@ -24,7 +24,7 @@ program bkgeta_fix character*256, allocatable :: arg(:) character*256 input, output - integer n,m,nargs,iargc,L,nvars2 + integer n,m,nargs,L,nvars2 real plev real undef @@ -66,13 +66,13 @@ program bkgeta_fix C **** Read Command Line Arguments **** C ********************************************************************** - nargs = iargc() + nargs = command_argument_count() if( nargs.ne.3 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-o' ) output = arg(n+1) diff --git a/GMAO_hermes/geos2fv.f b/GMAO_hermes/geos2fv.f index 1aed8e65..50cca5c6 100644 --- a/GMAO_hermes/geos2fv.f +++ b/GMAO_hermes/geos2fv.f @@ -809,13 +809,13 @@ subroutine get_geos2 ( nymd, nhms, im, jm, km, call ProgSig_Dim ( trim(ifname), imf, jmf, kmf, ier ) if ( ier .ne. 0 ) then print *, 'get_geos2: cannot get dims from ', trim(ifname) - call exit(7) + error stop 7 stop else if ( km .ne. kmf ) then print *, 'get_geos2: imcompatible vertical dimensions' print *, 'get_geos2: km on file: ', kmf print *, 'get_geos2: km in here: ', km - call exit(7) + error stop 7 stop end if @@ -827,7 +827,7 @@ subroutine get_geos2 ( nymd, nhms, im, jm, km, & q2(in,jn,km), rh2(in,jn,km), stat = ier ) if ( ier .ne. 0 ) then print *, 'get_geos2: cannot allocate memory ' - call exit(7) + error stop 7 stop end if @@ -838,7 +838,7 @@ subroutine get_geos2 ( nymd, nhms, im, jm, km, & phis, ps2, u2, v2, t2, q2, rh2, ier ) if ( ier .ne. 0 ) then print *, 'getgeos2: cannot read ', trim(ifname) - call exit(7) + error stop 7 stop end if @@ -2862,7 +2862,7 @@ subroutine parse_cmd ( nymd, nhms, im, jm, nstep ) include 'geos2fv.h' integer im, jm, nstep - integer iarg, argc, iargc + integer iarg, argc character*255 argv, res ! defaults @@ -2885,7 +2885,7 @@ subroutine parse_cmd ( nymd, nhms, im, jm, nstep ) ! parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() narg = argc if ( argc .lt. 2 ) call usage() iarg = 0 @@ -3028,6 +3028,6 @@ subroutine usage() print *, 'Last update: Seg Dez 6 08:13:42 EST 1999' print * - call exit(7) + error stop 7 end diff --git a/GMAO_hermes/getgfiodim.f90 b/GMAO_hermes/getgfiodim.f90 index 9be89e4d..cb64bb22 100644 --- a/GMAO_hermes/getgfiodim.f90 +++ b/GMAO_hermes/getgfiodim.f90 @@ -4,19 +4,19 @@ program getgfiodim integer, parameter :: READ_ONLY = 1 character(len=255) fname, argv - integer iarg, iargc, argc + integer iarg, argc integer fid, err integer im, jm, km, lm, nvars, ngatts - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) then print * print *, "Usage: getgfiodim.x gfiofilename" print * - call exit(1) + error stop 1 endif iarg = 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) fname = trim(argv) ! Open the file @@ -24,7 +24,7 @@ program getgfiodim call GFIO_Open ( trim(fname), READ_ONLY, fid, err ) if ( err .ne. 0 ) then print *, 'cannot open file ' - call exit (2) + error stop 2 endif ! Get dimensions @@ -32,7 +32,7 @@ program getgfiodim call GFIO_DimInquire ( fid, im, jm, km, lm, nvars, ngatts, err) if ( err .ne. 0 ) then print *, 'cannot extra dimensions ' - call exit (3) + error stop 3 end if ! Close GFIO file diff --git a/GMAO_hermes/ibc_upd.F b/GMAO_hermes/ibc_upd.F index fa7ae320..b8a756ff 100644 --- a/GMAO_hermes/ibc_upd.F +++ b/GMAO_hermes/ibc_upd.F @@ -57,9 +57,6 @@ program ibc_upd character(len=255) :: vars, str ! vars - logical upd - upd ( str ) = ( index((vars),(str)) .gt. 0 ) - !....................................................................... call zeit_ci ( 'ibc_upd' ) @@ -141,12 +138,12 @@ program ibc_upd ! Estimate bias ! ------------- a = alpha - if ( upd('ts') ) b_f%Ts = b_f%Ts - a * (w_e%Ts - w_f%Ts) - if ( upd('u') ) b_f%u = b_f%u - a * (w_e%u - w_f%u) - if ( upd('v') ) b_f%v = b_f%v - a * (w_e%v - w_f%v) - if ( upd('pt') ) b_f%pt = b_f%pt - a * (w_e%pt - w_f%pt) - if ( upd('q') ) b_f%q = b_f%q - a * (w_e%q - w_f%q) - if ( upd('delp') ) b_f%delp = b_f%delp - a * (w_e%delp - w_f%delp) + if ( upd('ts',vars) ) b_f%Ts = b_f%Ts - a * (w_e%Ts - w_f%Ts) + if ( upd('u',vars) ) b_f%u = b_f%u - a * (w_e%u - w_f%u) + if ( upd('v',vars) ) b_f%v = b_f%v - a * (w_e%v - w_f%v) + if ( upd('pt',vars) ) b_f%pt = b_f%pt - a * (w_e%pt - w_f%pt) + if ( upd('q',vars) ) b_f%q = b_f%q - a * (w_e%q - w_f%q) + if ( upd('delp',vars) ) b_f%delp = b_f%delp - a * (w_e%delp - w_f%delp) ! Write out the updated bias ! -------------------------- @@ -178,7 +175,7 @@ program ibc_upd print *, 'ibc_upd: successfully completed' - call exit(0) + stop !................................................................................... @@ -224,7 +221,7 @@ subroutine Init_ ( dyn_f, dyn_b, dyn_a, out_a, remap, restart, character(len=*), parameter :: myname = 'init' - integer i, iarg, argc, iargc, n + integer i, iarg, argc, n character(len=255) argv, prefix print * @@ -246,7 +243,7 @@ subroutine Init_ ( dyn_f, dyn_b, dyn_a, out_a, remap, restart, alpha = 0.1 out_a = 'undef' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage_() iarg = 0 @@ -254,11 +251,11 @@ subroutine Init_ ( dyn_f, dyn_b, dyn_a, out_a, remap, restart, do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if (index(argv,'-b' ) .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_b ) + call get_command_argument ( iArg, dyn_b ) else if (index(argv,'-noremap' ) .gt. 0 ) then remap = .false. else if (index(argv,'-nors' ) .gt. 0 ) then @@ -266,23 +263,23 @@ subroutine Init_ ( dyn_f, dyn_b, dyn_a, out_a, remap, restart, else if (index(argv,'-a' ) .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, out_a ) + call get_command_argument ( iArg, out_a ) else if (index(argv,'-vars' ) .gt. 0 ) then if ( iarg+2 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, vars ) + call get_command_argument ( iArg, vars ) else if (index(argv,'-alpha' ) .gt. 0 ) then if ( iarg+2 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) alpha else if (index(argv,'-pick' ) .gt. 0 ) then if ( iarg+2 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nymd_f iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nhms_f pick = .true. else @@ -290,7 +287,7 @@ subroutine Init_ ( dyn_f, dyn_b, dyn_a, out_a, remap, restart, call FileResolv ( trim(prefix), nymd_f, nhms_f, argv, dyn_f ) if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) n = n + 1 call FileResolv ( trim(prefix), nymd_f, nhms_f, argv, dyn_a ) end if @@ -335,10 +332,20 @@ subroutine Init_ ( dyn_f, dyn_b, dyn_a, out_a, remap, restart, print *, ' Alpha: ', alpha print * + end subroutine Init_ !....................................................................... + logical function upd(str,vars) + + character(len=*), intent(in) :: str + character(len=*), intent(in) :: vars + + upd = index(vars,str) .gt. 0 + + end function upd + subroutine usage_() print * print *, 'SYNOPSIS ' diff --git a/GMAO_hermes/lcv2prs.F90 b/GMAO_hermes/lcv2prs.F90 index 6e80d7ee..07257850 100644 --- a/GMAO_hermes/lcv2prs.F90 +++ b/GMAO_hermes/lcv2prs.F90 @@ -1279,7 +1279,7 @@ Program lcv2prs ! All done ! -------- - call exit(0) + stop CONTAINS @@ -1385,7 +1385,6 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& !------------------------------------------------------------------------- integer iarg, argc - integer :: iargc character(len=4096) argv, prsFile character(len=255) rcfile, Vars(mVars), tmp, tmp1 @@ -1402,7 +1401,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& real xWest, xSouth, deltaPhi, deltaj, p logical :: debug = .false. - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) call usage_() ! Defaults @@ -1444,11 +1443,11 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& if ( iarg .gt. argc ) then exit endif - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if(index(argv,'-o') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, outFile ) + call get_command_argument ( iArg, outFile ) else if(index(argv,'-edge') .gt. 0 ) then onEdges = .true. else if(index(argv,'-lcv') .gt. 0 ) then @@ -1466,108 +1465,108 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& else if(index(argv,'-cvs') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, cvsFile ) + call get_command_argument ( iArg, cvsFile ) else if(index(argv,'-format') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, format ) + call get_command_argument ( iArg, format ) else if(index(argv,'-date') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) date else if(index(argv,'-inc') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) inc_hhmmss else if(index(argv,'-start') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) startTime else if(index(argv,'-rc') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, rcfile ) + call get_command_argument ( iArg, rcfile ) else if(index(argv,'-hist') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrHistory ) + call get_command_argument ( iArg, usrHistory ) else if(index(argv,'-convention') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrConvention ) + call get_command_argument ( iArg, usrConvention ) else if(index(argv,'-inst') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrInstitution ) + call get_command_argument ( iArg, usrInstitution ) else if(index(argv,'-ref') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrReferences ) + call get_command_argument ( iArg, usrReferences ) else if(index(argv,'-comment') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrComment ) + call get_command_argument ( iArg, usrComment ) else if(index(argv,'-src') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrSource ) + call get_command_argument ( iArg, usrSource ) else if(index(argv,'-title') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrTitle ) + call get_command_argument ( iArg, usrTitle ) else if(index(argv,'-contact') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrContact ) + call get_command_argument ( iArg, usrContact ) else if(index(argv,'-im') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) im else if(index(argv,'-west') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) xWest else if(index(argv,'-south') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) xSouth else if(index(argv,'-jm') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) jm else if(index(argv,'-nbits') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nbit print *, "nbit: ", nbit else if(index(argv,'-tSteps') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) tSteps else if(index(argv,'-vars') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) call split_ ( ',', argv, mVars, Vars, nVars ) else if(index(argv,'-prsf') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, prsFile ) + call get_command_argument ( iArg, prsFile ) if (len(trim(prsFile)) .ge. 4096) call die (myNewName, '-prsf files are too long.') call split_ ( ',', prsFile, mFiles, prsFiles, nPsfs ) else if(index(argv,'-levels') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) call split_ ( ',', argv, mLevs, cLevs, nLevs ) allocate( Levs(nLevs), stat = rc) if ( rc /= 0 ) call die (myNewName, 'wrong in allocating nLevs') @@ -1578,7 +1577,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& else if(index(argv,'-prec') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) outPrec else if(index(argv,'-eta') .gt. 0 ) then inType = 'eta' @@ -2942,7 +2941,7 @@ subroutine comp_slp(im,jm,km,pt,phis,delp,pe,pm,grav,pkz,inField) end do if ( k_bot .lt. 2 ) then print *, ': got k_bot<2 while computing T_ref' - call exit(1) + error stop 1 else k1 = k_bot - 1 k2 = k_bot diff --git a/GMAO_hermes/m_dyn_util.F90 b/GMAO_hermes/m_dyn_util.F90 index 8ac55bb1..8a767572 100644 --- a/GMAO_hermes/m_dyn_util.F90 +++ b/GMAO_hermes/m_dyn_util.F90 @@ -10,6 +10,7 @@ module m_dyn_util ! !USES: ! use m_dyn + use iso_fortran_env implicit NONE private @@ -276,7 +277,7 @@ subroutine TotEne_Weights_(x,projlon,projlat,projlev,w2d,w3d,optene,vnorm,ps,del vnorm_=vnorm if(.not.present(delp)) then print *, 'need delp for height-weights' - call exit (99) + error stop 99 endif endif im=x%grid%im @@ -486,8 +487,8 @@ subroutine horiz_grid_ (jn1, jweights, glats) tlat=tlat+rlat glats(j,1)=pi180*ulat glats(j,2)=pi180*tlat - slats(j,1)=dsin(real(ulat,8)) - slats(j,2)=dsin(real(tlat,8)) + slats(j,1)=sin(real(ulat,REAL64)) + slats(j,2)=sin(real(tlat,REAL64)) enddo ! jweights(1,1)=0.d0 ! not used diff --git a/GMAO_hermes/m_insitu.F b/GMAO_hermes/m_insitu.F index 5d80d64f..4bebf2d9 100644 --- a/GMAO_hermes/m_insitu.F +++ b/GMAO_hermes/m_insitu.F @@ -1092,7 +1092,7 @@ subroutine Insitu_Prep(im, jm, km, end do if ( k_bot .lt. 2 ) then print *, myname//': got k_bot<2 while computing T_ref' - call exit(1) + error stop 1 else k1 = k_bot - 1 k2 = k_bot diff --git a/GMAO_hermes/m_interp.F90 b/GMAO_hermes/m_interp.F90 index 401e1d77..07fe1414 100644 --- a/GMAO_hermes/m_interp.F90 +++ b/GMAO_hermes/m_interp.F90 @@ -1144,7 +1144,7 @@ end subroutine Interp_Field subroutine die ( myname, msg ) character(len=*) :: myname, msg write(*,'(a)') trim(myname) // ': ' // trim(msg) - call exit(1) + error stop 1 end subroutine die !................................................................. diff --git a/GMAO_hermes/m_nc_JEDIinc.f90 b/GMAO_hermes/m_nc_JEDIinc.f90 index 8942eab3..2117966b 100644 --- a/GMAO_hermes/m_nc_JEDIinc.f90 +++ b/GMAO_hermes/m_nc_JEDIinc.f90 @@ -3,6 +3,9 @@ module m_nc_JEDIinc implicit none private +! NAG: use portable kind parameter instead of byte-count literal real(r4) +integer, parameter :: r4 = selected_real_kind(6) + public :: nc_JEDIinc_vars_init public :: nc_JEDIinc_vars_final public :: nc_JEDIinc_vars_comp @@ -20,19 +23,19 @@ module m_nc_JEDIinc logical :: initialized=.false. integer :: nlon,nlat,nsig logical :: gsiset=.false. - real(4),pointer,dimension(:):: ak=>NULL(),bk=>NULL() - real(4),pointer,dimension(:,:,:):: dp=>NULL() - real(4),pointer,dimension(:,:,:):: tv=>NULL() - real(4),pointer,dimension(:,:,:):: t=>NULL() - real(4),pointer,dimension(:,:,:):: u=>NULL(),v=>NULL() - real(4),pointer,dimension(:,:,:):: qv=>NULL() - real(4),pointer,dimension(:,:,:):: qi=>NULL(),ql=>NULL(),qr=>NULL(),qs=>NULL() - real(4),pointer,dimension(:,:,:):: oz=>NULL() - real(4),pointer,dimension(:,:) :: ps=>NULL(),ts=>NULL() + real(r4),pointer,dimension(:):: ak=>NULL(),bk=>NULL() + real(r4),pointer,dimension(:,:,:):: dp=>NULL() + real(r4),pointer,dimension(:,:,:):: tv=>NULL() + real(r4),pointer,dimension(:,:,:):: t=>NULL() + real(r4),pointer,dimension(:,:,:):: u=>NULL(),v=>NULL() + real(r4),pointer,dimension(:,:,:):: qv=>NULL() + real(r4),pointer,dimension(:,:,:):: qi=>NULL(),ql=>NULL(),qr=>NULL(),qs=>NULL() + real(r4),pointer,dimension(:,:,:):: oz=>NULL() + real(r4),pointer,dimension(:,:) :: ps=>NULL(),ts=>NULL() ! - real(4),pointer,dimension(:) :: v1d=>NULL() - real(4),pointer,dimension(:,:) :: v2d=>NULL() - real(4),pointer,dimension(:,:,:):: v3d=>NULL() + real(r4),pointer,dimension(:) :: v1d=>NULL() + real(r4),pointer,dimension(:,:) :: v2d=>NULL() + real(r4),pointer,dimension(:,:,:):: v3d=>NULL() end type nc_JEDIinc_vars character(len=*), parameter :: myname = 'm_nc_JEDIinc' @@ -153,7 +156,7 @@ subroutine read_JEDIinc_ (fname,bvars,rc, myid,root, gsiset) integer :: ndims_, nvars_, ngatts_, unlimdimid_ integer :: nlat_,nlon_,nlev_ integer :: mype_,root_ - real(4), allocatable :: data_in(:,:,:) + real(r4), allocatable :: data_in(:,:,:) logical :: verbose logical :: init_ logical :: gsi_ @@ -330,10 +333,10 @@ subroutine write_JEDIinc_ (fname,bvars,lats,lons,rc, myid,root,plevs) implicit none character(len=*), intent(in) :: fname ! input filename type(nc_JEDIinc_vars),intent(in) :: bvars ! background error variables - real(4), intent(in) :: lats(:) ! latitudes per GSI: increase index from South to North Pole - real(4), intent(in) :: lons(:) ! longitude per GSI: increase index from East to West + real(r4), intent(in) :: lats(:) ! latitudes per GSI: increase index from South to North Pole + real(r4), intent(in) :: lons(:) ! longitude per GSI: increase index from East to West integer, intent(out) :: rc - real(4), intent(in), optional :: plevs(:) + real(r4), intent(in), optional :: plevs(:) integer, intent(in), optional :: myid,root ! accommodate MPI calling programs character(len=*), parameter :: myname_ = myname//"::read_" @@ -352,8 +355,8 @@ subroutine write_JEDIinc_ (fname,bvars,lats,lons,rc, myid,root,plevs) ! This is the data array we will write. It will just be filled with ! a progression of integers for this example. - real(4), allocatable :: data_out(:,:,:) - real(4), allocatable :: idlevs(:) + real(r4), allocatable :: data_out(:,:,:) + real(r4), allocatable :: idlevs(:) ! Consistency check if (bvars%gsiset) then @@ -625,7 +628,7 @@ subroutine get_pointer_2d_ (vname, bvars, ptr, rc ) implicit none character(len=*), intent(in) :: vname type(nc_JEDIinc_vars) bvars -real(4),pointer,intent(inout) :: ptr(:,:) +real(r4),pointer,intent(inout) :: ptr(:,:) integer,intent(out) :: rc rc=-1 if(trim(vname)=='ps') then @@ -642,7 +645,7 @@ subroutine get_pointer_3d_ (vname, bvars, ptr, rc ) implicit none character(len=*), intent(in) :: vname type(nc_JEDIinc_vars) bvars -real(4),pointer,intent(inout) :: ptr(:,:,:) +real(r4),pointer,intent(inout) :: ptr(:,:,:) integer,intent(out) :: rc character(len=5) :: var rc=-1 @@ -804,8 +807,8 @@ subroutine hflip3_ ( q,im,jm,km, gsi ) implicit none integer im,jm,km,i,j,k logical gsi - real(4), intent(inout) :: q(:,:,:) - real(4), allocatable :: dum(:) + real(r4), intent(inout) :: q(:,:,:) + real(r4), allocatable :: dum(:) allocate ( dum(im) ) if (gsi) then do k=1,km @@ -835,8 +838,8 @@ subroutine hflip2_ ( q,im,jm, gsi ) implicit none integer im,jm,i,j logical gsi - real(4), intent(inout) :: q(:,:) - real(4), allocatable :: dum(:) + real(r4), intent(inout) :: q(:,:) + real(r4), allocatable :: dum(:) allocate ( dum(im) ) if (gsi) then do j=1,jm @@ -861,8 +864,8 @@ end subroutine hflip2_ subroutine vflip_(q,im,jm,km) implicit none integer,intent(in) :: im,jm,km - real(4),intent(inout) :: q(im,jm,km) - real(4), allocatable :: dum(:) + real(r4),intent(inout) :: q(im,jm,km) + real(r4), allocatable :: dum(:) integer i,j allocate(dum(km)) do j=1,jm @@ -901,7 +904,7 @@ end subroutine summary_ real function stddev2_(x) implicit none - real(4) :: x(:,:) + real(r4) :: x(:,:) integer im,jm real mean im = size(x,1) @@ -912,7 +915,7 @@ end function stddev2_ real function stddev3_(x) implicit none - real(4) :: x(:,:,:) + real(r4) :: x(:,:,:) integer im,jm,km real mean im = size(x,1) diff --git a/GMAO_hermes/m_nc_akbk.f90 b/GMAO_hermes/m_nc_akbk.f90 index 7d8398c0..a4759585 100644 --- a/GMAO_hermes/m_nc_akbk.f90 +++ b/GMAO_hermes/m_nc_akbk.f90 @@ -1,5 +1,6 @@ module m_nc_akbk use netcdf +use iso_fortran_env, only: real64 implicit none private public :: write_nc_akbk @@ -12,14 +13,14 @@ module m_nc_akbk subroutine write_nc_akbk_ (fname,ak, bk) character(len=*), intent(in) :: fname - double precision, intent(in) :: ak(:), bk(:) + real(real64), intent(in) :: ak(:), bk(:) ! NetCDF variables integer :: ncid, dimid_edge integer :: varid_edge, varid_ak, varid_bk integer :: rc integer :: i, km - double precision, allocatable :: edge(:) + real(real64), allocatable :: edge(:) km = size(ak) allocate(edge(km)) diff --git a/GMAO_hermes/m_topo_remap.F90 b/GMAO_hermes/m_topo_remap.F90 index 5a8a8877..c1b20a3b 100644 --- a/GMAO_hermes/m_topo_remap.F90 +++ b/GMAO_hermes/m_topo_remap.F90 @@ -132,8 +132,7 @@ subroutine dyn_topo_remap_( w_f,phis_new, dyntype, info ) deallocate ( ple ) else print *, ' not coded for old dyn' - call exit(1) - stop + error stop 1 endif call dyn_topo_remap( w_f%ps,w_f%delp,w_f%u,w_f%v,thv,w_f%q,w_f%phis,phis_new, & @@ -222,8 +221,7 @@ subroutine dyn_real_eta_( w_f, dyntype, info ) deallocate ( pke ) else print *, ' not coded for old dyn' - call exit(1) - stop + error stop 1 endif call ps_remap0_( ple_cur,ple_new,w_f%u,w_f%v,thv,w_f%q, & diff --git a/GMAO_hermes/maph_pert.f90 b/GMAO_hermes/maph_pert.f90 index 7fd8cbea..f5000eb0 100755 --- a/GMAO_hermes/maph_pert.f90 +++ b/GMAO_hermes/maph_pert.f90 @@ -129,7 +129,7 @@ program maph_pert print *, '--------------------------' print * - call exit(0) + stop !................................................................................... @@ -159,7 +159,7 @@ subroutine init_ () !EOP !----------------------------------------------------------------------- - integer i, iarg, argc, iargc + integer i, iarg, argc character(len=255) argv logical pin, lon_res, lat_res, pick @@ -174,7 +174,7 @@ subroutine init_ () dyn_pin = 'NONE' dyn_pout = 'maph_pert.nc4' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage_() iarg = 0 @@ -183,16 +183,16 @@ subroutine init_ () if ( iarg .gt. argc ) then exit endif - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if (index(argv,'-op' ) .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_pout ) + call get_command_argument ( iArg, dyn_pout ) else if (index(argv,'-p' ) .gt. 0 ) then pin = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_pin ) + call get_command_argument ( iArg, dyn_pin ) else if (index(argv,'-verbose' ) .gt. 0 ) then verb = .true. else if (index(argv,'-hs' ) .gt. 0 ) then @@ -203,22 +203,22 @@ subroutine init_ () lon_res = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) in else if (index(argv,'-lat' ) .gt. 0 ) then lat_res = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) jn else if (index(argv,'-pick' ) .gt. 0 ) then pick = .true. if ( iarg+2 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nymd_p iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nhms_p end if end do @@ -289,7 +289,7 @@ subroutine die ( myname, msg ) print * print *, trim(myname) // ': ' // trim(msg) print * - call exit(1) + error stop 1 end subroutine die !....................................................................... diff --git a/GMAO_hermes/recalcsfc.F90 b/GMAO_hermes/recalcsfc.F90 index 88fd44e3..64c91560 100644 --- a/GMAO_hermes/recalcsfc.F90 +++ b/GMAO_hermes/recalcsfc.F90 @@ -168,7 +168,7 @@ Program ReCalcSFC if(debug) print *, 'Overwrote surface file: ', trim(bkgsfc) call zeit_co ( 'recalcsfc' ) - call exit(0) + stop CONTAINS @@ -408,7 +408,7 @@ subroutine Init ( obkgeta, rbkgeta, bkgsfc, nymd, nhms, dyntype, debug ) character(len=*), parameter :: myname = 'Init' - integer i, iarg, argc, iargc, n + integer i, iarg, argc, n logical debug character(len=255) argv @@ -424,7 +424,7 @@ subroutine Init ( obkgeta, rbkgeta, bkgsfc, nymd, nhms, dyntype, debug ) ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 3 ) call usage() iarg = 0 @@ -434,7 +434,7 @@ subroutine Init ( obkgeta, rbkgeta, bkgsfc, nymd, nhms, dyntype, debug ) if ( iarg .gt. argc ) then exit endif - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if (index(argv,'-v' ) .gt. 0 ) then debug = .true. else if (index(argv,'-g5' ) .gt. 0 ) then diff --git a/GMAO_hermes/reset_time.f b/GMAO_hermes/reset_time.f index 09292684..73f1411c 100644 --- a/GMAO_hermes/reset_time.f +++ b/GMAO_hermes/reset_time.f @@ -10,7 +10,6 @@ INTEGER fdate, fhhmmss_beg, finc character(len=256) fileName character(len=256) argv - integer :: iargc integer hh, mm, ss character(len=2) chh, cmm, css integer yyyy, mon, day @@ -18,7 +17,7 @@ character(len=2) cmon, cday character*80 timeUnits - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) then print *, "Usage: reset_time.x fname yyyymmdd hhmmss time_inc" print *, " " @@ -34,18 +33,18 @@ end if iarg = 1 - call GetArg ( iarg, fileName ) + call get_command_argument ( iarg, fileName ) ! print * , "fileName: ", trim(fileName) iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) date ! print * , "date: ", date iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) hhmmss_beg ! print * , "hhmmss_beg: ", hhmmss_beg iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) inc ! print * , "inc: ", inc diff --git a/GMAO_hermes/rout2prs.f b/GMAO_hermes/rout2prs.f index dd5b735e..97ae68ee 100644 --- a/GMAO_hermes/rout2prs.f +++ b/GMAO_hermes/rout2prs.f @@ -84,8 +84,8 @@ program eta2prs C----- Open files --------------------------------------------- - call getarg (1, filein) - call getarg (2, fileout) + call get_command_argument(1, filein) + call get_command_argument(2, fileout) write(6,*) filein write(6,*) fileout diff --git a/GMAO_hermes/rs52dyn.f90 b/GMAO_hermes/rs52dyn.f90 index cd65bc43..55307dff 100644 --- a/GMAO_hermes/rs52dyn.f90 +++ b/GMAO_hermes/rs52dyn.f90 @@ -53,7 +53,7 @@ program main character*120, allocatable :: arg(:) character*8 date character*2 hour - integer n,nargs,iargc,i,j,L,rc + integer n,nargs,i,j,L,rc integer prec, ks real*8 ptop, pint @@ -80,11 +80,11 @@ program main nhms_ana = -999 prec = 0 - nargs = iargc() + nargs = command_argument_count() if(nargs==0) call usage() allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) call usage() @@ -365,6 +365,6 @@ subroutine usage() print * print *, " Last updated 26Jan2006, Elena N." print * - call exit(7) + error stop 7 end diff --git a/GMAO_hermes/ut_ana2dyn.f90 b/GMAO_hermes/ut_ana2dyn.f90 index fc4ef053..ebc5b77d 100644 --- a/GMAO_hermes/ut_ana2dyn.f90 +++ b/GMAO_hermes/ut_ana2dyn.f90 @@ -316,7 +316,7 @@ subroutine Init_ ( dynfile1, dynfile2, outfile, ampl ) ampl = 0.1 outfile = 'ut_ana2dyn' - argc = iargc() + argc = command_argument_count() if ( .not. (argc.eq.2 .or. argc.eq.4) ) call usage() iarg = 0 diff --git a/GMAO_hermes/ut_dyn_ipert.f90 b/GMAO_hermes/ut_dyn_ipert.f90 index c96afa96..54d75361 100644 --- a/GMAO_hermes/ut_dyn_ipert.f90 +++ b/GMAO_hermes/ut_dyn_ipert.f90 @@ -36,7 +36,7 @@ program ut_dyn_ipert vectype=dyntype, ptop=ptop, ks=ks, ak=ak, bk=bk ) if (rc/=0) then print *, 'main: Error initializing dyn vector(xpo), rc=', rc - call exit(1) + stop 1 endif deallocate(ak,bk) @@ -49,7 +49,7 @@ program ut_dyn_ipert call mapz_pert_interp ( plevi, plevo, xpi, xpo, rc) if (rc/=0) then print *, 'main: Error from mapz_pert_interp(xpo), rc=', rc - call exit(1) + stop 1 endif ! write out result diff --git a/GMAO_hermes/write_eta.F90 b/GMAO_hermes/write_eta.F90 index f7250f1f..1d93c1c3 100644 --- a/GMAO_hermes/write_eta.F90 +++ b/GMAO_hermes/write_eta.F90 @@ -31,14 +31,14 @@ program write_eta nxt = 1 filename = 'eta.rc' - call getarg(nxt,arg) + call get_command_argument(nxt,arg) do while(arg(1:1)=='-') opt=arg(2:2) if(len(trim(arg))==2) then nxt = nxt + 1 - call getarg(nxt,arg) + call get_command_argument(nxt,arg) else arg = arg(3:) end if @@ -58,7 +58,7 @@ program write_eta stop Usage end select nxt = nxt + 1 - call getarg(nxt,arg) + call get_command_argument(nxt,arg) end do if (use_sigma /=0 ) then @@ -85,7 +85,7 @@ program write_eta write(unit,'(A)') "ak-bk: " do k = 1,levels+1 - write(unit,'(2ES23.15)'), ak(k), bk(k) + write(unit,'(2ES23.15)') ak(k), bk(k) enddo write(unit,'(A, ES23.15)') "REF_PRESSURE: ",p0 diff --git a/GMAO_mpeu/CMakeLists.txt b/GMAO_mpeu/CMakeLists.txt index 986ceaa7..bbc348c6 100644 --- a/GMAO_mpeu/CMakeLists.txt +++ b/GMAO_mpeu/CMakeLists.txt @@ -57,9 +57,9 @@ file (MAKE_DIRECTORY ${esma_etc}/GMAO_eu) set_source_files_properties (m_FileResolv.f90 PROPERTIES COMPILE_FLAGS ${PP}) # NAG notices if the same procedure is called with varying types in the absence -# of an explicit interface. -target_compile_options (${this} PRIVATE $<$:${MISMATCH}>) -target_compile_options (GMAO_eu PRIVATE $<$:${MISMATCH}>) +# of an explicit interface. The MISMATCH flag is now in common_Fortran_flags. +# target_compile_options (${this} PRIVATE $<$:${MISMATCH}>) +# target_compile_options (GMAO_eu PRIVATE $<$:${MISMATCH}>) file (COPY assert.H DESTINATION ${include_${this}}) file (COPY assert.H DESTINATION ${esma_include}/GMAO_eu) diff --git a/GMAO_mpeu/m_ioutil.F90 b/GMAO_mpeu/m_ioutil.F90 index 342e2d1a..e7f81c0d 100644 --- a/GMAO_mpeu/m_ioutil.F90 +++ b/GMAO_mpeu/m_ioutil.F90 @@ -497,11 +497,12 @@ function swapI4_(ibuf) !EOP ___________________________________________________________________ character(len=*),parameter :: myname_=myname//'::swapI4_' + character(len=1),dimension(4*size(ibuf)) :: cbuf_in, cbuf_out - ! TRANSFER() should be used. The current implementation may be - ! not fully portable. - - call ioutil_byteswap_(size(ibuf),4,ibuf,swapI4_) + ! Use TRANSFER() for proper type conversion (NAG-safe) + cbuf_in = transfer(ibuf, cbuf_in) + call ioutil_byteswap_(size(ibuf),4,cbuf_in,cbuf_out) + swapI4_ = transfer(cbuf_out, swapI4_) end function swapI4_ @@ -527,11 +528,12 @@ function swapI8_(ibuf) !EOP ___________________________________________________________________ character(len=*),parameter :: myname_=myname//'::swapI8_' + character(len=1),dimension(8*size(ibuf)) :: cbuf_in, cbuf_out - ! TRANSFER() should be used. The current implementation may be - ! not fully portable. - - call ioutil_byteswap_(size(ibuf),8,ibuf,swapI8_) + ! Use TRANSFER() for proper type conversion (NAG-safe) + cbuf_in = transfer(ibuf, cbuf_in) + call ioutil_byteswap_(size(ibuf),8,cbuf_in,cbuf_out) + swapI8_ = transfer(cbuf_out, swapI8_) end function swapI8_ end module m_ioutil diff --git a/GMAO_mpeu/m_random.F b/GMAO_mpeu/m_random.F index 7f0a08cd..3a736891 100644 --- a/GMAO_mpeu/m_random.F +++ b/GMAO_mpeu/m_random.F @@ -545,7 +545,7 @@ double precision function mysecond() c c Generic Unix version real xx(2) -#if defined(sysAIX) || defined(__GFORTRAN__) +#if defined(sysAIX) || defined(__GFORTRAN__) || defined (__NAG_COMPILER_RELEASE) call get_zeits(xx(1)) #else call etime(xx) diff --git a/GMAO_mpeu/mpi0/mpi0_copy.F90 b/GMAO_mpeu/mpi0/mpi0_copy.F90 index 0b360e15..79f46072 100644 --- a/GMAO_mpeu/mpi0/mpi0_copy.F90 +++ b/GMAO_mpeu/mpi0/mpi0_copy.F90 @@ -42,25 +42,73 @@ subroutine mpi0_copy(sbuf,scount,stype,rbuf,rcount,rtype,ier) if( stype==MPI_INTEGER ) then call copy_INTEGER(sbuf,rbuf,scount) elseif( stype==MPI_REAL ) then - call copy_REAL(sbuf,rbuf,scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + real,dimension(scount) :: sbuf_real, rbuf_real + sbuf_real = transfer(sbuf(1:scount), sbuf_real) + call copy_REAL(sbuf_real,rbuf_real,scount) + rbuf(1:scount) = transfer(rbuf_real, rbuf(1:scount)) + end block elseif( stype==MPI_DOUBLE_PRECISION ) then - call copy_DOUBLE_PRECISION(sbuf,rbuf,scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + double precision,dimension(scount) :: sbuf_dbl, rbuf_dbl + sbuf_dbl = transfer(sbuf(1:scount), sbuf_dbl) + call copy_DOUBLE_PRECISION(sbuf_dbl,rbuf_dbl,scount) + rbuf(1:scount) = transfer(rbuf_dbl, rbuf(1:scount)) + end block elseif( stype==MPI_LOGICAL ) then - call copy_LOGICAL(sbuf,rbuf,scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + logical,dimension(scount) :: sbuf_log, rbuf_log + sbuf_log = transfer(sbuf(1:scount), sbuf_log) + call copy_LOGICAL(sbuf_log,rbuf_log,scount) + rbuf(1:scount) = transfer(rbuf_log, rbuf(1:scount)) + end block elseif( stype==MPI_CHARACTER ) then - call copy_CHARACTER(sbuf,rbuf,scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + character,dimension(scount) :: sbuf_char, rbuf_char + sbuf_char = transfer(sbuf(1:scount), sbuf_char) + call copy_CHARACTER(sbuf_char,rbuf_char,scount) + rbuf(1:scount) = transfer(rbuf_char, rbuf(1:scount)) + end block elseif( stype==MPI_INTEGER4 ) then call copy_INTEGER4(sbuf,rbuf,scount) elseif( stype==MPI_REAL4 ) then - call copy_REAL4(sbuf,rbuf,scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + real,dimension(scount) :: sbuf_r4, rbuf_r4 + sbuf_r4 = transfer(sbuf(1:scount), sbuf_r4) + call copy_REAL4(sbuf_r4,rbuf_r4,scount) + rbuf(1:scount) = transfer(rbuf_r4, rbuf(1:scount)) + end block elseif( stype==MPI_REAL8 ) then - call copy_REAL8(sbuf,rbuf,scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + double precision,dimension(scount) :: sbuf_r8, rbuf_r8 + sbuf_r8 = transfer(sbuf(1:scount), sbuf_r8) + call copy_REAL8(sbuf_r8,rbuf_r8,scount) + rbuf(1:scount) = transfer(rbuf_r8, rbuf(1:scount)) + end block elseif( stype==MPI_2INTEGER ) then call copy_INTEGER(sbuf,rbuf,2*scount) elseif( stype==MPI_2REAL ) then - call copy_REAL(sbuf,rbuf,2*scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + real,dimension(2*scount) :: sbuf_real, rbuf_real + sbuf_real = transfer(sbuf(1:2*scount), sbuf_real) + call copy_REAL(sbuf_real,rbuf_real,2*scount) + rbuf(1:2*scount) = transfer(rbuf_real, rbuf(1:2*scount)) + end block elseif( stype==MPI_2DOUBLE_PRECISION ) then - call copy_DOUBLE_PRECISION(sbuf,rbuf,2*scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + double precision,dimension(2*scount) :: sbuf_dbl, rbuf_dbl + sbuf_dbl = transfer(sbuf(1:2*scount), sbuf_dbl) + call copy_DOUBLE_PRECISION(sbuf_dbl,rbuf_dbl,2*scount) + rbuf(1:2*scount) = transfer(rbuf_dbl, rbuf(1:2*scount)) + end block else ier=stype if(stype==0) ier=MPI_UNDEFINED