From a4b7d50bbc123e5ca17b26f48d3b605d100778ca Mon Sep 17 00:00:00 2001 From: George Gayno Date: Thu, 27 Jun 2024 19:53:07 +0000 Subject: [PATCH 01/54] Remove spectral filtering of topography. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 36 ++++--------------- 1 file changed, 6 insertions(+), 30 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 041c9be5b..198191821 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -182,7 +182,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, integer :: mskocn,notocn integer :: i,j,nx,ny,ncid,js,jn,iw,ie,k,it,jt,error,id_dim integer :: id_var,nx_in,ny_in,fsize,wgta,IN,INW,INE,IS,ISW,ISE - integer :: M,N,ios,istat,itest,jtest + integer :: ios,istat,itest,jtest integer :: i_south_pole,j_south_pole,i_north_pole,j_north_pole integer :: maxc3,maxc4,maxc5,maxc6,maxc7,maxc8 integer(1) :: i3save @@ -198,7 +198,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, integer, allocatable :: IWORK(:,:,:) real :: DEGRAD,maxlat, minlat,timef,tbeg,tend,tbeg1 - real :: PHI,DELXN,slma,oroa,vara,var4a,xn,XS,FFF,WWW + real :: PHI,DELXN,slma,oroa,vara,var4a,xn,XS real :: sumdif,avedif real, allocatable :: COSCLT(:),WGTCLT(:),RCLT(:),XLAT(:),DIFFX(:) @@ -220,7 +220,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, real, allocatable :: oa_in(:,:,:), ol_in(:,:,:) logical :: grid_from_file,fexist,opened - logical :: SPECTR, FILTER + logical :: SPECTR logical :: is_south_pole(IM,JM), is_north_pole(IM,JM) tbeg1=timef() @@ -244,7 +244,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, ! DEGRAD = 180./PI SPECTR = NM .GT. 0 ! if NM <=0 grid is assumed lat/lon - FILTER = .TRUE. ! Spectr Filter defaults true and set by NF1 & NF0 MSKOCN = 1 ! Ocean land sea mask =1, =0 if not present NOTOCN = 1 ! =1 Ocean lsm input reverse: Ocean=1, land=0 ! --- The LSM Gaussian file from the ocean model sometimes arrives with @@ -1185,33 +1184,10 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, ! deallocate(VAR4) allocate (ORF(IM,JM)) - IF ( NF1 - NF0 .eq. 0 ) FILTER=.FALSE. - print *,' NF1, NF0, FILTER=',NF1,NF0,FILTER - IF (FILTER) THEN -C SPECTRALLY TRUNCATE AND FILTER OROGRAPHY + print *,' NF1, NF0=',NF1,NF0 - CALL SPTEZ(NR,NM,4,IM,JM,ORS,ORO,-1) -! - print *,' about to apply spectral filter ' - FFF=1./(NF1-NF0)**2 - I=0 - DO M=0,NM - DO N=M,NM+NR*M - IF(N.GT.NF0) THEN - WWW=MAX(1.-FFF*(N-NF0)**2,0.) - ORS(I+1)=ORS(I+1)*WWW - ORS(I+2)=ORS(I+2)*WWW - ENDIF - I=I+2 - ENDDO - ENDDO -! - CALL SPTEZ(NR,NM,4,IM,JM,ORS,ORF,+1) - - ELSE - ORS=0. - ORF=ORO - ENDIF + ORS=0. + ORF=ORO deallocate (WORK1) From 09928c746016fa1cde936c240ff9fc32dc3673ec Mon Sep 17 00:00:00 2001 From: George Gayno Date: Thu, 27 Jun 2024 20:35:36 +0000 Subject: [PATCH 02/54] Cleanup related to the removal of the spectral terrain filter step. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 34 ++++++------------- 1 file changed, 10 insertions(+), 24 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 198191821..55ca3c95d 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -77,14 +77,12 @@ character(len=256) :: INPUTOROG = "none" character(len=256) :: merge_file = "none" logical :: mask_only = .false. - integer :: MTNRES,IM,JM,NM,NR,NF0,NF1,EFAC,NW + integer :: MTNRES,IM,JM,NM,NR,EFAC fsize=65536 READ(5,*) OUTGRID READ(5,*) mask_only READ(5,*) merge_file NM=0 - NF0=0 - NF1=0 EFAC=0 NR=0 print*, "INPUTOROG= ", trim(INPUTOROG) @@ -97,8 +95,7 @@ ! --- other possibilities are =8 for 4' and =4 for 2' see ! HJ for T1000 test. Must set to 1 for now. MTNRES=1 - print*, MTNRES,NM,NR,NF0,NF1,EFAC - NW=(NM+1)*((NR+1)*NM+2) + print*, MTNRES,NM,NR,EFAC IMN = 360*120/MTNRES JMN = 180*120/MTNRES print *, ' Starting terr12 mtnlm7_slm30.f IMN,JMN:',IMN,JMN @@ -137,7 +134,7 @@ error=nf_close(ncid) call netcdf_err(error, 'close file '//trim(OUTGRID) ) - CALL TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, + CALL TERSUB(IMN,JMN,IM,JM,NM,NR,EFAC, & OUTGRID,INPUTOROG,MASK_ONLY,MERGE_FILE) STOP END @@ -150,9 +147,6 @@ !! @param[in] JM "j" dimension of the model grid tile. !! @param[in] NM Spectral truncation. !! @param[in] NR Rhomboidal flag. -!! @param[in] NF0 First order spectral filter parameters. -!! @param[in] NF1 Second order spectral filter parameters. -!! @param[in] NW Number of waves. !! @param[in] EFAC Factor to adjust orography by its variance. !! @param[in] OUTGRID The 'grid' file for the model tile. !! @param[in] INPUTOROG Input orography/GWD file on gaussian @@ -162,12 +156,12 @@ !! @param[in] MASK_ONLY Flag to generate the Land Mask only !! @param[in] MERGE_FILE Ocean merge file !! @author Jordan Alpert NOAA/EMC - SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, + SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,EFAC, & OUTGRID,INPUTOROG,MASK_ONLY,MERGE_FILE) implicit none include 'netcdf.inc' C - integer :: IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW + integer :: IMN,JMN,IM,JM,NM,NR character(len=*), intent(in) :: OUTGRID character(len=*), intent(in) :: INPUTOROG character(len=*), intent(in) :: MERGE_FILE @@ -202,7 +196,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, real :: sumdif,avedif real, allocatable :: COSCLT(:),WGTCLT(:),RCLT(:),XLAT(:),DIFFX(:) - real, allocatable :: XLON(:),ORS(:),oaa(:),ola(:),GLAT(:) + real, allocatable :: XLON(:),oaa(:),ola(:),GLAT(:) real, allocatable :: GEOLON(:,:),GEOLON_C(:,:),DX(:,:) real, allocatable :: GEOLAT(:,:),GEOLAT_C(:,:),DY(:,:) @@ -233,7 +227,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, ! reals allocate (COSCLT(JM),WGTCLT(JM),RCLT(JM),XLAT(JM),DIFFX(JM/2)) - allocate (XLON(IM),ORS(NW),oaa(4),ola(4),GLAT(JMN)) + allocate (XLON(IM),oaa(4),ola(4),GLAT(JMN)) allocate (ZAVG(IMN,JMN)) allocate (ZSLM(IMN,JMN)) @@ -297,8 +291,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, ! ! --- IMN,JMN - print*, ' IM, JM, NM, NR, NF0, NF1, EFAC' - print*, IM,JM,NM,NR,NF0,NF1,EFAC + print*, ' IM, JM, NM, NR, EFAC' + print*, IM,JM,NM,NR,EFAC print *,' imn,jmn,glob(imn,jmn)=',imn,jmn,glob(imn,jmn) print *,' UBOUND ZAVG=',UBOUND(ZAVG) print *,' UBOUND glob=',UBOUND(glob) @@ -1175,18 +1169,10 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, ENDDO ! call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') -! --- Quadratic filter applied by default. -! --- NF0 is normally set to an even value beyond the previous truncation, -! --- for example, for jcap=382, NF0=254+2 -! --- NF1 is set as jcap+2 (and/or nearest even), eg., for t382, NF1=382+2=384 -! --- if no filter is desired then NF1=NF0=0 and ORF=ORO -! --- if no filter but spectral to grid (with gibbs) then NF1=jcap+2, and NF1=jcap+1 ! deallocate(VAR4) allocate (ORF(IM,JM)) - print *,' NF1, NF0=',NF1,NF0 - ORS=0. ORF=ORO deallocate (WORK1) @@ -1249,7 +1235,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, ! Deallocate 1d vars deallocate(JST,JEN,numi) - deallocate(COSCLT,WGTCLT,RCLT,XLAT,DIFFX,XLON,ORS,oaa,ola,GLAT) + deallocate(COSCLT,WGTCLT,RCLT,XLAT,DIFFX,XLON,oaa,ola,GLAT) ! Deallocate 2d vars deallocate (OCLSM) From a350cb0a58389fcb0408d394054790bdf83cc8fc Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 28 Jun 2024 12:46:48 +0000 Subject: [PATCH 03/54] Remove filtered orography array, which is no longer needed. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 30 +++++-------------- sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 | 8 ++--- 2 files changed, 12 insertions(+), 26 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 55ca3c95d..94ccda983 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -200,7 +200,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,EFAC, real, allocatable :: GEOLON(:,:),GEOLON_C(:,:),DX(:,:) real, allocatable :: GEOLAT(:,:),GEOLAT_C(:,:),DY(:,:) - real, allocatable :: SLM(:,:),ORO(:,:),VAR(:,:),ORF(:,:) + real, allocatable :: SLM(:,:),ORO(:,:),VAR(:,:) real, allocatable :: land_frac(:,:),lake_frac(:,:) real, allocatable :: THETA(:,:),GAMMA(:,:),SIGMA(:,:),ELVMAX(:,:) real, allocatable :: VAR4(:,:),SLMI(:,:) @@ -1167,30 +1167,16 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,EFAC, HPRIME(I,J,14)= ELVMAX(I,J) ENDDO ENDDO -! - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') ! deallocate(VAR4) - allocate (ORF(IM,JM)) - - ORF=ORO - deallocate (WORK1) - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') - print *,' ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) - print *,' after spectral filter is applied' - call minmxj(IM,JM,ORO,' ORO') - call minmxj(IM,JM,ORF,' ORF') -C - print *,' after nearest neighbor interpolation applied ' - call minmxj(IM,JM,ORO,' ORO') - call minmxj(IM,JM,ORF,' ORF') - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') - print *,' ORO,ORF(itest,jtest),itest,jtest:', - & ORO(itest,jtest),ORF(itest,jtest),itest,jtest - print *,' ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) + call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') + call minmxj(IM,JM,ORO,' ORO') + print *,' ORO(itest,jtest),itest,jtest:', + & ORO(itest,jtest),itest,jtest + print *,' ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) C check antarctic pole DO J = 1,JM @@ -1225,7 +1211,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,EFAC, endif tbeg=timef() - CALL WRITE_NETCDF(IM,JM,SLM,land_frac,ORO,ORF,HPRIME,1,1, + CALL WRITE_NETCDF(IM,JM,SLM,land_frac,ORO,HPRIME,1,1, 1 GEOLON(1:IM,1:JM),GEOLAT(1:IM,1:JM), XLON,XLAT) tend=timef() write(6,*)' WRITE_NETCDF time= ',tend-tbeg @@ -1240,7 +1226,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,EFAC, ! Deallocate 2d vars deallocate (OCLSM) deallocate (GEOLON,GEOLON_C,GEOLAT,GEOLAT_C) - deallocate (SLM,ORO,VAR,ORF,land_frac) + deallocate (SLM,ORO,VAR,land_frac) deallocate (THETA,GAMMA,SIGMA,ELVMAX) diff --git a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 index 4e13fc8ef..f4834c2c5 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 @@ -9,7 +9,6 @@ !! @param[in] slm Land-sea mask. !! @param[in] land_frac Land fraction. !! @param[in] oro Orography -!! @param[in] orf Filtered orography. Currently the same as 'oro'. !! @param[in] hprime The gravity wave drag fields on the model grid tile. !! @param[in] ntiles Number of tiles to output. !! @param[in] tile Tile number to output. @@ -18,11 +17,11 @@ !! @param[in] lon Longitude of the first row of the model grid tile. !! @param[in] lat Latitude of the first column of the model grid tile. !! @author Jordan Alpert NOAA/EMC GFDL Programmer - subroutine write_netcdf(im, jm, slm, land_frac, oro, orf, hprime, ntiles, tile, geolon, geolat, lon, lat) + subroutine write_netcdf(im, jm, slm, land_frac, oro, hprime, ntiles, tile, geolon, geolat, lon, lat) implicit none integer, intent(in):: im, jm, ntiles, tile real, intent(in) :: lon(im), lat(jm) - real, intent(in), dimension(im,jm) :: slm, oro, orf, geolon, geolat, land_frac + real, intent(in), dimension(im,jm) :: slm, oro, geolon, geolat, land_frac real, intent(in), dimension(im,jm,14):: hprime character(len=128) :: outfile integer :: error, ncid @@ -170,7 +169,8 @@ subroutine write_netcdf(im, jm, slm, land_frac, oro, orf, hprime, ntiles, tile, error = nf_put_var_double( ncid, id_orog_raw, oro(:dim1,:dim2)) call netcdf_err(error, 'write var orog_raw for file='//trim(outfile) ) - error = nf_put_var_double( ncid, id_orog_filt, orf(:dim1,:dim2)) +! We no longer filter the orog, so the raw and filtered records are the same. + error = nf_put_var_double( ncid, id_orog_filt, oro(:dim1,:dim2)) call netcdf_err(error, 'write var orog_filt for file='//trim(outfile) ) error = nf_put_var_double( ncid, id_stddev, hprime(:dim1,:dim2,1)) From a052eef31dbd51e8f19ac624d2091faed0bf2a9b Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 28 Jun 2024 13:30:43 +0000 Subject: [PATCH 04/54] Remove computation of latitude for obsolete gaussian grids. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 48 ++++++------------- 1 file changed, 15 insertions(+), 33 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 94ccda983..306c64646 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -70,21 +70,21 @@ C> - GBYTES - UNPACK BITS C> C> @return 0 for success, error code otherwise. + implicit none include 'netcdf.inc' logical fexist, opened + integer imn, jmn integer fsize, ncid, error, id_dim, nx, ny character(len=256) :: OUTGRID = "none" character(len=256) :: INPUTOROG = "none" character(len=256) :: merge_file = "none" logical :: mask_only = .false. - integer :: MTNRES,IM,JM,NM,NR,EFAC + integer :: MTNRES,IM,JM,EFAC fsize=65536 READ(5,*) OUTGRID READ(5,*) mask_only READ(5,*) merge_file - NM=0 EFAC=0 - NR=0 print*, "INPUTOROG= ", trim(INPUTOROG) print*, "MASK_ONLY", mask_only print*, "MERGE_FILE ", trim(merge_file) @@ -95,7 +95,7 @@ ! --- other possibilities are =8 for 4' and =4 for 2' see ! HJ for T1000 test. Must set to 1 for now. MTNRES=1 - print*, MTNRES,NM,NR,EFAC + print*, MTNRES,EFAC IMN = 360*120/MTNRES JMN = 180*120/MTNRES print *, ' Starting terr12 mtnlm7_slm30.f IMN,JMN:',IMN,JMN @@ -134,7 +134,7 @@ error=nf_close(ncid) call netcdf_err(error, 'close file '//trim(OUTGRID) ) - CALL TERSUB(IMN,JMN,IM,JM,NM,NR,EFAC, + CALL TERSUB(IMN,JMN,IM,JM,EFAC, & OUTGRID,INPUTOROG,MASK_ONLY,MERGE_FILE) STOP END @@ -145,8 +145,6 @@ !! @param[in] JMN "j" dimension of the input terrain dataset. !! @param[in] IM "i" dimension of the model grid tile. !! @param[in] JM "j" dimension of the model grid tile. -!! @param[in] NM Spectral truncation. -!! @param[in] NR Rhomboidal flag. !! @param[in] EFAC Factor to adjust orography by its variance. !! @param[in] OUTGRID The 'grid' file for the model tile. !! @param[in] INPUTOROG Input orography/GWD file on gaussian @@ -156,12 +154,12 @@ !! @param[in] MASK_ONLY Flag to generate the Land Mask only !! @param[in] MERGE_FILE Ocean merge file !! @author Jordan Alpert NOAA/EMC - SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,EFAC, + SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, & OUTGRID,INPUTOROG,MASK_ONLY,MERGE_FILE) implicit none include 'netcdf.inc' C - integer :: IMN,JMN,IM,JM,NM,NR + integer :: IMN,JMN,IM,JM character(len=*), intent(in) :: OUTGRID character(len=*), intent(in) :: INPUTOROG character(len=*), intent(in) :: MERGE_FILE @@ -192,7 +190,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,EFAC, integer, allocatable :: IWORK(:,:,:) real :: DEGRAD,maxlat, minlat,timef,tbeg,tend,tbeg1 - real :: PHI,DELXN,slma,oroa,vara,var4a,xn,XS + real :: DELXN,slma,oroa,vara,var4a,xn,XS real :: sumdif,avedif real, allocatable :: COSCLT(:),WGTCLT(:),RCLT(:),XLAT(:),DIFFX(:) @@ -214,7 +212,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,EFAC, real, allocatable :: oa_in(:,:,:), ol_in(:,:,:) logical :: grid_from_file,fexist,opened - logical :: SPECTR logical :: is_south_pole(IM,JM), is_north_pole(IM,JM) tbeg1=timef() @@ -237,7 +234,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,EFAC, ! SET CONSTANTS AND ZERO FIELDS ! DEGRAD = 180./PI - SPECTR = NM .GT. 0 ! if NM <=0 grid is assumed lat/lon MSKOCN = 1 ! Ocean land sea mask =1, =0 if not present NOTOCN = 1 ! =1 Ocean lsm input reverse: Ocean=1, land=0 ! --- The LSM Gaussian file from the ocean model sometimes arrives with @@ -291,8 +287,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,EFAC, ! ! --- IMN,JMN - print*, ' IM, JM, NM, NR, EFAC' - print*, IM,JM,NM,NR,EFAC + print*, ' IM, JM, EFAC' + print*, IM,JM,EFAC print *,' imn,jmn,glob(imn,jmn)=',imn,jmn,glob(imn,jmn) print *,' UBOUND ZAVG=',UBOUND(ZAVG) print *,' UBOUND glob=',UBOUND(glob) @@ -354,25 +350,11 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,EFAC, ! ! This code assumes that lat runs from north to south for gg! ! - - print *,' SPECTR=',SPECTR,' ** with GICE-07 **' - IF (SPECTR) THEN - CALL SPLAT(4,JM,COSCLT,WGTCLT) - DO J=1,JM/2 - RCLT(J) = ACOS(COSCLT(J)) - ENDDO - DO J = 1,JM/2 - PHI = RCLT(J) * DEGRAD - XLAT(J) = 90. - PHI - XLAT(JM-J+1) = PHI - 90. - ENDDO - ELSE - CALL SPLAT(0,JM,COSCLT,WGTCLT) - DO J=1,JM - RCLT(J) = ACOS(COSCLT(J)) - XLAT(J) = 90.0 - RCLT(J) * DEGRAD - ENDDO - ENDIF + CALL SPLAT(0,JM,COSCLT,WGTCLT) + DO J=1,JM + RCLT(J) = ACOS(COSCLT(J)) + XLAT(J) = 90.0 - RCLT(J) * DEGRAD + ENDDO allocate (GICE(IMN+1,3601)) ! From 14c0faf7fd9d61db1de1c5e320bb4019ccf03d99 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 28 Jun 2024 15:05:59 +0000 Subject: [PATCH 05/54] More clean up. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 309 ++++++++---------- 1 file changed, 128 insertions(+), 181 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 306c64646..5d13a3d11 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -16,11 +16,6 @@ C> 6. grib sea-land mask on model physics grid C> 7. grib gridded orography on model physics grid C> -C> The orography is only filtered for wavenumbers greater than nf0. For -C> wavenumbers n between nf0 and nf1, the orography is filtered by the -C> factor 1-((n-nf0)/(nf1-nf0))**2. The filtered orography will not have -C> information beyond wavenumber nf1. -C> C> PROGRAM HISTORY LOG: C> - 92-04-16 IREDELL C> - 98-02-02 IREDELL FILTER @@ -37,12 +32,6 @@ C> - 05-09-05 if test on HK and HLPRIM for GAMMA SQRT C> - 07-08-07 replace 8' with 30" incl GICE, conintue w/ S-Y. lake slm C> - 08-08-07 All input 30", UMD option, and filter as described below -C> Quadratic filter applied by default. -C> NF0 is normally set to an even value beyond the previous truncation, -C> for example, for jcap=382, NF0=254+2 -C> NF1 is set as jcap+2 (and/or nearest even), eg., for t382, NF1=382+2=384 -C> if no filter is desired then NF1=NF0=0 and ORF=ORO -C> but if no filter but spectral to grid (with gibbs) then NF1=jcap+2, and NF1=jcap+1 C> C> INPUT FILES: C> - UNIT5 - PHYSICS LONGITUDES (IM), PHYSICS LATITUDES (JM), @@ -191,9 +180,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, real :: DEGRAD,maxlat, minlat,timef,tbeg,tend,tbeg1 real :: DELXN,slma,oroa,vara,var4a,xn,XS - real :: sumdif,avedif - real, allocatable :: COSCLT(:),WGTCLT(:),RCLT(:),XLAT(:),DIFFX(:) + real, allocatable :: COSCLT(:),WGTCLT(:),RCLT(:),XLAT(:) real, allocatable :: XLON(:),oaa(:),ola(:),GLAT(:) real, allocatable :: GEOLON(:,:),GEOLON_C(:,:),DX(:,:) @@ -223,7 +211,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, allocate (glob(IMN,JMN)) ! reals - allocate (COSCLT(JM),WGTCLT(JM),RCLT(JM),XLAT(JM),DIFFX(JM/2)) + allocate (COSCLT(JM),WGTCLT(JM),RCLT(JM),XLAT(JM)) allocate (XLON(IM),oaa(4),ola(4),GLAT(JMN)) allocate (ZAVG(IMN,JMN)) @@ -347,9 +335,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, do j=1,jm numi(j)=im enddo -! -! This code assumes that lat runs from north to south for gg! -! +! When the gaussian grid routines makemt, makepc and makeoa are +! removed, xlat can be removed. CALL SPLAT(0,JM,COSCLT,WGTCLT) DO J=1,JM RCLT(J) = ACOS(COSCLT(J)) @@ -358,18 +345,9 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, allocate (GICE(IMN+1,3601)) ! - sumdif = 0. - DO J = JM/2,2,-1 - DIFFX(J) = xlat(J) - XLAT(j-1) - sumdif = sumdif + DIFFX(J) - ENDDO - avedif=sumdif/(float(JM/2)) -! print *,' XLAT= avedif: ',avedif -! write (6,107) (xlat(J)-xlat(j-1),J=JM,2,-1) print *,' XLAT=' write (6,106) (xlat(J),J=JM,1,-1) 106 format( 10(f7.3,1x)) - 107 format( 10(f9.5,1x)) C DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION C @@ -491,177 +469,157 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, allocate (land_frac(IM,JM),lake_frac(IM,JM)) !--- reading grid file. - grid_from_file = .false. is_south_pole = .false. is_north_pole = .false. i_south_pole = 0 j_south_pole = 0 i_north_pole = 0 j_north_pole = 0 - if( trim(OUTGRID) .NE. "none" ) then - grid_from_file = .true. - inquire(file=trim(OUTGRID), exist=fexist) - if(.not. fexist) then - print*, "FATAL ERROR: file "//trim(OUTGRID) - print*, "does not exist." - CALL ERREXIT(4) - endif - do ncid = 103, 512 - inquire( ncid,OPENED=opened ) - if( .NOT.opened )exit - end do - - print*, "outgrid=", trim(outgrid) - error=NF__OPEN(trim(OUTGRID),NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Open file '//trim(OUTGRID) ) - error=nf_inq_dimid(ncid, 'nx', id_dim) - call netcdf_err(error, 'inquire dimension nx from file '// + + grid_from_file = .true. + inquire(file=trim(OUTGRID), exist=fexist) + if(.not. fexist) then + print*, "FATAL ERROR: file "//trim(OUTGRID) + print*, "does not exist." + CALL ERREXIT(4) + endif + do ncid = 103, 512 + inquire( ncid,OPENED=opened ) + if( .NOT.opened )exit + end do + + print*, "outgrid=", trim(outgrid) + error=NF__OPEN(trim(OUTGRID),NF_NOWRITE,fsize,ncid) + call netcdf_err(error, 'Open file '//trim(OUTGRID) ) + error=nf_inq_dimid(ncid, 'nx', id_dim) + call netcdf_err(error, 'inquire dimension nx from file '// & trim(OUTGRID) ) - nx = 2*IM - ny = 2*JM - print*, "Read the grid from file "//trim(OUTGRID) + nx = 2*IM + ny = 2*JM + print*, "Read the grid from file "//trim(OUTGRID) - allocate(tmpvar(nx+1,ny+1)) + allocate(tmpvar(nx+1,ny+1)) - error=nf_inq_varid(ncid, 'x', id_var) - call netcdf_err(error, 'inquire varid of x from file ' + error=nf_inq_varid(ncid, 'x', id_var) + call netcdf_err(error, 'inquire varid of x from file ' & //trim(OUTGRID) ) - error=nf_get_var_double(ncid, id_var, tmpvar) - call netcdf_err(error, 'inquire data of x from file ' + error=nf_get_var_double(ncid, id_var, tmpvar) + call netcdf_err(error, 'inquire data of x from file ' & //trim(OUTGRID) ) - !--- adjust lontitude to be between 0 and 360. - do j = 1,ny+1; do i = 1,nx+1 - if(tmpvar(i,j) .NE. MISSING_VALUE) then - if(tmpvar(i,j) .GT. 360) tmpvar(i,j) = tmpvar(i,j) - 360 - if(tmpvar(i,j) .LT. 0) tmpvar(i,j) = tmpvar(i,j) + 360 - endif - enddo; enddo + !--- adjust lontitude to be between 0 and 360. + do j = 1,ny+1; do i = 1,nx+1 + if(tmpvar(i,j) .NE. MISSING_VALUE) then + if(tmpvar(i,j) .GT. 360) tmpvar(i,j) = tmpvar(i,j) - 360 + if(tmpvar(i,j) .LT. 0) tmpvar(i,j) = tmpvar(i,j) + 360 + endif + enddo; enddo - geolon(1:IM,1:JM) = tmpvar(2:nx:2,2:ny:2) - geolon_c(1:IM+1,1:JM+1) = tmpvar(1:nx+1:2,1:ny+1:2) + geolon(1:IM,1:JM) = tmpvar(2:nx:2,2:ny:2) + geolon_c(1:IM+1,1:JM+1) = tmpvar(1:nx+1:2,1:ny+1:2) - error=nf_inq_varid(ncid, 'y', id_var) - call netcdf_err(error, 'inquire varid of y from file ' + error=nf_inq_varid(ncid, 'y', id_var) + call netcdf_err(error, 'inquire varid of y from file ' & //trim(OUTGRID) ) - error=nf_get_var_double(ncid, id_var, tmpvar) - call netcdf_err(error, 'inquire data of y from file ' + error=nf_get_var_double(ncid, id_var, tmpvar) + call netcdf_err(error, 'inquire data of y from file ' & //trim(OUTGRID) ) - geolat(1:IM,1:JM) = tmpvar(2:nx:2,2:ny:2) - geolat_c(1:IM+1,1:JM+1) = tmpvar(1:nx+1:2,1:ny+1:2) + geolat(1:IM,1:JM) = tmpvar(2:nx:2,2:ny:2) + geolat_c(1:IM+1,1:JM+1) = tmpvar(1:nx+1:2,1:ny+1:2) - !--- figure out pole location. - maxlat = -90 - minlat = 90 + !--- figure out pole location. + maxlat = -90 + minlat = 90 + i_north_pole = 0 + j_north_pole = 0 + i_south_pole = 0 + j_south_pole = 0 + do j = 1, ny+1; do i = 1, nx+1 + if( tmpvar(i,j) > maxlat ) then + i_north_pole=i + j_north_pole=j + maxlat = tmpvar(i,j) + endif + if( tmpvar(i,j) < minlat ) then + i_south_pole=i + j_south_pole=j + minlat = tmpvar(i,j) + endif + enddo ; enddo + !--- only when maxlat is close to 90. the point is north pole + if(maxlat < 89.9 ) then i_north_pole = 0 j_north_pole = 0 + endif + if(minlat > -89.9 ) then i_south_pole = 0 j_south_pole = 0 - do j = 1, ny+1; do i = 1, nx+1 - if( tmpvar(i,j) > maxlat ) then - i_north_pole=i - j_north_pole=j - maxlat = tmpvar(i,j) - endif - if( tmpvar(i,j) < minlat ) then - i_south_pole=i - j_south_pole=j - minlat = tmpvar(i,j) - endif - enddo ; enddo - !--- only when maxlat is close to 90. the point is north pole - if(maxlat < 89.9 ) then - i_north_pole = 0 - j_north_pole = 0 - endif - if(minlat > -89.9 ) then - i_south_pole = 0 - j_south_pole = 0 - endif - print*, "minlat=", minlat, "maxlat=", maxlat - print*, "north pole supergrid index is ", + endif + print*, "minlat=", minlat, "maxlat=", maxlat + print*, "north pole supergrid index is ", & i_north_pole, j_north_pole - print*, "south pole supergrid index is ", + print*, "south pole supergrid index is ", & i_south_pole, j_south_pole - deallocate(tmpvar) + deallocate(tmpvar) - if(i_south_pole >0 .and. j_south_pole > 0) then - if(mod(i_south_pole,2)==0) then ! stretched grid - do j = 1, JM; do i = 1, IM - if(i==i_south_pole/2 .and. (j==j_south_pole/2 + if(i_south_pole >0 .and. j_south_pole > 0) then + if(mod(i_south_pole,2)==0) then ! stretched grid + do j = 1, JM; do i = 1, IM + if(i==i_south_pole/2 .and. (j==j_south_pole/2 & .or. j==j_south_pole/2+1) ) then + is_south_pole(i,j) = .true. + print*, "south pole at i,j=", i, j + endif + enddo; enddo + else + do j = 1, JM; do i = 1, IM + if((i==i_south_pole/2 .or. i==i_south_pole/2+1) + & .and. (j==j_south_pole/2 .or. + & j==j_south_pole/2+1) ) then is_south_pole(i,j) = .true. print*, "south pole at i,j=", i, j - endif - enddo; enddo - else - do j = 1, JM; do i = 1, IM - if((i==i_south_pole/2 .or. i==i_south_pole/2+1) - & .and. (j==j_south_pole/2 .or. - & j==j_south_pole/2+1) ) then - is_south_pole(i,j) = .true. - print*, "south pole at i,j=", i, j - endif - enddo; enddo - endif - endif - if(i_north_pole >0 .and. j_north_pole > 0) then - if(mod(i_north_pole,2)==0) then ! stretched grid - do j = 1, JM; do i = 1, IM - if(i==i_north_pole/2 .and. (j==j_north_pole/2 .or. + endif + enddo; enddo + endif + endif + + if(i_north_pole >0 .and. j_north_pole > 0) then + if(mod(i_north_pole,2)==0) then ! stretched grid + do j = 1, JM; do i = 1, IM + if(i==i_north_pole/2 .and. (j==j_north_pole/2 .or. & j==j_north_pole/2+1) ) then - is_north_pole(i,j) = .true. - print*, "north pole at i,j=", i, j - endif - enddo; enddo - else - do j = 1, JM; do i = 1, IM - if((i==i_north_pole/2 .or. i==i_north_pole/2+1) + is_north_pole(i,j) = .true. + print*, "north pole at i,j=", i, j + endif + enddo; enddo + else + do j = 1, JM; do i = 1, IM + if((i==i_north_pole/2 .or. i==i_north_pole/2+1) & .and. (j==j_north_pole/2 .or. & j==j_north_pole/2+1) ) then - is_north_pole(i,j) = .true. - print*, "north pole at i,j=", i, j - endif - enddo; enddo - endif - endif - + is_north_pole(i,j) = .true. + print*, "north pole at i,j=", i, j + endif + enddo; enddo + endif + endif - allocate(tmpvar(nx,ny)) - error=nf_inq_varid(ncid, 'area', id_var) - call netcdf_err(error, 'inquire varid of area from file ' + allocate(tmpvar(nx,ny)) + error=nf_inq_varid(ncid, 'area', id_var) + call netcdf_err(error, 'inquire varid of area from file ' & //trim(OUTGRID) ) - error=nf_get_var_double(ncid, id_var, tmpvar) - call netcdf_err(error, 'inquire data of area from file ' + error=nf_get_var_double(ncid, id_var, tmpvar) + call netcdf_err(error, 'inquire data of area from file ' & //trim(OUTGRID) ) - do j = 1, jm - do i = 1, im - dx(i,j) = sqrt(tmpvar(2*i-1,2*j-1)+tmpvar(2*i,2*j-1) - & +tmpvar(2*i-1,2*j )+tmpvar(2*i,2*j )) - dy(i,j) = dx(i,j) - enddo + do j = 1, jm + do i = 1, im + dx(i,j) = sqrt(tmpvar(2*i-1,2*j-1)+tmpvar(2*i,2*j-1) + & +tmpvar(2*i-1,2*j )+tmpvar(2*i,2*j )) + dy(i,j) = dx(i,j) enddo -! allocate(tmpvar(nx,ny+1)) - -! error=nf_inq_varid(ncid, 'dx', id_var) -! call netcdf_err(error, 'inquire varid of dx from file ' -! & //trim(OUTGRID) ) -! error=nf_get_var_double(ncid, id_var, tmpvar) -! call netcdf_err(error, 'inquire data of dx from file ' -! & //trim(OUTGRID) ) -! dx(1:IM,1:JM+1) = tmpvar(2:nx:2,1:ny+1:2) -! deallocate(tmpvar) - -! allocate(tmpvar(nx+1,ny)) -! error=nf_inq_varid(ncid, 'dy', id_var) -! call netcdf_err(error, 'inquire varid of dy from file ' -! & //trim(OUTGRID) ) -! error=nf_get_var_double(ncid, id_var, tmpvar) -! call netcdf_err(error, 'inquire data of dy from file ' -! & //trim(OUTGRID) ) -! dy(1:IM+1,1:JM) = tmpvar(1:nx+1:2,2:ny:2) - deallocate(tmpvar) - endif + enddo + deallocate(tmpvar) + tend=timef() write(6,*)' Timer 1 time= ',tend-tbeg ! @@ -1173,24 +1131,13 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, write(6,*)' Timer 5 time= ',tend-tbeg C DELXN = 360./IM - do i=1,im - xlon(i) = DELXN*(i-1) + + do j = 1, jm + xlat(j) = geolat(1,j) + enddo + do i = 1, im + xlon(i) = geolon(i,1) enddo - IF(trim(OUTGRID) == "none") THEN - do j=1,jm - do i=1,im - geolon(i,j) = xlon(i) - geolat(i,j) = xlat(j) - enddo - enddo - else - do j = 1, jm - xlat(j) = geolat(1,j) - enddo - do i = 1, im - xlon(i) = geolon(i,1) - enddo - endif tbeg=timef() CALL WRITE_NETCDF(IM,JM,SLM,land_frac,ORO,HPRIME,1,1, @@ -1203,7 +1150,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ! Deallocate 1d vars deallocate(JST,JEN,numi) - deallocate(COSCLT,WGTCLT,RCLT,XLAT,DIFFX,XLON,oaa,ola,GLAT) + deallocate(COSCLT,WGTCLT,RCLT,XLAT,XLON,oaa,ola,GLAT) ! Deallocate 2d vars deallocate (OCLSM) From c848aeba7102d0fe36ae247b23cc4cffcc961e88 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 28 Jun 2024 17:03:11 +0000 Subject: [PATCH 06/54] Remove some logic associated with obsolete routine makeoa3. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 138 ++---------------- 1 file changed, 9 insertions(+), 129 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 5d13a3d11..44f7a82be 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -65,7 +65,6 @@ integer imn, jmn integer fsize, ncid, error, id_dim, nx, ny character(len=256) :: OUTGRID = "none" - character(len=256) :: INPUTOROG = "none" character(len=256) :: merge_file = "none" logical :: mask_only = .false. integer :: MTNRES,IM,JM,EFAC @@ -74,7 +73,6 @@ READ(5,*) mask_only READ(5,*) merge_file EFAC=0 - print*, "INPUTOROG= ", trim(INPUTOROG) print*, "MASK_ONLY", mask_only print*, "MERGE_FILE ", trim(merge_file) ! --- MTNRES defines the input (highest) elev resolution @@ -124,7 +122,7 @@ call netcdf_err(error, 'close file '//trim(OUTGRID) ) CALL TERSUB(IMN,JMN,IM,JM,EFAC, - & OUTGRID,INPUTOROG,MASK_ONLY,MERGE_FILE) + & OUTGRID,MASK_ONLY,MERGE_FILE) STOP END @@ -136,7 +134,6 @@ !! @param[in] JM "j" dimension of the model grid tile. !! @param[in] EFAC Factor to adjust orography by its variance. !! @param[in] OUTGRID The 'grid' file for the model tile. -!! @param[in] INPUTOROG Input orography/GWD file on gaussian !! grid. When specified, will be interpolated to model tile. !! When not specified, program will create fields from !! raw high-resolution topography data. @@ -144,13 +141,12 @@ !! @param[in] MERGE_FILE Ocean merge file !! @author Jordan Alpert NOAA/EMC SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, - & OUTGRID,INPUTOROG,MASK_ONLY,MERGE_FILE) + & OUTGRID,MASK_ONLY,MERGE_FILE) implicit none include 'netcdf.inc' C integer :: IMN,JMN,IM,JM character(len=*), intent(in) :: OUTGRID - character(len=*), intent(in) :: INPUTOROG character(len=*), intent(in) :: MERGE_FILE logical, intent(in) :: mask_only @@ -162,7 +158,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, integer :: efac,zsave1,zsave2 integer :: mskocn,notocn integer :: i,j,nx,ny,ncid,js,jn,iw,ie,k,it,jt,error,id_dim - integer :: id_var,nx_in,ny_in,fsize,wgta,IN,INW,INE,IS,ISW,ISE + integer :: id_var,fsize,wgta,IN,INW,INE,IS,ISW,ISE integer :: ios,istat,itest,jtest integer :: i_south_pole,j_south_pole,i_north_pole,j_north_pole integer :: maxc3,maxc4,maxc5,maxc6,maxc7,maxc8 @@ -193,11 +189,9 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, real, allocatable :: WORK1(:,:),WORK2(:,:),WORK3(:,:),WORK4(:,:) real, allocatable :: WORK5(:,:),WORK6(:,:) real, allocatable :: tmpvar(:,:) - real, allocatable :: slm_in(:,:), lon_in(:,:), lat_in(:,:) real(4), allocatable:: GICE(:,:),OCLSM(:,:) real, allocatable :: OA(:,:,:),OL(:,:,:),HPRIME(:,:,:) - real, allocatable :: oa_in(:,:,:), ol_in(:,:,:) logical :: grid_from_file,fexist,opened logical :: is_south_pole(IM,JM), is_north_pole(IM,JM) @@ -698,130 +692,16 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, allocate (WORK5(IM,JM),WORK6(IM,JM)) call minmxj(IM,JM,ORO,' ORO') - print*, "inputorog=", trim(INPUTOROG) + if(grid_from_file) then - if(trim(INPUTOROG) == "none") then - print*, "calling MAKEOA2 to compute OA, OL" - tbeg=timef() - CALL MAKEOA2(ZAVG,zslm,VAR,GLAT,OA,OL,IWORK,ELVMAX,ORO, + print*, "calling MAKEOA2 to compute OA, OL" + tbeg=timef() + CALL MAKEOA2(ZAVG,zslm,VAR,GLAT,OA,OL,IWORK,ELVMAX,ORO, 1 WORK1,WORK2,WORK3,WORK4,WORK5,WORK6, 2 IM,JM,IMN,JMN,geolon_c,geolat_c, 3 geolon,geolat,dx,dy,is_south_pole,is_north_pole) - tend=timef() - write(6,*)' MAKEOA2 time= ',tend-tbeg - else - !-- read the data from INPUTOROG file. - error=NF__OPEN(trim(INPUTOROG),NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Open file '//trim(INPUTOROG) ) - error=nf_inq_dimid(ncid, 'lon', id_dim) - call netcdf_err(error, 'inquire dimension lon from file '// - & trim(INPUTOROG) ) - error=nf_inq_dimlen(ncid,id_dim,nx_in) - call netcdf_err(error, 'inquire dimension lon length '// - & 'from file '//trim(INPUTOROG) ) - error=nf_inq_dimid(ncid, 'lat', id_dim) - call netcdf_err(error, 'inquire dimension lat from file '// - & trim(INPUTOROG) ) - error=nf_inq_dimlen(ncid,id_dim,ny_in) - call netcdf_err(error, 'inquire dimension lat length '// - & 'from file '//trim(INPUTOROG) ) - - print*, "extrapolate OA, OL from Gaussian grid with nx=", - & nx_in, ", ny=", ny_in - allocate(oa_in(nx_in,ny_in,4), ol_in(nx_in,ny_in,4)) - allocate(slm_in(nx_in,ny_in) ) - allocate(lon_in(nx_in,ny_in), lat_in(nx_in,ny_in) ) - - error=nf_inq_varid(ncid, 'oa1', id_var) - call netcdf_err(error, 'inquire varid of oa1 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, oa_in(:,:,1)) - call netcdf_err(error, 'inquire data of oa1 from file ' - & //trim(INPUTOROG) ) - error=nf_inq_varid(ncid, 'oa2', id_var) - call netcdf_err(error, 'inquire varid of oa2 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, oa_in(:,:,2)) - call netcdf_err(error, 'inquire data of oa2 from file ' - & //trim(INPUTOROG) ) - error=nf_inq_varid(ncid, 'oa3', id_var) - call netcdf_err(error, 'inquire varid of oa3 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, oa_in(:,:,3)) - call netcdf_err(error, 'inquire data of oa3 from file ' - & //trim(INPUTOROG) ) - error=nf_inq_varid(ncid, 'oa4', id_var) - call netcdf_err(error, 'inquire varid of oa4 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, oa_in(:,:,4)) - call netcdf_err(error, 'inquire data of oa4 from file ' - & //trim(INPUTOROG) ) - - error=nf_inq_varid(ncid, 'ol1', id_var) - call netcdf_err(error, 'inquire varid of ol1 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, ol_in(:,:,1)) - call netcdf_err(error, 'inquire data of ol1 from file ' - & //trim(INPUTOROG) ) - error=nf_inq_varid(ncid, 'ol2', id_var) - call netcdf_err(error, 'inquire varid of ol2 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, ol_in(:,:,2)) - call netcdf_err(error, 'inquire data of ol2 from file ' - & //trim(INPUTOROG) ) - error=nf_inq_varid(ncid, 'ol3', id_var) - call netcdf_err(error, 'inquire varid of ol3 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, ol_in(:,:,3)) - call netcdf_err(error, 'inquire data of ol3 from file ' - & //trim(INPUTOROG) ) - error=nf_inq_varid(ncid, 'ol4', id_var) - call netcdf_err(error, 'inquire varid of ol4 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, ol_in(:,:,4)) - call netcdf_err(error, 'inquire data of ol4 from file ' - & //trim(INPUTOROG) ) - - error=nf_inq_varid(ncid, 'slmsk', id_var) - call netcdf_err(error, 'inquire varid of slmsk from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, slm_in) - call netcdf_err(error, 'inquire data of slmsk from file ' - & //trim(INPUTOROG) ) - - error=nf_inq_varid(ncid, 'geolon', id_var) - call netcdf_err(error, 'inquire varid of geolon from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, lon_in) - call netcdf_err(error, 'inquire data of geolon from file ' - & //trim(INPUTOROG) ) - - error=nf_inq_varid(ncid, 'geolat', id_var) - call netcdf_err(error, 'inquire varid of geolat from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, lat_in) - call netcdf_err(error, 'inquire data of geolat from file ' - & //trim(INPUTOROG) ) - - ! set slmsk=2 to be ocean (0) - do j=1,ny_in; do i=1,nx_in - if(slm_in(i,j) == 2) slm_in(i,j) = 0 - enddo; enddo - - error=nf_close(ncid) - call netcdf_err(error, 'close file ' - & //trim(INPUTOROG) ) - - print*, "calling MAKEOA3 to compute OA, OL" - CALL MAKEOA3(ZAVG,VAR,GLAT,OA,OL,IWORK,ELVMAX,ORO,SLM, - 1 WORK1,WORK2,WORK3,WORK4,WORK5,WORK6, - 2 IM,JM,IMN,JMN,geolon_c,geolat_c, - 3 geolon,geolat,nx_in,ny_in, - 4 oa_in,ol_in,slm_in,lon_in,lat_in) - - deallocate(oa_in,ol_in,slm_in,lon_in,lat_in) - - endif + tend=timef() + write(6,*)' MAKEOA2 time= ',tend-tbeg else CALL MAKEOA(ZAVG,VAR,GLAT,OA,OL,IWORK,ELVMAX,ORO, 1 WORK1,WORK2,WORK3,WORK4, From 65c9eceeed85ee661593940e1cbebe087fe9f125 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 28 Jun 2024 18:09:20 +0000 Subject: [PATCH 07/54] Remove obsolete routine MAKEOA3 and some functions. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 534 ------------------ 1 file changed, 534 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 44f7a82be..37737e219 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -3042,540 +3042,6 @@ function spherical_distance(theta1,phi1,theta2,phi2) end function spherical_distance -!> For unmapped land points, find the nearest land point -!! on the input data and pass back its i/j index. -!! -!! @param[in] im_in 'i' dimension of input data. -!! @param[in] jm_in 'j' dimension of input data. -!! @param[in] geolon_in Longitude of input data. -!! @param[in] geolat_in Latitude of input data. -!! @param[in] bitmap_in Bitmap (mask) of input data. -!! @param[in] num_out Number of unmapped points. -!! @param[in] lon_out Longitude of unmapped points. -!! @param[in] lat_out Latitude of unmapped points. -!! @param[out] iindx 'i' indices of nearest land points -!! on the input data. -!! @param[out] jindx 'j' indices of nearest land points -!! on the input data. -!! @author GFDL progammer - subroutine get_mismatch_index(im_in, jm_in, geolon_in,geolat_in, - & bitmap_in,num_out, lon_out,lat_out, iindx, jindx ) - integer, intent(in) :: im_in, jm_in, num_out - real, intent(in) :: geolon_in(im_in,jm_in) - real, intent(in) :: geolat_in(im_in,jm_in) - logical*1, intent(in) :: bitmap_in(im_in,jm_in) - real, intent(in) :: lon_out(num_out), lat_out(num_out) - integer, intent(out):: iindx(num_out), jindx(num_out) - real, parameter :: MAX_DIST = 1.e+20 - integer, parameter :: NUMNBR = 20 - integer :: i_c,j_c,jstart,jend - real :: lon,lat - - print*, "im_in,jm_in = ", im_in, jm_in - print*, "num_out = ", num_out - print*, "max and min of lon_in is", minval(geolon_in), - & maxval(geolon_in) - print*, "max and min of lat_in is", minval(geolat_in), - & maxval(geolat_in) - print*, "max and min of lon_out is", minval(lon_out), - & maxval(lon_out) - print*, "max and min of lat_out is", minval(lat_out), - & maxval(lat_out) - print*, "count(bitmap_in)= ", count(bitmap_in), MAX_DIST - - do n = 1, num_out - ! print*, "n = ", n - lon = lon_out(n) - lat = lat_out(n) - !--- find the j-index for the nearest point - i_c = 0; j_c = 0 - do j = 1, jm_in-1 - if(lat .LE. geolat_in(1,j) .and. - & lat .GE. geolat_in(1,j+1)) then - j_c = j - endif - enddo - if(lat > geolat_in(1,1)) j_c = 1 - if(lat < geolat_in(1,jm_in)) j_c = jm_in - ! print*, "lat =", lat, geolat_in(1,jm_in), geolat_in(1,jm_in-1) - ! The input is Gaussian grid. - jstart = max(j_c-NUMNBR,1) - jend = min(j_c+NUMNBR,jm_in) - dist = MAX_DIST - iindx(n) = 0 - jindx(n) = 0 - ! print*, "jstart, jend =", jstart, jend - do j = jstart, jend; do i = 1,im_in - if(bitmap_in(i,j) ) then - ! print*, "bitmap_in is true" - d = spherical_distance(lon_out(n),lat_out(n), - & geolon_in(i,j), geolat_in(i,j)) - if( dist > d ) then - iindx(n) = i; jindx(n) = j - dist = d - endif - endif - enddo; enddo - if(iindx(n) ==0) then - print*, "lon,lat=", lon,lat - print*, "jstart, jend=", jstart, jend, dist - print*, "FATAL ERROR in get mismatch_index: " - print*, "did not find nearest points." - call ERREXIT(4) - endif - enddo - - end subroutine get_mismatch_index - -!> Replace unmapped model land points with the nearest land point on the -!! input grid. -!! -!! @param[in] im_in 'i' dimension of input grid. -!! @param[in] jm_in 'j' dimension of input grid. -!! @param[in] data_in Input grid data. -!! @param[in] num_out Number of unmapped model points. -!! @param[out] data_out Data on the model tile. -!! @param[in] iindx 'i' indices of the nearest land points on -!! the input grid. -!! @param[in] jindx 'j' indices of the nearest land points on -!! the input grid. -!! @author GFDL programmer - subroutine interpolate_mismatch(im_in, jm_in, data_in, - & num_out, data_out, iindx, jindx) - integer, intent(in) :: im_in, jm_in, num_out - real, intent(in) :: data_in(im_in,jm_in) - real, intent(out):: data_out(num_out) - integer, intent(in) :: iindx(num_out), jindx(num_out) - - do n = 1, num_out - data_out(n) = data_in(iindx(n),jindx(n)) - enddo - - end subroutine interpolate_mismatch - -!> Create orographic asymmetry and orographic length scale on -!! the model grid. This routine is used for the cubed-sphere -!! grid. The asymmetry and length scales are interpolated -!! from an existing gfs orography file. The maximum elevation -!! is computed from the high-resolution orography data. -!! -!! @param[in] zavg High-resolution orography data. -!! @param[in] var Standard deviation of orography on the model grid. -!! @param[out] glat Latitude of each row of input terrain dataset. -!! @param[out] oa4 Orographic asymmetry on the model grid. Four -!! directional components - W/S/SW/NW -!! @param[out] ol Orographic length scale on the model grid. Four -!! directional components - W/S/SW/NW -!! @param[out] ioa4 Count of oa4 values between certain thresholds. -!! @param[out] elvmax Maximum elevation within a model grid box. -!! @param[in] slm Land-mask on model grid. -!! @param[in] oro Orography on the model grid. -!! @param[out] oro1 Save array for model grid orography. -!! @param[in] xnsum Not used. -!! @param[in] xnsum1 Not used. -!! @param[in] xnsum2 Not used. -!! @param[in] xnsum3 Not used. -!! @param[in] xnsum4 Not used. -!! @param[in] im "i" dimension of the model grid tile. -!! @param[in] jm "j" dimension of the model grid tile. -!! @param[in] imn "i" dimension of the high-resolution orography and -!! mask data. -!! @param[in] jmn "j" dimension of the high-resolution orography and -!! mask data. -!! @param[in] lon_c Corner point longitudes of the model grid points. -!! @param[in] lat_c Corner point latitudes of the model grid points. -!! @param[in] lon_t Center point longitudes of the model grid points. -!! @param[in] lat_t Center point latitudes of the model grid points. -!! @param[in] imi 'i' dimension of input gfs orography data. -!! @param[in] jmi 'j' dimension of input gfs orography data. -!! @param[in] oa_in Asymmetry on the input gfs orography data. -!! @param[in] ol_in Length scales on the input gfs orography data. -!! @param[in] slm_in Land-sea mask on the input gfs orography data. -!! @param[in] lon_in Longitude on the input gfs orography data. -!! @param[in] lat_in Latitude on the input gfs orography data. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE MAKEOA3(ZAVG,VAR,GLAT,OA4,OL,IOA4,ELVMAX, - 1 ORO,SLM,oro1,XNSUM,XNSUM1,XNSUM2,XNSUM3,XNSUM4, - 2 IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t, - 3 IMI,JMI,OA_IN,OL_IN, - 4 slm_in,lon_in,lat_in) - -! Required when using iplib v4.0 or higher. -#ifdef IP_V4 - use ipolates_mod -#endif - - implicit none - real, parameter :: MISSING_VALUE = -9999. - real, parameter :: D2R = 3.14159265358979/180. - real, PARAMETER :: R2D=180./3.14159265358979 - integer IM,JM,IMN,JMN,IMI,JMI - real GLAT(JMN) - INTEGER ZAVG(IMN,JMN) - real SLM(IM,JM) - real ORO(IM,JM),ORO1(IM,JM),ELVMAX(IM,JM),ZMAX(IM,JM) - real OA4(IM,JM,4) - integer IOA4(IM,JM,4) - real OA_IN(IMI,JMI,4), OL_IN(IMI,JMI,4) - real slm_in(IMI,JMI) - real lon_in(IMI,JMI), lat_in(IMI,JMI) - real lon_c(IM+1,JM+1), lat_c(IM+1,JM+1) - real lon_t(IM,JM), lat_t(IM,JM) - real XNSUM(IM,JM),XNSUM1(IM,JM),XNSUM2(IM,JM) - real XNSUM3(IM,JM),XNSUM4(IM,JM) - real VAR(IM,JM),OL(IM,JM,4) - integer i,j,ilist(IMN),numx,i1,j1,ii1 - integer KWD - real LONO(4),LATO(4),LONI,LATI - real DELXN,HC,HEIGHT,T - integer NS0,NS1,NS2,NS3,NS4,NS5,NS6 - logical inside_a_polygon - integer jst, jen - integer int_opt, ipopt(20), kgds_input(200), kgds_output(200) - integer count_land_output - integer ij, ijmdl_output, iret, num_mismatch_land, num - integer ibo(1), ibi(1) - logical*1, allocatable :: bitmap_input(:,:) - logical*1, allocatable :: bitmap_output(:,:) - integer, allocatable :: ijsav_land_output(:) - real, allocatable :: lats_land_output(:) - real, allocatable :: lons_land_output(:) - real, allocatable :: output_data_land(:,:) - real, allocatable :: lons_mismatch_output(:) - real, allocatable :: lats_mismatch_output(:) - real, allocatable :: data_mismatch_output(:) - integer, allocatable :: iindx(:), jindx(:) -C -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C - ijmdl_output = IM*JM - - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO - print *,' IM=',IM,' JM=',JM,' IMN=',IMN,' JMN=',JMN -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C -C - DO J=1,JM - DO I=1,IM - XNSUM(I,J) = 0.0 - ELVMAX(I,J) = ORO(I,J) - ZMAX(I,J) = 0.0 -C---- COUNT NUMBER OF MODE. HIGHER THAN THE HC, CRITICAL HEIGHT -C IN A GRID BOX - XNSUM1(I,J) = 0.0 - XNSUM2(I,J) = 0.0 - XNSUM3(I,J) = 0.0 - XNSUM4(I,J) = 0.0 - ORO1(I,J) = ORO(I,J) - ELVMAX(I,J) = ZMAX(I,J) - ENDDO - ENDDO - -! --- # of peaks > ZAVG value and ZMAX(IM,JM) -- ORO is already avg. -! --- to JM or to JM1 - DO J=1,JM -! print*, "J=", J - DO I=1,IM - HC = 1116.2 - 0.878 * VAR(I,J) - LONO(1) = lon_c(i,j) - LONO(2) = lon_c(i+1,j) - LONO(3) = lon_c(i+1,j+1) - LONO(4) = lon_c(i,j+1) - LATO(1) = lat_c(i,j) - LATO(2) = lat_c(i+1,j) - LATO(3) = lat_c(i+1,j+1) - LATO(4) = lat_c(i,j+1) - call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) - do j1 = jst, jen; do ii1 = 1, numx - i1 = ilist(ii1) - LONI = i1*DELXN - LATI = -90 + j1*DELXN - if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO*D2R,LATO*D2R))then - - HEIGHT = FLOAT(ZAVG(I1,J1)) - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - IF ( HEIGHT .gt. ORO(I,J) ) then - if ( HEIGHT .gt. ZMAX(I,J) )ZMAX(I,J) = HEIGHT - ENDIF - endif - ENDDO ; ENDDO - ENDDO - ENDDO - -C -! --- this will make work1 array take on oro's values on return -! --- this will make work1 array take on oro's values on return - DO J=1,JM - DO I=1,IM - - ORO1(I,J) = ORO(I,J) - ELVMAX(I,J) = ZMAX(I,J) - ENDDO - ENDDO - - DO KWD = 1, 4 - DO J=1,JM - DO I=1,IM - OA4(I,J,KWD) = 0.0 - OL(I,J,KWD) = 0.0 - ENDDO - ENDDO - ENDDO - - !--- use the nearest point to do remapping. - int_opt = 2 - ipopt=0 - KGDS_INPUT = 0 - KGDS_INPUT(1) = 4 ! OCT 6 - TYPE OF GRID (GAUSSIAN) - KGDS_INPUT(2) = IMI ! OCT 7-8 - # PTS ON LATITUDE CIRCLE - KGDS_INPUT(3) = JMI ! OCT 9-10 - # PTS ON LONGITUDE CIRCLE - KGDS_INPUT(4) = 90000 ! OCT 11-13 - LAT OF ORIGIN - KGDS_INPUT(5) = 0 ! OCT 14-16 - LON OF ORIGIN - KGDS_INPUT(6) = 128 ! OCT 17 - RESOLUTION FLAG - KGDS_INPUT(7) = -90000 ! OCT 18-20 - LAT OF EXTREME POINT - KGDS_INPUT(8) = NINT(-360000./IMI) ! OCT 21-23 - LON OF EXTREME POINT - KGDS_INPUT(9) = NINT((360.0 / FLOAT(IMI))*1000.0) - ! OCT 24-25 - LONGITUDE DIRECTION INCR. - KGDS_INPUT(10) = JMI /2 ! OCT 26-27 - NUMBER OF CIRCLES POLE TO EQUATOR - KGDS_INPUT(12) = 255 ! OCT 29 - RESERVED - KGDS_INPUT(20) = 255 ! OCT 5 - NOT USED, SET TO 255 - - - KGDS_OUTPUT = -1 -! KGDS_OUTPUT(1) = IDRT ! OCT 6 - TYPE OF GRID (GAUSSIAN) - KGDS_OUTPUT(2) = IM ! OCT 7-8 - # PTS ON LATITUDE CIRCLE - KGDS_OUTPUT(3) = JM ! OCT 9-10 - # PTS ON LONGITUDE CIRCLE - KGDS_OUTPUT(4) = 90000 ! OCT 11-13 - LAT OF ORIGIN - KGDS_OUTPUT(5) = 0 ! OCT 14-16 - LON OF ORIGIN - KGDS_OUTPUT(6) = 128 ! OCT 17 - RESOLUTION FLAG - KGDS_OUTPUT(7) = -90000 ! OCT 18-20 - LAT OF EXTREME POINT - KGDS_OUTPUT(8) = NINT(-360000./IM) ! OCT 21-23 - LON OF EXTREME POINT - KGDS_OUTPUT(9) = NINT((360.0 / FLOAT(IM))*1000.0) - ! OCT 24-25 - LONGITUDE DIRECTION INCR. - KGDS_OUTPUT(10) = JM /2 ! OCT 26-27 - NUMBER OF CIRCLES POLE TO EQUATOR - KGDS_OUTPUT(12) = 255 ! OCT 29 - RESERVED - KGDS_OUTPUT(20) = 255 ! OCT 5 - NOT USED, SET TO 255 - - count_land_output=0 - print*, "sum(slm) = ", sum(slm) - do ij = 1, ijmdl_output - j = (ij-1)/IM + 1 - i = mod(ij-1,IM) + 1 - if (slm(i,j) > 0.0) then - count_land_output=count_land_output+1 - endif - enddo - allocate(bitmap_input(imi,jmi)) - bitmap_input=.false. - print*, "number of land input=", sum(slm_in) - where(slm_in > 0.0) bitmap_input=.true. - print*, "count(bitmap_input)", count(bitmap_input) - - allocate(bitmap_output(count_land_output,1)) - allocate(output_data_land(count_land_output,1)) - allocate(ijsav_land_output(count_land_output)) - allocate(lats_land_output(count_land_output)) - allocate(lons_land_output(count_land_output)) - - - - count_land_output=0 - do ij = 1, ijmdl_output - j = (ij-1)/IM + 1 - i = mod(ij-1,IM) + 1 - if (slm(i,j) > 0.0) then - count_land_output=count_land_output+1 - ijsav_land_output(count_land_output)=ij - lats_land_output(count_land_output)=lat_t(i,j) - lons_land_output(count_land_output)=lon_t(i,j) - endif - enddo - - oa4 = 0.0 - ol = 0.0 - ibi = 1 - - do KWD=1,4 - bitmap_output = .false. - output_data_land = 0.0 - call ipolates(int_opt, ipopt, kgds_input, kgds_output, - & (IMI*JMI), count_land_output, - & 1, ibi, bitmap_input, oa_in(:,:,KWD), - & count_land_output, lats_land_output, - & lons_land_output, ibo, - & bitmap_output, output_data_land, iret) - if (iret /= 0) then - print*,'- FATAL ERROR IN IPOLATES ',iret - call ERREXIT(4) - endif - - num_mismatch_land = 0 - do ij = 1, count_land_output - if (bitmap_output(ij,1)) then - j = (ijsav_land_output(ij)-1)/IM + 1 - i = mod(ijsav_land_output(ij)-1,IM) + 1 - oa4(i,j,KWD)=output_data_land(ij,1) - else ! default value - num_mismatch_land = num_mismatch_land + 1 - endif - enddo - print*, "num_mismatch_land = ", num_mismatch_land - - if(.not. allocated(data_mismatch_output)) then - allocate(lons_mismatch_output(num_mismatch_land)) - allocate(lats_mismatch_output(num_mismatch_land)) - allocate(data_mismatch_output(num_mismatch_land)) - allocate(iindx(num_mismatch_land)) - allocate(jindx(num_mismatch_land)) - - num = 0 - do ij = 1, count_land_output - if (.not. bitmap_output(ij,1)) then - num = num+1 - lons_mismatch_output(num) = lons_land_output(ij) - lats_mismatch_output(num) = lats_land_output(ij) - endif - enddo - - ! For those land points that with bitmap_output=.false. use - ! the nearest land points to interpolate. - print*,"before get_mismatch_index", count(bitmap_input) - call get_mismatch_index(imi,jmi,lon_in*D2R, - & lat_in*D2R,bitmap_input,num_mismatch_land, - & lons_mismatch_output*D2R,lats_mismatch_output*D2R, - & iindx, jindx ) - endif - - data_mismatch_output = 0 - call interpolate_mismatch(imi,jmi,oa_in(:,:,KWD), - & num_mismatch_land,data_mismatch_output,iindx,jindx) - - num = 0 - do ij = 1, count_land_output - if (.not. bitmap_output(ij,1)) then - num = num+1 - j = (ijsav_land_output(ij)-1)/IM + 1 - i = mod(ijsav_land_output(ij)-1,IM) + 1 - oa4(i,j,KWD) = data_mismatch_output(num) - if(i==372 .and. j== 611) then - print*, "ij=",ij, num, oa4(i,j,KWD),iindx(num),jindx(num) - endif - endif - enddo - - - enddo - - !OL - do KWD=1,4 - bitmap_output = .false. - output_data_land = 0.0 - call ipolates(int_opt, ipopt, kgds_input, kgds_output, - & (IMI*JMI), count_land_output, - & 1, ibi, bitmap_input, ol_in(:,:,KWD), - & count_land_output, lats_land_output, - & lons_land_output, ibo, - & bitmap_output, output_data_land, iret) - if (iret /= 0) then - print*,'- FATAL ERROR IN IPOLATES ',iret - call ERREXIT(4) - endif - - num_mismatch_land = 0 - do ij = 1, count_land_output - if (bitmap_output(ij,1)) then - j = (ijsav_land_output(ij)-1)/IM + 1 - i = mod(ijsav_land_output(ij)-1,IM) + 1 - ol(i,j,KWD)=output_data_land(ij,1) - else ! default value - num_mismatch_land = num_mismatch_land + 1 - endif - enddo - print*, "num_mismatch_land = ", num_mismatch_land - - data_mismatch_output = 0 - call interpolate_mismatch(imi,jmi,ol_in(:,:,KWD), - & num_mismatch_land,data_mismatch_output,iindx,jindx) - - num = 0 - do ij = 1, count_land_output - if (.not. bitmap_output(ij,1)) then - num = num+1 - j = (ijsav_land_output(ij)-1)/IM + 1 - i = mod(ijsav_land_output(ij)-1,IM) + 1 - ol(i,j,KWD) = data_mismatch_output(num) - if(i==372 .and. j== 611) then - print*, "ij=",ij, num, ol(i,j,KWD),iindx(num),jindx(num) - endif - endif - enddo - - - enddo - - deallocate(lons_mismatch_output,lats_mismatch_output) - deallocate(data_mismatch_output,iindx,jindx) - deallocate(bitmap_output,output_data_land) - deallocate(ijsav_land_output,lats_land_output) - deallocate(lons_land_output) - - DO KWD=1,4 - DO J=1,JM - DO I=1,IM - T = OA4(I,J,KWD) - OA4(I,J,KWD) = SIGN( MIN( ABS(T), 1. ), T ) - ENDDO - ENDDO - ENDDO -C - NS0 = 0 - NS1 = 0 - NS2 = 0 - NS3 = 0 - NS4 = 0 - NS5 = 0 - NS6 = 0 - DO KWD=1,4 - DO J=1,JM - DO I=1,IM - T = ABS( OA4(I,J,KWD) ) - IF(T .EQ. 0.) THEN - IOA4(I,J,KWD) = 0 - NS0 = NS0 + 1 - ELSE IF(T .GT. 0. .AND. T .LE. 1.) THEN - IOA4(I,J,KWD) = 1 - NS1 = NS1 + 1 - ELSE IF(T .GT. 1. .AND. T .LE. 10.) THEN - IOA4(I,J,KWD) = 2 - NS2 = NS2 + 1 - ELSE IF(T .GT. 10. .AND. T .LE. 100.) THEN - IOA4(I,J,KWD) = 3 - NS3 = NS3 + 1 - ELSE IF(T .GT. 100. .AND. T .LE. 1000.) THEN - IOA4(I,J,KWD) = 4 - NS4 = NS4 + 1 - ELSE IF(T .GT. 1000. .AND. T .LE. 10000.) THEN - IOA4(I,J,KWD) = 5 - NS5 = NS5 + 1 - ELSE IF(T .GT. 10000.) THEN - IOA4(I,J,KWD) = 6 - NS6 = NS6 + 1 - ENDIF - ENDDO - ENDDO - ENDDO -C - WRITE(6,*) "! MAKEOA3 EXIT" -C - RETURN - END SUBROUTINE MAKEOA3 - !> Print out the maximum and minimum values of !! an array. !! From 40b3114955c915647fc797d30d9502b694894fce Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 28 Jun 2024 19:25:11 +0000 Subject: [PATCH 08/54] Remove obsolete routine makeoa. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 377 +----------------- 1 file changed, 5 insertions(+), 372 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 37737e219..90e154e74 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -693,21 +693,14 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, call minmxj(IM,JM,ORO,' ORO') - if(grid_from_file) then - print*, "calling MAKEOA2 to compute OA, OL" - tbeg=timef() - CALL MAKEOA2(ZAVG,zslm,VAR,GLAT,OA,OL,IWORK,ELVMAX,ORO, + print*, "calling MAKEOA2 to compute OA, OL" + tbeg=timef() + CALL MAKEOA2(ZAVG,zslm,VAR,GLAT,OA,OL,IWORK,ELVMAX,ORO, 1 WORK1,WORK2,WORK3,WORK4,WORK5,WORK6, 2 IM,JM,IMN,JMN,geolon_c,geolat_c, 3 geolon,geolat,dx,dy,is_south_pole,is_north_pole) - tend=timef() - write(6,*)' MAKEOA2 time= ',tend-tbeg - else - CALL MAKEOA(ZAVG,VAR,GLAT,OA,OL,IWORK,ELVMAX,ORO, - 1 WORK1,WORK2,WORK3,WORK4, - 2 WORK5,WORK6, - 3 IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - endif + tend=timef() + write(6,*)' MAKEOA2 time= ',tend-tbeg ! Deallocate 2d vars deallocate(IST,IEN) @@ -2195,366 +2188,6 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, RETURN END SUBROUTINE MAKEPC2 -!> Create orographic asymmetry and orographic length scale on -!! the model grid. This routine is used for the spectral -!! GFS gaussian grid. -!! -!! @param[in] zavg The high-resolution input orography dataset. -!! @param[in] var Standard deviation of orography on the model grid. -!! @param[out] glat Latitude of each row of input terrain dataset. -!! @param[out] oa4 Orographic asymmetry on the model grid. Four -!! directional components - W/S/SW/NW -!! @param[out] ol Orographic length scale on the model grid. Four -!! directional components - W/S/SW/NW -!! @param[out] ioa4 Count of oa4 values between certain thresholds. -!! @param[out] elvmax Maximum elevation on the model grid. -!! @param[in] oro Orography on the model grid. -!! @param[out] oro1 Save array for model grid orography. -!! @param[out] xnsum Number of high-resolution orography points -!! higher than the model grid box average. -!! @param[out] xnsum1 Number of high-resolution orography points -!! higher than the critical height. -!! @param[out] xnsum2 Total number of high-resolution orography points -!! within a model grid box. -!! @param[out] xnsum3 Same as xnsum1, except shifted by half a -!! model grid box. -!! @param[out] xnsum4 Same as xnsum2, except shifted by half a -!! model grid box. -!! @param[out] ist This is the 'i' index of high-resolution data set -!! at the east edge of the model grid cell. -!! @param[out] ien This is the 'i' index of high-resolution data set -!! at the west edge of the model grid cell. -!! @param[out] jst This is the 'j' index of high-resolution data set -!! at the south edge of the model grid cell. -!! @param[out] jen This is the 'j' index of high-resolution data set -!! at the north edge of the model grid cell. -!! @param[in] im "i" dimension of the model grid. -!! @param[in] jm "j" dimension of the model grid. -!! @param[in] imn "i" dimension of the input terrain dataset. -!! @param[in] jmn "j" dimension of the input terrain dataset. -!! @param[in] xlat The latitude of each row of the model grid. -!! @param[in] numi For reduced gaussian grids, the number of 'i' points -!! for each 'j' row. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE MAKEOA(ZAVG,VAR,GLAT,OA4,OL,IOA4,ELVMAX, - 1 ORO,oro1,XNSUM,XNSUM1,XNSUM2,XNSUM3,XNSUM4, - 2 IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - DIMENSION GLAT(JMN),XLAT(JM) - INTEGER ZAVG(IMN,JMN) - DIMENSION ORO(IM,JM),ORO1(IM,JM),ELVMAX(IM,JM),ZMAX(IM,JM) - DIMENSION OA4(IM,JM,4),IOA4(IM,JM,4) - DIMENSION IST(IM,jm),IEN(IM,jm),JST(JM),JEN(JM) - DIMENSION XNSUM(IM,JM),XNSUM1(IM,JM),XNSUM2(IM,JM) - DIMENSION XNSUM3(IM,JM),XNSUM4(IM,JM) - DIMENSION VAR(IM,JM),OL(IM,JM,4),numi(jm) - LOGICAL FLAG -C -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C -! --- IM1 = IM - 1 removed (not used in this sub) - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO - print *,' IM=',IM,' JM=',JM,' IMN=',IMN,' JMN=',JMN -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C - DO j=1,jm - DO I=1,numi(j) - DELX = 360./numi(j) ! GAUSSIAN GRID RESOLUTION - FACLON = DELX / DELXN -C --- minus sign here in IST and IEN as in MAKEMT! - IST(I,j) = FACLON * FLOAT(I-1) - FACLON * 0.5 - IST(I,j) = IST(I,j) + 1 - IEN(I,j) = FACLON * FLOAT(I) - FACLON * 0.5 -! IST(I,j) = FACLON * FLOAT(I-1) + 1.0001 -! IEN(I,j) = FACLON * FLOAT(I) + 0.0001 - IF (IST(I,j) .LE. 0) IST(I,j) = IST(I,j) + IMN - IF (IEN(I,j) .LT. IST(I,j)) IEN(I,j) = IEN(I,j) + IMN -cx PRINT*, ' I j IST IEN ',I,j,IST(I,j),IEN(I,j) - if ( I .lt. 3 .and. J .lt. 3 ) - 1PRINT*,' MAKEOA: I j IST IEN ',I,j,IST(I,j),IEN(I,j) - if ( I .lt. 3 .and. J .ge. JM-1 ) - 1PRINT*,' MAKEOA: I j IST IEN ',I,j,IST(I,j),IEN(I,j) - ENDDO - ENDDO - print *,'MAKEOA: DELXN,DELX,FACLON',DELXN,DELX,FACLON - print *, ' ***** ready to start JST JEN section ' - DO J=1,JM-1 - FLAG=.TRUE. - DO J1=1,JMN -! --- XXLAT added as in MAKEMT and in next line as well - XXLAT = (XLAT(J)+XLAT(J+1))/2. - IF(FLAG.AND.GLAT(J1).GT.XXLAT) THEN - JST(J) = J1 -! --- JEN(J+1) = J1 - 1 - FLAG = .FALSE. - if ( J .eq. 1 ) - 1PRINT*,' MAKEOA: XX j JST JEN ',j,JST(j),JEN(j) - ENDIF - ENDDO - if ( J .lt. 3 ) - 1PRINT*,' MAKEOA: j JST JEN ',j,JST(j),JEN(j) - if ( J .ge. JM-2 ) - 1PRINT*,' MAKEOA: j JST JEN ',j,JST(j),JEN(j) -C FLAG=.TRUE. -C DO J1=JST(J),JMN -C IF(FLAG.AND.GLAT(J1).GT.XLAT(J)) THEN -C JEN(J) = J1 - 1 -C FLAG = .FALSE. -C ENDIF -C ENDDO - ENDDO - JST(JM) = MAX(JST(JM-1) - (JEN(JM-1)-JST(JM-1)),1) - JEN(1) = MIN(JEN(2) + (JEN(2)-JST(2)),JMN) - print *,' ***** JST(1) JEN(1) ',JST(1),JEN(1) - print *,' ***** JST(JM) JEN(JM) ',JST(JM),JEN(JM) -C - DO J=1,JM - DO I=1,numi(j) - XNSUM(I,J) = 0.0 - ELVMAX(I,J) = ORO(I,J) - ZMAX(I,J) = 0.0 - ENDDO - ENDDO -! -! --- # of peaks > ZAVG value and ZMAX(IM,JM) -- ORO is already avg. -! --- to JM or to JM1 - DO J=1,JM - DO I=1,numi(j) - DO II1 = 1, IEN(I,J) - IST(I,J) + 1 - I1 = IST(I,J) + II1 - 1 -! --- next line as in makemt (I1 not II1) (*j*) 20070701 - IF(I1.LE.0.) I1 = I1 + IMN - IF (I1 .GT. IMN) I1 = I1 - IMN - DO J1=JST(J),JEN(J) - HEIGHT = FLOAT(ZAVG(I1,J1)) - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - IF ( HEIGHT .gt. ORO(I,J) ) then - if ( HEIGHT .gt. ZMAX(I,J) )ZMAX(I,J) = HEIGHT - XNSUM(I,J) = XNSUM(I,J) + 1 - ENDIF - ENDDO - ENDDO - if ( I .lt. 5 .and. J .ge. JM-5 ) then - print *,' I,J,ORO(I,J),XNSUM(I,J),ZMAX(I,J):', - 1 I,J,ORO(I,J),XNSUM(I,J),ZMAX(I,J) - endif - ENDDO - ENDDO -! -C.... make ELVMAX ORO from MAKEMT sub -C -! --- this will make work1 array take on oro's values on return - DO J=1,JM - DO I=1,numi(j) - - ORO1(I,J) = ORO(I,J) - ELVMAX(I,J) = ZMAX(I,J) - ENDDO - ENDDO -C........ -C The MAX elev peak (no averaging) -C........ -! DO J=1,JM -! DO I=1,numi(j) -! DO II1 = 1, IEN(I,J) - IST(I,J) + 1 -! I1 = IST(I,J) + II1 - 1 -! IF(I1.LE.0.) I1 = I1 + IMN -! IF(I1.GT.IMN) I1 = I1 - IMN -! DO J1=JST(J),JEN(J) -! if ( ELVMAX(I,J) .lt. ZMAX(I1,J1)) -! 1 ELVMAX(I,J) = ZMAX(I1,J1) -! ENDDO -! ENDDO -! ENDDO -! ENDDO -C -C---- COUNT NUMBER OF MODE. HIGHER THAN THE HC, CRITICAL HEIGHT -C IN A GRID BOX - DO J=1,JM - DO I=1,numi(j) - XNSUM1(I,J) = 0.0 - XNSUM2(I,J) = 0.0 - XNSUM3(I,J) = 0.0 - XNSUM4(I,J) = 0.0 - ENDDO - ENDDO -! --- loop - DO J=1,JM1 - DO I=1,numi(j) - HC = 1116.2 - 0.878 * VAR(I,J) -! print *,' I,J,HC,VAR:',I,J,HC,VAR(I,J) - DO II1 = 1, IEN(I,J) - IST(I,J) + 1 - I1 = IST(I,J) + II1 - 1 -! IF (I1.LE.0.) print *,' I1 less than 0',I1,II1,IST(I,J),IEN(I,J) -! if ( J .lt. 3 .or. J .gt. JM-2 ) then -! IF(I1 .GT. IMN)print *,' I1 > IMN',J,I1,II1,IMN,IST(I,J),IEN(I,J) -! endif - IF(I1.GT.IMN) I1 = I1 - IMN - DO J1=JST(J),JEN(J) - IF(FLOAT(ZAVG(I1,J1)) .GT. HC) - 1 XNSUM1(I,J) = XNSUM1(I,J) + 1 - XNSUM2(I,J) = XNSUM2(I,J) + 1 - ENDDO - ENDDO -C - INCI = NINT((IEN(I,j)-IST(I,j)) * 0.5) - ISTTT = MIN(MAX(IST(I,j)-INCI,1),IMN) - IEDDD = MIN(MAX(IEN(I,j)-INCI,1),IMN) -C - INCJ = NINT((JEN(J)-JST(J)) * 0.5) - JSTTT = MIN(MAX(JST(J)-INCJ,1),JMN) - JEDDD = MIN(MAX(JEN(J)-INCJ,1),JMN) -! if ( J .lt. 3 .or. J .gt. JM-3 ) then -! if(I .lt. 3 .or. I .gt. IM-3) then -! print *,' INCI,ISTTT,IEDDD,INCJ,JSTTT,JEDDD:', -! 1 I,J,INCI,ISTTT,IEDDD,INCJ,JSTTT,JEDDD -! endif -! endif -C - DO I1=ISTTT,IEDDD - DO J1=JSTTT,JEDDD - IF(FLOAT(ZAVG(I1,J1)) .GT. HC) - 1 XNSUM3(I,J) = XNSUM3(I,J) + 1 - XNSUM4(I,J) = XNSUM4(I,J) + 1 - ENDDO - ENDDO -cx print*,' i j hc var ',i,j,hc,var(i,j) -cx print*,'xnsum12 ',xnsum1(i,j),xnsum2(i,j) -cx print*,'xnsum34 ',xnsum3(i,j),xnsum4(i,j) - ENDDO - ENDDO -C -C---- CALCULATE THE 3D OROGRAPHIC ASYMMETRY FOR 4 WIND DIRECTIONS -C---- AND THE 3D OROGRAPHIC SUBGRID OROGRAPHY FRACTION -C (KWD = 1 2 3 4) -C ( WD = W S SW NW) -C -C - DO KWD = 1, 4 - DO J=1,JM - DO I=1,numi(j) - OA4(I,J,KWD) = 0.0 - ENDDO - ENDDO - ENDDO -C - DO J=1,JM-2 - DO I=1,numi(j) - II = I + 1 - IF (II .GT. numi(j)) II = II - numi(j) - XNPU = XNSUM(I,J) + XNSUM(I,J+1) - XNPD = XNSUM(II,J) + XNSUM(II,J+1) - IF (XNPD .NE. XNPU) OA4(II,J+1,1) = 1. - XNPD / MAX(XNPU , 1.) - OL(II,J+1,1) = (XNSUM3(I,J+1)+XNSUM3(II,J+1))/ - 1 (XNSUM4(I,J+1)+XNSUM4(II,J+1)) -! if ( I .lt. 20 .and. J .ge. JM-19 ) then -! PRINT*,' MAKEOA: I J IST IEN ',I,j,IST(I,J),IEN(I,J) -! PRINT*,' HC VAR ',HC,VAR(i,j) -! PRINT*,' MAKEOA: XNSUM(I,J)=',XNSUM(I,J),XNPU, XNPD -! PRINT*,' MAKEOA: XNSUM3(I,J+1),XNSUM3(II,J+1)', -! 1 XNSUM3(I,J+1),XNSUM3(II,J+1) -! PRINT*,' MAKEOA: II, OA4(II,J+1,1), OL(II,J+1,1):', -! 1 II, OA4(II,J+1,1), OL(II,J+1,1) -! endif - ENDDO - ENDDO - DO J=1,JM-2 - DO I=1,numi(j) - II = I + 1 - IF (II .GT. numi(j)) II = II - numi(j) - XNPU = XNSUM(I,J+1) + XNSUM(II,J+1) - XNPD = XNSUM(I,J) + XNSUM(II,J) - IF (XNPD .NE. XNPU) OA4(II,J+1,2) = 1. - XNPD / MAX(XNPU , 1.) - OL(II,J+1,2) = (XNSUM3(II,J)+XNSUM3(II,J+1))/ - 1 (XNSUM4(II,J)+XNSUM4(II,J+1)) - ENDDO - ENDDO - DO J=1,JM-2 - DO I=1,numi(j) - II = I + 1 - IF (II .GT. numi(j)) II = II - numi(j) - XNPU = XNSUM(I,J+1) + ( XNSUM(I,J) + XNSUM(II,J+1) )*0.5 - XNPD = XNSUM(II,J) + ( XNSUM(I,J) + XNSUM(II,J+1) )*0.5 - IF (XNPD .NE. XNPU) OA4(II,J+1,3) = 1. - XNPD / MAX(XNPU , 1.) - OL(II,J+1,3) = (XNSUM1(II,J)+XNSUM1(I,J+1))/ - 1 (XNSUM2(II,J)+XNSUM2(I,J+1)) - ENDDO - ENDDO - DO J=1,JM-2 - DO I=1,numi(j) - II = I + 1 - IF (II .GT. numi(j)) II = II - numi(j) - XNPU = XNSUM(I,J) + ( XNSUM(II,J) + XNSUM(I,J+1) )*0.5 - XNPD = XNSUM(II,J+1) + ( XNSUM(II,J) + XNSUM(I,J+1) )*0.5 - IF (XNPD .NE. XNPU) OA4(II,J+1,4) = 1. - XNPD / MAX(XNPU , 1.) - OL(II,J+1,4) = (XNSUM1(I,J)+XNSUM1(II,J+1))/ - 1 (XNSUM2(I,J)+XNSUM2(II,J+1)) - ENDDO - ENDDO -C - DO KWD = 1, 4 - DO I=1,numi(j) - OL(I,1,KWD) = OL(I,2,KWD) - OL(I,JM,KWD) = OL(I,JM-1,KWD) - ENDDO - ENDDO -C - DO KWD=1,4 - DO J=1,JM - DO I=1,numi(j) - T = OA4(I,J,KWD) - OA4(I,J,KWD) = SIGN( MIN( ABS(T), 1. ), T ) - ENDDO - ENDDO - ENDDO -C - NS0 = 0 - NS1 = 0 - NS2 = 0 - NS3 = 0 - NS4 = 0 - NS5 = 0 - NS6 = 0 - DO KWD=1,4 - DO J=1,JM - DO I=1,numi(j) - T = ABS( OA4(I,J,KWD) ) - IF(T .EQ. 0.) THEN - IOA4(I,J,KWD) = 0 - NS0 = NS0 + 1 - ELSE IF(T .GT. 0. .AND. T .LE. 1.) THEN - IOA4(I,J,KWD) = 1 - NS1 = NS1 + 1 - ELSE IF(T .GT. 1. .AND. T .LE. 10.) THEN - IOA4(I,J,KWD) = 2 - NS2 = NS2 + 1 - ELSE IF(T .GT. 10. .AND. T .LE. 100.) THEN - IOA4(I,J,KWD) = 3 - NS3 = NS3 + 1 - ELSE IF(T .GT. 100. .AND. T .LE. 1000.) THEN - IOA4(I,J,KWD) = 4 - NS4 = NS4 + 1 - ELSE IF(T .GT. 1000. .AND. T .LE. 10000.) THEN - IOA4(I,J,KWD) = 5 - NS5 = NS5 + 1 - ELSE IF(T .GT. 10000.) THEN - IOA4(I,J,KWD) = 6 - NS6 = NS6 + 1 - ENDIF - ENDDO - ENDDO - ENDDO -C - WRITE(6,*) "! MAKEOA EXIT" -C - RETURN - END SUBROUTINE MAKEOA - !> Convert the 'x' direction distance of a cubed-sphere grid !! point to the corresponding distance in longitude. !! From 54a0a3e884afd781fddcd830cc8eca1b45d175c4 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 28 Jun 2024 19:51:37 +0000 Subject: [PATCH 09/54] Remove dependency on IPLIB. Fixes #970. --- sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt index 6fbed0573..cd0e5eed3 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt +++ b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt @@ -2,16 +2,13 @@ set(lib_src netcdf_io.F90) set(exe_src mtnlm7_oclsm.F) if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -r8 -convert big_endian -assume byterecl") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -warn unused -r8 -convert big_endian -assume byterecl") elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8 -fconvert=big-endian -fno-range-check") if(CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 10) set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fallow-invalid-boz") endif() endif() -if(ip_VERSION GREATER_EQUAL 4.0.0) - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -DIP_V4") -endif() set(exe_name orog) @@ -27,7 +24,6 @@ target_link_libraries( PUBLIC bacio::bacio_4 w3emc::w3emc_d - ip::ip_d NetCDF::NetCDF_Fortran) if(sp_FOUND) From 320b8f861144678cf6d0575dbbe85bf8e041c705 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Mon, 8 Jul 2024 20:05:39 +0000 Subject: [PATCH 10/54] Remove obsolete routine MAKEPC. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 290 +----------------- 1 file changed, 1 insertion(+), 289 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 90e154e74..1697c6809 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -668,16 +668,11 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, C === Compute mtn principal coord HTENSR: THETA,GAMMA,SIGMA C allocate (THETA(IM,JM),GAMMA(IM,JM),SIGMA(IM,JM),ELVMAX(IM,JM)) - if(grid_from_file) then tbeg=timef() - CALL MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA,GLAT, + CALL MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA,GLAT, 1 IM,JM,IMN,JMN,geolon_c,geolat_c,SLM) tend=timef() write(6,*)' MAKEPC2 time= ',tend-tbeg - else - CALL MAKEPC(ZAVG,ZSLM,THETA,GAMMA,SIGMA,GLAT, - 1 IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - endif call minmxj(IM,JM,THETA,' THETA') call minmxj(IM,JM,GAMMA,' GAMMA') @@ -1658,289 +1653,6 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, RETURN END -!> Make the principle coordinates - slope of orography, -!! anisotropy, angle of mountain range with respect to east. -!! This routine is used for spectral GFS gaussian grids. -!! -!! @param[in] zavg The high-resolution input orography dataset. -!! @param[in] zslm The high-resolution input land-mask dataset. -!! @param[out] theta Angle of mountain range with respect to -!! east for each model point. -!! @param[out] gamma Anisotropy for each model point. -!! @param[out] sigma Slope of orography for each model point. -!! @param[out] glat Latitude of each row of the high-resolution -!! orography and land-mask datasets. -!! @param[out] ist This is the 'i' index of high-resolution data set -!! at the east edge of the model grid cell. -!! @param[out] ien This is the 'i' index of high-resolution data set -!! at the west edge of the model grid cell. -!! @param[out] jst This is the 'j' index of high-resolution data set -!! at the south edge of the model grid cell. -!! @param[out] jen This is the 'j' index of high-resolution data set -!! at the north edge of the model grid cell. -!! @param[in] im "i" dimension of the model grid tile. -!! @param[in] jm "j" dimension of the model grid tile. -!! @param[in] imn "i" dimension of the hi-res input orog/mask datasets. -!! @param[in] jmn "j" dimension of the hi-res input orog/mask datasets. -!! @param[in] xlat The latitude of each row of the model grid. -!! @param[in] numi For reduced gaussian grids, the number of 'i' points -!! for each 'j' row. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE MAKEPC(ZAVG,ZSLM,THETA,GAMMA,SIGMA, - 1 GLAT,IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) -C -C=== PC: principal coordinates of each Z avg orog box for L&M -C - parameter(REARTH=6.3712E+6) - DIMENSION GLAT(JMN),XLAT(JM),DELTAX(JMN) - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - DIMENSION ORO(IM,JM),SLM(IM,JM),HL(IM,JM),HK(IM,JM) - DIMENSION HX2(IM,JM),HY2(IM,JM),HXY(IM,JM),HLPRIM(IM,JM) - DIMENSION THETA(IM,JM),GAMMA(IM,JM),SIGMA2(IM,JM),SIGMA(IM,JM) - DIMENSION IST(IM,jm),IEN(IM,jm),JST(JM),JEN(JM),numi(jm) - LOGICAL FLAG, DEBUG -C=== DATA DEBUG/.TRUE./ - DATA DEBUG/.FALSE./ -C - PI = 4.0 * ATAN(1.0) - CERTH = PI * REARTH -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION - DELTAY = CERTH / FLOAT(JMN) - print *, 'MAKEPC: DELTAY=',DELTAY -C - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - DELTAX(J) = DELTAY * COS(GLAT(J)*PI/180.0) - ENDDO -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C - DO J=1,JM - DO I=1,numi(j) -C IM1 = numi(j) - 1 - DELX = 360./numi(j) ! GAUSSIAN GRID RESOLUTION - FACLON = DELX / DELXN - IST(I,j) = FACLON * FLOAT(I-1) - FACLON * 0.5 - IST(I,j) = IST(I,j) + 1 - IEN(I,j) = FACLON * FLOAT(I) - FACLON * 0.5 -C if (debug) then -C if ( I .lt. 10 .and. J .lt. 10 ) -C 1 PRINT*, ' I j IST IEN ',I,j,IST(I,j),IEN(I,j) -C endif -! IST(I,j) = FACLON * FLOAT(I-1) + 1.0001 -! IEN(I,j) = FACLON * FLOAT(I) + 0.0001 - IF (IST(I,j) .LE. 0) IST(I,j) = IST(I,j) + IMN - IF (IEN(I,j) .LT. IST(I,j)) IEN(I,j) = IEN(I,j) + IMN - if (debug) then - if ( I .lt. 10 .and. J .lt. 10 ) - 1 PRINT*, ' I j IST IEN ',I,j,IST(I,j),IEN(I,j) - endif - IF (IEN(I,j) .LT. IST(I,j)) - 1 print *,' MAKEPC: IEN < IST: I,J,IST(I,J),IEN(I,J)', - 2 I,J,IST(I,J),IEN(I,J) - ENDDO - ENDDO - DO J=1,JM-1 - FLAG=.TRUE. - DO J1=1,JMN - XXLAT = (XLAT(J)+XLAT(J+1))/2. - IF(FLAG.AND.GLAT(J1).GT.XXLAT) THEN - JST(J) = J1 - JEN(J+1) = J1 - 1 - FLAG = .FALSE. - ENDIF - ENDDO - ENDDO - JST(JM) = MAX(JST(JM-1) - (JEN(JM-1)-JST(JM-1)),1) - JEN(1) = MIN(JEN(2) + (JEN(2)-JST(2)),JMN) - if (debug) then - PRINT*, ' IST,IEN(1,1-numi(1,JM))',IST(1,1),IEN(1,1), - 1 IST(numi(JM),JM),IEN(numi(JM),JM), numi(JM) - PRINT*, ' JST,JEN(1,JM) ',JST(1),JEN(1),JST(JM),JEN(JM) - endif -C -C... DERIVITIVE TENSOR OF HEIGHT -C - DO J=1,JM - DO I=1,numi(j) - ORO(I,J) = 0.0 - HX2(I,J) = 0.0 - HY2(I,J) = 0.0 - HXY(I,J) = 0.0 - XNSUM = 0.0 - XLAND = 0.0 - XWATR = 0.0 - XL1 = 0.0 - XS1 = 0.0 - xfp = 0.0 - yfp = 0.0 - xfpyfp = 0.0 - xfp2 = 0.0 - yfp2 = 0.0 - HL(I,J) = 0.0 - HK(I,J) = 0.0 - HLPRIM(I,J) = 0.0 - THETA(I,J) = 0.0 - GAMMA(I,J) = 0. - SIGMA2(I,J) = 0. - SIGMA(I,J) = 0. -C - DO II1 = 1, IEN(I,J) - IST(I,J) + 1 - I1 = IST(I,J) + II1 - 1 - IF(I1.LE.0.) I1 = I1 + IMN - IF(I1.GT.IMN) I1 = I1 - IMN -C -C=== set the rest of the indexs for ave: 2pt staggered derivitive -C - i0 = i1 - 1 - if (i1 - 1 .le. 0 ) i0 = i0 + imn - if (i1 - 1 .gt. imn) i0 = i0 - imn -C - ip1 = i1 + 1 - if (i1 + 1 .le. 0 ) ip1 = ip1 + imn - if (i1 + 1 .gt. imn) ip1 = ip1 - imn -C - DO J1=JST(J),JEN(J) - if (debug) then - if ( I1 .eq. IST(I,J) .and. J1 .eq. JST(J) ) - 1 PRINT*, ' J, J1,IST,JST,DELTAX,GLAT ', - 2 J,J1,IST(I,J),JST(J),DELTAX(J1),GLAT(J1) - if ( I1 .eq. IEN(I,J) .and. J1 .eq. JEN(J) ) - 1 PRINT*, ' J, J1,IEN,JEN,DELTAX,GLAT ', - 2 J,J1,IEN(I,J),JEN(J),DELTAX(J1),GLAT(J1) - endif - XLAND = XLAND + FLOAT(ZSLM(I1,J1)) - XWATR = XWATR + FLOAT(1-ZSLM(I1,J1)) - XNSUM = XNSUM + 1. -C - HEIGHT = FLOAT(ZAVG(I1,J1)) - hi0 = float(zavg(i0,j1)) - hip1 = float(zavg(ip1,j1)) -C - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - if(hi0 .lt. -990.) hi0 = 0.0 - if(hip1 .lt. -990.) hip1 = 0.0 -C........ xfp = xfp + 0.5 * ( hip1 - hi0 ) / DELTAX(J1) - xfp = 0.5 * ( hip1 - hi0 ) / DELTAX(J1) - xfp2 = xfp2 + 0.25 * ( ( hip1 - hi0 )/DELTAX(J1) )** 2 -C -! --- not at boundaries -!RAB if ( J1 .ne. JST(1) .and. J1 .ne. JEN(JM) ) then - if ( J1 .ne. JST(JM) .and. J1 .ne. JEN(1) ) then - hj0 = float(zavg(i1,j1-1)) - hjp1 = float(zavg(i1,j1+1)) - if(hj0 .lt. -990.) hj0 = 0.0 - if(hjp1 .lt. -990.) hjp1 = 0.0 -C....... yfp = yfp + 0.5 * ( hjp1 - hj0 ) / DELTAY - yfp = 0.5 * ( hjp1 - hj0 ) / DELTAY - yfp2 = yfp2 + 0.25 * ( ( hjp1 - hj0 )/DELTAY )**2 -C -C..............elseif ( J1 .eq. JST(J) .or. J1 .eq. JEN(JM) ) then -C === the NH pole: NB J1 goes from High at NP to Low toward SP -C -!RAB elseif ( J1 .eq. JST(1) ) then - elseif ( J1 .eq. JST(JM) ) then - ijax = i1 + imn/2 - if (ijax .le. 0 ) ijax = ijax + imn - if (ijax .gt. imn) ijax = ijax - imn -C..... at N pole we stay at the same latitude j1 but cross to opp side - hijax = float(zavg(ijax,j1)) - hi1j1 = float(zavg(i1,j1)) - if(hijax .lt. -990.) hijax = 0.0 - if(hi1j1 .lt. -990.) hi1j1 = 0.0 -C....... yfp = yfp + 0.5 * ( ( 0.5 * ( hijax + hi1j1) ) - hi1j1 )/DELTAY - yfp = 0.5 * ( ( 0.5 * ( hijax - hi1j1 ) ) )/DELTAY - yfp2 = yfp2 + 0.25 * ( ( 0.5 * ( hijax - hi1j1) ) - 1 / DELTAY )**2 -C -C === the SH pole: NB J1 goes from High at NP to Low toward SP -C -!RAB elseif ( J1 .eq. JEN(JM) ) then - elseif ( J1 .eq. JEN(1) ) then - ijax = i1 + imn/2 - if (ijax .le. 0 ) ijax = ijax + imn - if (ijax .gt. imn) ijax = ijax - imn - hijax = float(zavg(ijax,j1)) - hi1j1 = float(zavg(i1,j1)) - if(hijax .lt. -990.) hijax = 0.0 - if(hi1j1 .lt. -990.) hi1j1 = 0.0 - if ( i1 .lt. 5 )print *,' S.Pole i1,j1 :',i1,j1,hijax,hi1j1 -C..... yfp = yfp + 0.5 * (0.5 * ( hijax - hi1j1) )/DELTAY - yfp = 0.5 * (0.5 * ( hijax - hi1j1) )/DELTAY - yfp2 = yfp2 + 0.25 * ( (0.5 * (hijax - hi1j1) ) - 1 / DELTAY )**2 - endif -C -C === The above does an average across the pole for the bndry in j. -C23456789012345678901234567890123456789012345678901234567890123456789012...... -C - xfpyfp = xfpyfp + xfp * yfp - XL1 = XL1 + HEIGHT * FLOAT(ZSLM(I1,J1)) - XS1 = XS1 + HEIGHT * FLOAT(1-ZSLM(I1,J1)) -C -C === average the HX2, HY2 and HXY -C === This will be done over all land -C - ENDDO - ENDDO -C -C === HTENSR -C - IF(XNSUM.GT.1.) THEN - SLM(I,J) = FLOAT(NINT(XLAND/XNSUM)) - IF(SLM(I,J).NE.0.) THEN - ORO(I,J)= XL1 / XLAND - HX2(I,J) = xfp2 / XLAND - HY2(I,J) = yfp2 / XLAND - HXY(I,J) = xfpyfp / XLAND - ELSE - ORO(I,J)= XS1 / XWATR - ENDIF -C=== degub testing - if (debug) then - print *," I,J,i1,j1,HEIGHT:", I,J,i1,j1,HEIGHT, - 1 XLAND,SLM(i,j) - print *," xfpyfp,xfp2,yfp2:",xfpyfp,xfp2,yfp2 - print *," HX2,HY2,HXY:",HX2(I,J),HY2(I,J),HXY(I,J) - ENDIF -C -C === make the principal axes, theta, and the degree of anisotropy, -C === and sigma2, the slope parameter -C - HK(I,J) = 0.5 * ( HX2(I,J) + HY2(I,J) ) - HL(I,J) = 0.5 * ( HX2(I,J) - HY2(I,J) ) - HLPRIM(I,J) = SQRT(HL(I,J)*HL(I,J) + HXY(I,J)*HXY(I,J)) - IF( HL(I,J).NE. 0. .AND. SLM(I,J) .NE. 0. ) THEN -C - THETA(I,J) = 0.5 * ATAN2(HXY(I,J),HL(I,J)) * 180.0 / PI -C === for testing print out in degrees -C THETA(I,J) = 0.5 * ATAN2(HXY(I,J),HL(I,J)) - ENDIF - SIGMA2(I,J) = ( HK(I,J) + HLPRIM(I,J) ) - if ( SIGMA2(I,J) .GE. 0. ) then - SIGMA(I,J) = SQRT(SIGMA2(I,J) ) - if (sigma2(i,j) .ne. 0. .and. - & HK(I,J) .GE. HLPRIM(I,J) ) - 1 GAMMA(I,J) = sqrt( (HK(I,J) - HLPRIM(I,J)) / SIGMA2(I,J) ) - else - SIGMA(I,J)=0. - endif - ENDIF - if (debug) then - print *," I,J,THETA,SIGMA,GAMMA,",I,J,THETA(I,J), - 1 SIGMA(I,J),GAMMA(I,J) - print *," HK,HL,HLPRIM:",HK(I,J),HL(I,J),HLPRIM(I,J) - endif - ENDDO - ENDDO - WRITE(6,*) "! MAKE Principal Coord DONE" -C - RETURN - END - !> Make the principle coordinates - slope of orography, !! anisotropy, angle of mountain range with respect to east. !! This routine is used for the FV3GFS cubed-sphere grid. From b29d87c5811276e8e50e9094b69494ef554c01b5 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 9 Jul 2024 18:07:25 +0000 Subject: [PATCH 11/54] Remove unused routine minmaxj. Fixes #970 --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 52 ------------------- 1 file changed, 52 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 1697c6809..9eb9af6a6 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -2544,58 +2544,6 @@ subroutine maxmin(ia,len,tile) return end -!> Print out the maximum and minimum values of -!! an array and their i/j location. Also print out -!! the number of undefined points. -!! -!! @param[in] im The 'i' dimension of the array. -!! @param[in] jm The 'i' dimension of the array. -!! @param[in] a The array to check. -!! @param[in] title Name of the data to be checked. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE minmaxj(IM,JM,A,title) - implicit none - - real(kind=4) A(IM,JM),rmin,rmax,undef - integer i,j,IM,JM,imax,jmax,imin,jmin,iundef - character*8 title,chara - data chara/' '/ - chara=title - rmin=1.e+10 - rmax=-rmin - imax=0 - imin=0 - jmax=0 - jmin=0 - iundef=0 - undef=-9999. -csela.................................................... -csela if(rmin.eq.1.e+10)return -csela.................................................... - DO j=1,JM - DO i=1,IM - if(A(i,j).ge.rmax)then - rmax=A(i,j) - imax=i - jmax=j - endif - if(A(i,j).le.rmin)then - if ( A(i,j) .eq. undef ) then - iundef = iundef + 1 - else - rmin=A(i,j) - imin=i - jmin=j - endif - endif - ENDDO - ENDDO - write(6,150)chara,rmin,imin,jmin,rmax,imax,jmax,iundef -150 format(1x,a8,2x,'rmin=',e13.4,2i6,2x,'rmax=',e13.4,3i6) -C - RETURN - END - !> Convert from latitude and longitude to x,y,z coordinates. !! !! @param[in] siz Number of points to convert. From 5e5503cd99bbc397c4e683b601ed3b5521b6efdb Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 9 Jul 2024 18:18:30 +0000 Subject: [PATCH 12/54] Remove unused function 'spherical_distance'. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 27 ------------------- 1 file changed, 27 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 9eb9af6a6..34f8bb929 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -2360,33 +2360,6 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,GLAT,OA4,OL,IOA4,ELVMAX, END SUBROUTINE MAKEOA2 -!> Compute a great circle distance between two points. -!! -!! @param[in] theta1 Longitude of point 1. -!! @param[in] phi1 Latitude of point 1. -!! @param[in] theta2 Longitude of point 2. -!! @param[in] phi2 Latitude of point2. -!! @return spherical_distance Great circle distance. -!! @author GFDL programmer - function spherical_distance(theta1,phi1,theta2,phi2) - - real, intent(in) :: theta1, phi1, theta2, phi2 - real :: spherical_distance, dot - - if(theta1 == theta2 .and. phi1 == phi2) then - spherical_distance = 0.0 - return - endif - - dot = cos(phi1)*cos(phi2)*cos(theta1-theta2) + sin(phi1)*sin(phi2) - if(dot > 1. ) dot = 1. - if(dot < -1.) dot = -1. - spherical_distance = acos(dot) - - return - - end function spherical_distance - !> Print out the maximum and minimum values of !! an array. !! From 168c0b331837484c1d02abe012283e26c989559e Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 9 Jul 2024 18:51:43 +0000 Subject: [PATCH 13/54] Add formal 'end' statements for all subroutines and functions. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 20 +++++++++---------- sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 | 7 +++---- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 34f8bb929..986995ccd 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -1201,7 +1201,7 @@ SUBROUTINE MAKEMT(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, C RETURN - END + END SUBROUTINE MAKEMT !> Determine the location of a cubed-sphere point within !! the high-resolution orography data. The location is @@ -1294,7 +1294,7 @@ SUBROUTINE get_index(IMN,JMN,npts,lonO,latO,DELXN, enddo endif - END + END SUBROUTINE get_index !> Create the land-mask, land fraction. !! This routine is used for the FV3GFS model. @@ -1651,7 +1651,7 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, deallocate(hgt_1d) deallocate(hgt_1d_all) RETURN - END + END SUBROUTINE MAKEMT2 !> Make the principle coordinates - slope of orography, !! anisotropy, angle of mountain range with respect to east. @@ -2390,7 +2390,7 @@ SUBROUTINE minmxj(IM,JM,A,title) 150 format('rmin=',e13.4,2x,'rmax=',e13.4,2x,a8,' ') C RETURN - END + END SUBROUTINE minmxj !> Print out the maximum and minimum values of !! an array. Pass back the i/j location of the @@ -2429,7 +2429,7 @@ SUBROUTINE mnmxja(IM,JM,A,imax,jmax,title) 150 format('rmin=',e13.4,2x,'rmax=',e13.4,2x,a8,' ') C RETURN - END + END SUBROUTINE mnmxja !> Read input global 30-arc second orography data. !! @@ -2515,7 +2515,7 @@ subroutine maxmin(ia,len,tile) print*,tile,' mean=',mean,' std.dev=',std, & ' ko9s=',kount,kount_9,kount+kount_9 return - end + end subroutine maxmin !> Convert from latitude and longitude to x,y,z coordinates. !! @@ -2539,7 +2539,7 @@ subroutine latlon2xyz(siz,lon, lat, x, y, z) y(n) = cos(lat(n))*sin(lon(n)) z(n) = sin(lat(n)) enddo - end + end subroutine latlon2xyz !> Compute spherical angle. !! @@ -2586,7 +2586,7 @@ FUNCTION spherical_angle(v1, v2, v3) endif return - END + END FUNCTION spherical_angle !> Check if a point is inside a polygon. !! @@ -2668,7 +2668,7 @@ FUNCTION inside_a_polygon(lon1, lat1, npts, lon2, lat2) return - end + end function inside_a_polygon !> Count the number of high-resolution orography points that !! are higher than the model grid box average orography height. @@ -2954,4 +2954,4 @@ real function timef() elapsed=float(total) + (1.0e-3*float(values(8))) timef=elapsed return - end + end function timef diff --git a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 index f4834c2c5..b48aaea59 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 @@ -208,7 +208,7 @@ subroutine write_netcdf(im, jm, slm, land_frac, oro, hprime, ntiles, tile, geolo error = nf_close(ncid) call netcdf_err(error, 'close file='//trim(outfile) ) - end subroutine + end subroutine write_netcdf !> Check NetCDF error code and output the error message. !! @@ -319,8 +319,7 @@ subroutine write_mask_netcdf(im, jm, slm, land_frac, ntiles, tile, geolon, geola error = nf_close(ncid) call netcdf_err(error, 'close file='//trim(outfile) ) - end subroutine - + end subroutine write_mask_netcdf !> Read the land mask file !! @@ -377,4 +376,4 @@ subroutine read_mask(merge_file,slm,land_frac,lake_frac,im,jm) error = nf_close(ncid) print*,'bot of read_mask' - end subroutine + end subroutine read_mask From 549d2b66f85d9b296e8745ea8f1c25bb6910837a Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 10 Jul 2024 18:25:40 +0000 Subject: [PATCH 14/54] Remove obsolete routine makemt and related logic. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 190 +----------------- 1 file changed, 4 insertions(+), 186 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 986995ccd..c13c1be23 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -165,7 +165,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, integer(1) :: i3save integer(2) :: i2save - integer, allocatable :: JST(:),JEN(:),numi(:) + integer, allocatable :: JST(:),JEN(:) integer, allocatable :: IST(:,:),IEN(:,:),ZSLMX(:,:) integer, allocatable :: ZAVG(:,:),ZSLM(:,:) @@ -193,14 +193,14 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, real, allocatable :: OA(:,:,:),OL(:,:,:),HPRIME(:,:,:) - logical :: grid_from_file,fexist,opened + logical :: fexist,opened logical :: is_south_pole(IM,JM), is_north_pole(IM,JM) tbeg1=timef() tbeg=timef() fsize = 65536 ! integers - allocate (JST(JM),JEN(JM),numi(jm)) + allocate (JST(JM),JEN(JM)) allocate (IST(IM,jm),IEN(IM,jm),ZSLMX(2700,1350)) allocate (glob(IMN,JMN)) @@ -325,11 +325,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ! --- spacing of 1/120 degrees. ! ! When the gaussian grid routines makemt, makepc and makeoa are -! removed, numi can be removed. - do j=1,jm - numi(j)=im - enddo -! When the gaussian grid routines makemt, makepc and makeoa are ! removed, xlat can be removed. CALL SPLAT(0,JM,COSCLT,WGTCLT) DO J=1,JM @@ -470,7 +465,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, i_north_pole = 0 j_north_pole = 0 - grid_from_file = .true. inquire(file=trim(OUTGRID), exist=fexist) if(.not. fexist) then print*, "FATAL ERROR: file "//trim(OUTGRID) @@ -617,7 +611,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, tend=timef() write(6,*)' Timer 1 time= ',tend-tbeg ! - if(grid_from_file) then tbeg=timef() IF (MERGE_FILE == 'none') then @@ -643,10 +636,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, tend=timef() write(6,*)' MAKEMT2 time= ',tend-tbeg - else - CALL MAKEMT(ZAVG,ZSLM,ORO,SLM,VAR,VAR4,GLAT, - & IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - endif call minmxj(IM,JM,ORO,' ORO') call minmxj(IM,JM,SLM,' SLM') @@ -1017,7 +1006,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, print *,' ===== Deallocate Arrays and ENDING MTN VAR OROG program' ! Deallocate 1d vars - deallocate(JST,JEN,numi) + deallocate(JST,JEN) deallocate(COSCLT,WGTCLT,RCLT,XLAT,XLON,oaa,ola,GLAT) ! Deallocate 2d vars @@ -1032,177 +1021,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, RETURN END SUBROUTINE TERSUB -!> Create the orography, land-mask, standard deviation of -!! orography and the convexity on a model gaussian grid. -!! This routine was used for the spectral GFS model. -!! -!! @param[in] zavg The high-resolution input orography dataset. -!! @param[in] zslm The high-resolution input land-mask dataset. -!! @param[out] oro Orography on the model grid. -!! @param[out] slm Land-mask on the model grid. -!! @param[out] var Standard deviation of orography on the model grid. -!! @param[out] var4 Convexity on the model grid. -!! @param[out] glat Latitude of each row of the high-resolution -!! orography and land-mask datasets. -!! @param[out] ist This is the 'i' index of high-resolution data set -!! at the east edge of the model grid cell. -!! the high-resolution dataset with respect to the 'east' edge -!! @param[out] ien This is the 'i' index of high-resolution data set -!! at the west edge of the model grid cell. -!! @param[out] jst This is the 'j' index of high-resolution data set -!! at the south edge of the model grid cell. -!! @param[out] jen This is the 'j' index of high-resolution data set -!! at the north edge of the model grid cell. -!! @param[in] im "i" dimension of the model grid. -!! @param[in] jm "j" dimension of the model grid. -!! @param[in] imn "i" dimension of the hi-res input orog/mask dataset. -!! @param[in] jmn "j" dimension of the hi-res input orog/mask dataset. -!! @param[in] xlat The latitude of each row of the model grid. -!! @param[in] numi For reduced gaussian grids, the number of 'i' points -!! for each 'j' row. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE MAKEMT(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, - 1 GLAT,IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - DIMENSION GLAT(JMN),XLAT(JM) -! REAL*4 OCLSM - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - DIMENSION ORO(IM,JM),SLM(IM,JM),VAR(IM,JM),VAR4(IM,JM) - DIMENSION IST(IM,jm),IEN(IM,jm),JST(JM),JEN(JM),numi(jm) - LOGICAL FLAG -C -! ---- OCLSM holds the ocean (im,jm) grid - print *,' _____ SUBROUTINE MAKEMT ' -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C -C (*j*) for hard wired zero offset (lambda s =0) for terr05 - DO J=1,JM - DO I=1,numi(j) - IM1 = numi(j) - 1 - DELX = 360./numi(j) ! GAUSSIAN GRID RESOLUTION - FACLON = DELX / DELXN - IST(I,j) = FACLON * FLOAT(I-1) - FACLON * 0.5 + 1 - IEN(I,j) = FACLON * FLOAT(I) - FACLON * 0.5 + 1 -! IST(I,j) = FACLON * FLOAT(I-1) + 1.0001 -! IEN(I,j) = FACLON * FLOAT(I) + 0.0001 -C - IF (IST(I,j) .LE. 0) IST(I,j) = IST(I,j) + IMN - IF (IEN(I,j) .LT. IST(I,j)) IEN(I,j) = IEN(I,j) + IMN -! -! if ( I .lt. 10 .and. J .ge. JM-1 ) -! 1 PRINT*,' MAKEMT: I j IST IEN ',I,j,IST(I,j),IEN(I,j) - ENDDO -! if ( J .ge. JM-1 ) then -! print *,' *** FACLON=',FACLON, 'numi(j=',j,')=',numi(j) -! endif - ENDDO - print *,' DELX=',DELX,' DELXN=',DELXN - DO J=1,JM-1 - FLAG=.TRUE. - DO J1=1,JMN - XXLAT = (XLAT(J)+XLAT(J+1))/2. - IF(FLAG.AND.GLAT(J1).GT.XXLAT) THEN - JST(J) = J1 - JEN(J+1) = J1 - 1 - FLAG = .FALSE. - ENDIF - ENDDO -CX PRINT*, ' J JST JEN ',J,JST(J),JEN(J),XLAT(J),GLAT(J1) - ENDDO - JST(JM) = MAX(JST(JM-1) - (JEN(JM-1)-JST(JM-1)),1) - JEN(1) = MIN(JEN(2) + (JEN(2)-JST(2)),JMN) -! PRINT*, ' JM JST JEN=',JST(JM),JEN(JM),XLAT(JM),GLAT(JMN) -C -C...FIRST, AVERAGED HEIGHT -C - DO J=1,JM - DO I=1,numi(j) - ORO(I,J) = 0.0 - VAR(I,J) = 0.0 - VAR4(I,J) = 0.0 - XNSUM = 0.0 - XLAND = 0.0 - XWATR = 0.0 - XL1 = 0.0 - XS1 = 0.0 - XW1 = 0.0 - XW2 = 0.0 - XW4 = 0.0 - DO II1 = 1, IEN(I,J) - IST(I,J) + 1 - I1 = IST(I,J) + II1 - 1 - IF(I1.LE.0.) I1 = I1 + IMN - IF(I1.GT.IMN) I1 = I1 - IMN -! if ( i .le. 10 .and. i .ge. 1 ) then -! if (j .eq. JM ) -! &print *,' J,JST,JEN,IST,IEN,I1=', -! &J,JST(j),JEN(J),IST(I,j),IEN(I,j),I1 -! endif - DO J1=JST(J),JEN(J) - XLAND = XLAND + FLOAT(ZSLM(I1,J1)) - XWATR = XWATR + FLOAT(1-ZSLM(I1,J1)) - XNSUM = XNSUM + 1. - HEIGHT = FLOAT(ZAVG(I1,J1)) -C......... - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - XL1 = XL1 + HEIGHT * FLOAT(ZSLM(I1,J1)) - XS1 = XS1 + HEIGHT * FLOAT(1-ZSLM(I1,J1)) - XW1 = XW1 + HEIGHT - XW2 = XW2 + HEIGHT ** 2 -C check antarctic pole -! if ( i .le. 10 .and. i .ge. 1 )then -! if (j .ge. JM-1 )then -C=== degub testing -! print *," I,J,I1,J1,XL1,XS1,XW1,XW2:",I,J,I1,J1,XL1,XS1,XW1,XW2 -! 153 format(1x,' ORO,ELVMAX(i=',i4,' j=',i4,')=',2E14.5,3f5.1) -! endif -! endif - ENDDO - ENDDO - IF(XNSUM.GT.1.) THEN -! --- SLM initialized with OCLSM calc from all land points except .... -! --- 0 is ocean and 1 is land for slm -! --- Step 1 is to only change SLM after GFS SLM is applied - - SLM(I,J) = FLOAT(NINT(XLAND/XNSUM)) - IF(SLM(I,J).NE.0.) THEN - ORO(I,J)= XL1 / XLAND - ELSE - ORO(I,J)= XS1 / XWATR - ENDIF - VAR(I,J)=SQRT(MAX(XW2/XNSUM-(XW1/XNSUM)**2,0.)) - DO II1 = 1, IEN(I,j) - IST(I,J) + 1 - I1 = IST(I,J) + II1 - 1 - IF(I1.LE.0.) I1 = I1 + IMN - IF(I1.GT.IMN) I1 = I1 - IMN - DO J1=JST(J),JEN(J) - HEIGHT = FLOAT(ZAVG(I1,J1)) - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - XW4 = XW4 + (HEIGHT-ORO(I,J)) ** 4 - ENDDO - ENDDO - IF(VAR(I,J).GT.1.) THEN -! if ( I .lt. 20 .and. J .ge. JM-19 ) then -! print *,'I,J,XW4,XNSUM,VAR(I,J)',I,J,XW4,XNSUM,VAR(I,J) -! endif - VAR4(I,J) = MIN(XW4/XNSUM/VAR(I,J) **4,10.) - ENDIF - ENDIF - ENDDO - ENDDO - WRITE(6,*) "! MAKEMT ORO SLM VAR VAR4 DONE" -C - - RETURN - END SUBROUTINE MAKEMT - !> Determine the location of a cubed-sphere point within !! the high-resolution orography data. The location is !! described by the range of i/j indices on the high-res grid. From 15bbc856eff07601b601aba9d5876423ef70c6fb Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 10 Jul 2024 20:15:44 +0000 Subject: [PATCH 15/54] Remove read of gaussian ocean mask file, which is not used anymore. Remove associated logic. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 147 +----------------- 1 file changed, 8 insertions(+), 139 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index c13c1be23..8c3f56d66 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -41,7 +41,6 @@ C> - NCID - GMTED2010 USGS orography (NetCDF) C> - NCID - 30" UMD land cover mask. (NetCDF) C> - NCID - GICE Grumbine 30" RAMP Antarctica orog IMNx3601. (NetCDF) -C> - UNIT25 - Ocean land-sea mask on gaussian grid C> C> OUTPUT FILES: C> - UNIT51 - SEA-LAND MASK (IM,JM) @@ -56,7 +55,6 @@ C> - SPLAT - COMPUTE GAUSSIAN LATITUDES OR EQUALLY-SPACED LATITUDES C> - LIBRARY: C> - SPTEZ - SPHERICAL TRANSFORM -C> - GBYTES - UNPACK BITS C> C> @return 0 for success, error code otherwise. implicit none @@ -67,7 +65,7 @@ character(len=256) :: OUTGRID = "none" character(len=256) :: merge_file = "none" logical :: mask_only = .false. - integer :: MTNRES,IM,JM,EFAC + integer :: IM,JM,EFAC fsize=65536 READ(5,*) OUTGRID READ(5,*) mask_only @@ -75,16 +73,9 @@ EFAC=0 print*, "MASK_ONLY", mask_only print*, "MERGE_FILE ", trim(merge_file) -! --- MTNRES defines the input (highest) elev resolution -! --- =1 is topo30 30" in units of 1/2 minute. -! so MTNRES for old values must be *2. -! =16 is now Song Yu's 8' orog the old ops standard -! --- other possibilities are =8 for 4' and =4 for 2' see -! HJ for T1000 test. Must set to 1 for now. - MTNRES=1 - print*, MTNRES,EFAC - IMN = 360*120/MTNRES - JMN = 180*120/MTNRES + print*, EFAC + IMN = 360*120 + JMN = 180*120 print *, ' Starting terr12 mtnlm7_slm30.f IMN,JMN:',IMN,JMN ! --- read the grid resolution from OUTGRID. @@ -156,10 +147,9 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, integer, PARAMETER :: NMT=14 integer :: efac,zsave1,zsave2 - integer :: mskocn,notocn integer :: i,j,nx,ny,ncid,js,jn,iw,ie,k,it,jt,error,id_dim integer :: id_var,fsize,wgta,IN,INW,INE,IS,ISW,ISE - integer :: ios,istat,itest,jtest + integer :: itest,jtest integer :: i_south_pole,j_south_pole,i_north_pole,j_north_pole integer :: maxc3,maxc4,maxc5,maxc6,maxc7,maxc8 integer(1) :: i3save @@ -185,11 +175,11 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, real, allocatable :: SLM(:,:),ORO(:,:),VAR(:,:) real, allocatable :: land_frac(:,:),lake_frac(:,:) real, allocatable :: THETA(:,:),GAMMA(:,:),SIGMA(:,:),ELVMAX(:,:) - real, allocatable :: VAR4(:,:),SLMI(:,:) + real, allocatable :: VAR4(:,:) real, allocatable :: WORK1(:,:),WORK2(:,:),WORK3(:,:),WORK4(:,:) real, allocatable :: WORK5(:,:),WORK6(:,:) real, allocatable :: tmpvar(:,:) - real(4), allocatable:: GICE(:,:),OCLSM(:,:) + real(4), allocatable:: GICE(:,:) real, allocatable :: OA(:,:,:),OL(:,:,:),HPRIME(:,:,:) @@ -216,20 +206,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ! SET CONSTANTS AND ZERO FIELDS ! DEGRAD = 180./PI - MSKOCN = 1 ! Ocean land sea mask =1, =0 if not present - NOTOCN = 1 ! =1 Ocean lsm input reverse: Ocean=1, land=0 -! --- The LSM Gaussian file from the ocean model sometimes arrives with -! --- 0=Ocean and 1=Land or it arrives with 1=Ocean and 0=land without -! --- metadata to distinguish its disposition. The AI below mitigates this. print *,' In TERSUB' - if (mskocn .eq. 1)then - print *,' Ocean Model LSM Present and ' - print *, ' Overrides OCEAN POINTS in LSM: mskocn=',mskocn - if (notocn .eq. 1)then - print *,' Ocean LSM Reversed: NOTOCN=',notocn - endif - endif print *,' Attempt to open/read UMD 30sec slmsk.' @@ -276,7 +254,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, print *,' UBOUND glob=',UBOUND(glob) print *,' UBOUND ZSLM=',UBOUND(ZSLM) print *,' UBOUND GICE=',IMN+1,3601 - print *,' UBOUND OCLSM=',IM,JM ! ! --- 0 is ocean and 1 is land for slm ! @@ -386,72 +363,9 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, enddo deallocate (GICE) - - allocate (OCLSM(IM,JM),SLMI(IM,JM)) -!C +C C COMPUTE MOUNTAIN DATA : ORO SLM VAR (Std Dev) OC C -! --- The coupled ocean model is already on a Guasian grid if (IM,JM) -! --- Attempt to Open the file if mskocn=1 - istat=0 - if (mskocn .eq. 1) then -! open(25,form='unformatted',iostat=istat) -! open(25,form='binary',iostat=istat) -! --- open to fort.25 with link to file in script - open(25,form='formatted',iostat=istat) - if (istat.ne.0) then - mskocn = 0 - print *,' Ocean lsm file Open failure: mskocn,istat=',mskocn,istat - else - mskocn = 1 - print *,' Ocean lsm file Opened OK: mskocn,istat=',mskocn,istat - endif -! --- Read it in - ios=0 - OCLSM=0. -! read(25,iostat=ios)OCLSM - read(25,*,iostat=ios)OCLSM - if (ios.ne.0) then - mskocn = 0 -! --- did not properly read Gaussian grid ocean land-sea mask, but -! continue using ZSLMX - print *,' Rd fail: Ocean lsm - continue, mskocn,ios=',mskocn,ios - else - mskocn = 1 - print *,' Rd OK: ocean lsm: mskocn,ios=',mskocn,ios -! --- LSM initialized to ocean mask especially for case where Ocean -! --- changed by ocean model to land to cope with its problems -! --- remember, that lake mask is in zslm to be assigned in MAKEMT. - if ( mskocn .eq. 1 ) then - DO J = 1,JM - DO I = 1,IM - if ( notocn .eq. 0 ) then - slmi(i,j) = float(NINT(OCLSM(i,j))) - else - if ( NINT(OCLSM(i,j)) .eq. 0) then - slmi(i,j) = 1 - else - slmi(i,j) = 0 - endif - endif - enddo - enddo - print *,' OCLSM',OCLSM(1,1),OCLSM(50,50),OCLSM(75,75),OCLSM(IM,JM) - print *,' SLMI:',SLMI(1,1),SLMI(50,50),SLMI(75,75),SLMI(IM,JM) -! --- Diag -! WRITE(27,iostat=ios) REAL(SLMI,4) -! print *,' write SLMI/OCLSM diag input:',ios - endif - endif - - else - print *,' Not using Ocean model land sea mask' - endif - - if (mskocn .eq. 1)then - print *,' LSM:',OCLSM(1,1),OCLSM(50,50),OCLSM(75,75),OCLSM(IM,JM) - endif - allocate (GEOLON(IM,JM),GEOLON_C(IM+1,JM+1),DX(IM,JM)) allocate (GEOLAT(IM,JM),GEOLAT_C(IM+1,JM+1),DY(IM,JM)) allocate (SLM(IM,JM),ORO(IM,JM),VAR(IM,JM),VAR4(IM,JM)) @@ -785,37 +699,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ENDDO ENDDO C -! --- if mskocn=1 ocean land sea mask given, =0 if not present -! --- OCLSM is real(*4) array with fractional values possible -! --- 0 is ocean and 1 is land for slm -! --- Step 1: Only change SLM after GFS SLM is applied -! --- SLM is only field that will be altered by OCLSM -! --- Ocean land sea mask ocean points made ocean in atm model -! --- Land and Lakes and all other atm elv moments remain unchanged. - - IF (MERGE_FILE == 'none') then - - MSK_OCN : if ( mskocn .eq. 1 ) then - - DO j = 1,jm - DO i = 1,im - if (abs (oro(i,j)) .lt. 1. ) then - slm(i,j) = slmi(i,j) - else - if ( slmi(i,j) .eq. 1. .and. slm(i,j) .eq. 1) slm(i,j) = 1 - if ( slmi(i,j) .eq. 0. .and. slm(i,j) .eq. 0) slm(i,j) = 0 - if ( slmi(i,j) .eq. 0. .and. slm(i,j) .eq. 1) slm(i,j) = 0 - if ( slmi(i,j) .eq. 0. .and. slm(i,j) .eq. 0) slm(i,j) = 0 - endif - enddo - enddo - endif MSK_OCN - endif - print *,' SLM(itest,jtest)=',slm(itest,jtest),itest,jtest - print *,' ORO(itest,jtest)=',oro(itest,jtest),itest,jtest - - deallocate(SLMI) - IF (MERGE_FILE == 'none') then C REMOVE ISOLATED POINTS @@ -1010,12 +893,10 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, deallocate(COSCLT,WGTCLT,RCLT,XLAT,XLON,oaa,ola,GLAT) ! Deallocate 2d vars - deallocate (OCLSM) deallocate (GEOLON,GEOLON_C,GEOLAT,GEOLAT_C) deallocate (SLM,ORO,VAR,land_frac) deallocate (THETA,GAMMA,SIGMA,ELVMAX) - tend=timef() write(6,*)' Total runtime time= ',tend-tbeg1 RETURN @@ -1147,7 +1028,6 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, real XNSUM_ALL,XLAND_ALL,XWATR_ALL logical inside_a_polygon C -! ---- OCLSM holds the ocean (im,jm) grid print *,' _____ SUBROUTINE MAKE_MASK ' C---- GLOBAL XLAT AND XLON ( DEGREE ) C @@ -1224,9 +1104,6 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, IF(XNSUM.GT.1.) THEN -! --- SLM initialized with OCLSM calc from all land points except .... -! --- 0 is ocean and 1 is land for slm -! --- Step 1 is to only change SLM after GFS SLM is applied land_frac(i,j) = XLAND/XNSUM SLM(I,J) = FLOAT(NINT(XLAND/XNSUM)) ELSEIF(XNSUM_ALL.GT.1.) THEN @@ -1286,9 +1163,6 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, real XL1_ALL,XS1_ALL,XW1_ALL,XW2_ALL,XW4_ALL logical inside_a_polygon C -! ---- OCLSM holds the ocean (im,jm) grid -! --- mskocn=1 Use ocean model sea land mask, OK and present, -! --- mskocn=0 dont use Ocean model sea land mask, not OK, not present print *,' _____ SUBROUTINE MAKEMT2 ' allocate(hgt_1d(MAXSUM)) allocate(hgt_1d_all(MAXSUM)) @@ -1395,11 +1269,6 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, enddo ; enddo IF(XNSUM.GT.1.) THEN -! --- SLM initialized with OCLSM calc from all land points except .... -! --- 0 is ocean and 1 is land for slm -! --- Step 1 is to only change SLM after GFS SLM is applied - - !IF(SLM(I,J).NE.0.) THEN IF(SLM(I,J) .NE. 0. .OR. LAND_FRAC(I,J) > 0.) THEN IF (XLAND > 0) THEN ORO(I,J)= XL1 / XLAND From 6b4568eb30c8bca3d84485522d3f29a3035e16f7 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 16 Jul 2024 15:22:44 +0000 Subject: [PATCH 16/54] Move read of model 'grid' file in the driver to its own subroutine - read_mdl_dims. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 44 ++----------------- sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 | 43 ++++++++++++++++++ 2 files changed, 47 insertions(+), 40 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 8c3f56d66..28c1bb4b9 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -58,16 +58,12 @@ C> C> @return 0 for success, error code otherwise. implicit none - include 'netcdf.inc' - logical fexist, opened integer imn, jmn - integer fsize, ncid, error, id_dim, nx, ny - character(len=256) :: OUTGRID = "none" + character(len=256) :: MDL_GRID_FILE = "none" character(len=256) :: merge_file = "none" logical :: mask_only = .false. integer :: IM,JM,EFAC - fsize=65536 - READ(5,*) OUTGRID + READ(5,*) MDL_GRID_FILE READ(5,*) mask_only READ(5,*) merge_file EFAC=0 @@ -78,42 +74,10 @@ JMN = 180*120 print *, ' Starting terr12 mtnlm7_slm30.f IMN,JMN:',IMN,JMN -! --- read the grid resolution from OUTGRID. - inquire(file=trim(OUTGRID), exist=fexist) - if(.not. fexist) then - print*, "FATAL ERROR: file "//trim(OUTGRID) - print*, " does not exist." - CALL ERREXIT(4) - endif - do ncid = 103, 512 - inquire( ncid,OPENED=opened ) - if( .NOT.opened )exit - end do - - print*, "READ outgrid=", trim(outgrid) - error=NF__OPEN(trim(OUTGRID),NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Open file '//trim(OUTGRID) ) - error=nf_inq_dimid(ncid, 'nx', id_dim) - call netcdf_err(error, 'inquire dimension nx from file '// - & trim(OUTGRID) ) - error=nf_inq_dimlen(ncid,id_dim,nx) - call netcdf_err(error, 'inquire dimension nx length '// - & 'from file '//trim(OUTGRID) ) - - error=nf_inq_dimid(ncid, 'ny', id_dim) - call netcdf_err(error, 'inquire dimension ny from file '// - & trim(OUTGRID) ) - error=nf_inq_dimlen(ncid,id_dim,ny) - call netcdf_err(error, 'inquire dimension ny length '// - & 'from file '//trim(OUTGRID) ) - IM = nx/2 - JM = ny/2 - print*, "nx, ny, im, jm = ", nx, ny, im, jm - error=nf_close(ncid) - call netcdf_err(error, 'close file '//trim(OUTGRID) ) + call read_mdl_dims(mdl_grid_file, im, jm) CALL TERSUB(IMN,JMN,IM,JM,EFAC, - & OUTGRID,MASK_ONLY,MERGE_FILE) + & MDL_GRID_FILE,MASK_ONLY,MERGE_FILE) STOP END diff --git a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 index b48aaea59..347957e4d 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 @@ -377,3 +377,46 @@ subroutine read_mask(merge_file,slm,land_frac,lake_frac,im,jm) print*,'bot of read_mask' end subroutine read_mask + +!> Read the grid dimensions from the model 'grid' file +!! +!! @param[in] mdl_grid_file path/name of model 'grid' file. +!! @param[out] im 'i' dimension of a model grid tile. +!! @param[out] jm 'j' dimension of a model grid tile. +!! @author George Gayno NOAA/EMC + subroutine read_mdl_dims(mdl_grid_file, im, jm) + + implicit none + include "netcdf.inc" + + character(len=*), intent(in) :: mdl_grid_file + + integer, intent(out) :: im, jm + + integer ncid, error, fsize, id_dim, nx, ny + + fsize = 66536 + + print*, "- OPEN AND READ= ", trim(mdl_grid_file) + + error=NF__OPEN(mdl_grid_file,NF_NOWRITE,fsize,ncid) + call netcdf_err(error, 'Opening file '//trim(mdl_grid_file) ) + + error=nf_inq_dimid(ncid, 'nx', id_dim) + call netcdf_err(error, 'inquire dimension nx from file '// trim(mdl_grid_file) ) + error=nf_inq_dimlen(ncid,id_dim,nx) + call netcdf_err(error, 'inquire nx from file '//trim(mdl_grid_file) ) + + error=nf_inq_dimid(ncid, 'ny', id_dim) + call netcdf_err(error, 'inquire dimension ny from file '// trim(mdl_grid_file) ) + error=nf_inq_dimlen(ncid,id_dim,ny) + call netcdf_err(error, 'inquire ny from file '//trim(mdl_grid_file) ) + + error=nf_close(ncid) + + IM = nx/2 + JM = ny/2 + + print*,"- MDL GRID DIMENSIONS ", im, jm + + end subroutine read_mdl_dims From 2725c69cb36b44b88ce30371f407a1a308e35f0d Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 16 Jul 2024 17:34:12 +0000 Subject: [PATCH 17/54] Remove obsolete calls to sp library routines. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/CMakeLists.txt | 4 --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 26 +++---------------- 2 files changed, 4 insertions(+), 26 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt index cd0e5eed3..ec8168faa 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt +++ b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt @@ -26,10 +26,6 @@ target_link_libraries( w3emc::w3emc_d NetCDF::NetCDF_Fortran) -if(sp_FOUND) - target_link_libraries(orog_lib PUBLIC sp::sp_d) -endif() - if(OpenMP_Fortran_FOUND) target_link_libraries(orog_lib PUBLIC OpenMP::OpenMP_Fortran) endif() diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 28c1bb4b9..7924d0815 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -131,8 +131,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, real :: DEGRAD,maxlat, minlat,timef,tbeg,tend,tbeg1 real :: DELXN,slma,oroa,vara,var4a,xn,XS - real, allocatable :: COSCLT(:),WGTCLT(:),RCLT(:),XLAT(:) - real, allocatable :: XLON(:),oaa(:),ola(:),GLAT(:) + real, allocatable :: XLAT(:),XLON(:),oaa(:),ola(:),GLAT(:) real, allocatable :: GEOLON(:,:),GEOLON_C(:,:),DX(:,:) real, allocatable :: GEOLAT(:,:),GEOLAT_C(:,:),DY(:,:) @@ -159,8 +158,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, allocate (glob(IMN,JMN)) ! reals - allocate (COSCLT(JM),WGTCLT(JM),RCLT(JM),XLAT(JM)) - allocate (XLON(IM),oaa(4),ola(4),GLAT(JMN)) + allocate (oaa(4),ola(4),GLAT(JMN)) allocate (ZAVG(IMN,JMN)) allocate (ZSLM(IMN,JMN)) @@ -260,25 +258,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ZSLM(i,JMN)=1 enddo ! -! print *,' kount1,2,ZAVG(1,1),ZAVG(imn,jmn),ZAVG(500,500)', -! & kount,kount2,ZAVG(1,1),ZAVG(imn,jmn),ZAVG(500,500) -! --- The center of pixel (1,1) is 89.9958333N/179.9958333W with dx/dy -! --- spacing of 1/120 degrees. -! -! When the gaussian grid routines makemt, makepc and makeoa are -! removed, xlat can be removed. - CALL SPLAT(0,JM,COSCLT,WGTCLT) - DO J=1,JM - RCLT(J) = ACOS(COSCLT(J)) - XLAT(J) = 90.0 - RCLT(J) * DEGRAD - ENDDO - allocate (GICE(IMN+1,3601)) ! - print *,' XLAT=' - write (6,106) (xlat(J),J=JM,1,-1) - 106 format( 10(f7.3,1x)) -C DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION C DO J=1,JMN @@ -836,6 +817,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, C DELXN = 360./IM + allocate(xlat(jm), xlon(im)) do j = 1, jm xlat(j) = geolat(1,j) enddo @@ -854,7 +836,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ! Deallocate 1d vars deallocate(JST,JEN) - deallocate(COSCLT,WGTCLT,RCLT,XLAT,XLON,oaa,ola,GLAT) + deallocate(XLAT,XLON,oaa,ola,GLAT) ! Deallocate 2d vars deallocate (GEOLON,GEOLON_C,GEOLAT,GEOLAT_C) From fae9d8c9aa17a8baa9f025352ce2a8ba95f982bc Mon Sep 17 00:00:00 2001 From: George Gayno Date: Mon, 22 Jul 2024 17:13:26 +0000 Subject: [PATCH 18/54] Place logic that find i/j indices of the n/s poles in its own routine. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 109 ++++++++++++------ 1 file changed, 71 insertions(+), 38 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 7924d0815..d3452d2a3 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -128,7 +128,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, integer, allocatable :: IWORK(:,:,:) - real :: DEGRAD,maxlat, minlat,timef,tbeg,tend,tbeg1 + real :: DEGRAD,timef,tbeg,tend,tbeg1 real :: DELXN,slma,oroa,vara,var4a,xn,XS real, allocatable :: XLAT(:),XLON(:),oaa(:),ola(:),GLAT(:) @@ -319,10 +319,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, !--- reading grid file. is_south_pole = .false. is_north_pole = .false. - i_south_pole = 0 - j_south_pole = 0 - i_north_pole = 0 - j_north_pole = 0 inquire(file=trim(OUTGRID), exist=fexist) if(.not. fexist) then @@ -373,39 +369,9 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, geolat(1:IM,1:JM) = tmpvar(2:nx:2,2:ny:2) geolat_c(1:IM+1,1:JM+1) = tmpvar(1:nx+1:2,1:ny+1:2) - !--- figure out pole location. - maxlat = -90 - minlat = 90 - i_north_pole = 0 - j_north_pole = 0 - i_south_pole = 0 - j_south_pole = 0 - do j = 1, ny+1; do i = 1, nx+1 - if( tmpvar(i,j) > maxlat ) then - i_north_pole=i - j_north_pole=j - maxlat = tmpvar(i,j) - endif - if( tmpvar(i,j) < minlat ) then - i_south_pole=i - j_south_pole=j - minlat = tmpvar(i,j) - endif - enddo ; enddo - !--- only when maxlat is close to 90. the point is north pole - if(maxlat < 89.9 ) then - i_north_pole = 0 - j_north_pole = 0 - endif - if(minlat > -89.9 ) then - i_south_pole = 0 - j_south_pole = 0 - endif - print*, "minlat=", minlat, "maxlat=", maxlat - print*, "north pole supergrid index is ", - & i_north_pole, j_north_pole - print*, "south pole supergrid index is ", - & i_south_pole, j_south_pole + call find_poles(tmpvar, nx, ny, i_north_pole, j_north_pole, + & i_south_pole, j_south_pole) + deallocate(tmpvar) if(i_south_pole >0 .and. j_south_pole > 0) then @@ -2588,3 +2554,70 @@ real function timef() timef=elapsed return end function timef + +!> Find the i/j indices of the north/south poles on +!! a model grid tile. +!! +!! @param[in] tmpvar Latitude on the supergrid. +!! @param[in] nx i-dimension of the supergrid. +!! @param[in] ny j-dimension of the supergrid. +!! @param[out] i_north_pole 'i' index of north pole. '0' if +!! pole is outside of grid. +!! @param[out] j_north_pole 'j' index of north pole. '0' if +!! pole is outside of grid. +!! @param[out] i_south_pole 'i' index of south pole. '0' if +!! pole is outside of grid. +!! @param[out] j_south_pole 'j' index of south pole. '0' if +!! pole is outside of grid. +!! @author GFDL Programmer + subroutine find_poles(tmpvar, nx, ny, i_north_pole, j_north_pole, + & i_south_pole, j_south_pole) + + implicit none + + integer, intent(in) :: nx, ny + + real, intent(in) :: tmpvar(nx+1,ny+1) + + integer, intent(out) :: i_north_pole, j_north_pole + integer, intent(out) :: i_south_pole, j_south_pole + + integer :: i, j + + real :: maxlat, minlat + + !--- figure out pole location. + maxlat = -90 + minlat = 90 + i_north_pole = 0 + j_north_pole = 0 + i_south_pole = 0 + j_south_pole = 0 + do j = 1, ny+1; do i = 1, nx+1 + if( tmpvar(i,j) > maxlat ) then + i_north_pole=i + j_north_pole=j + maxlat = tmpvar(i,j) + endif + if( tmpvar(i,j) < minlat ) then + i_south_pole=i + j_south_pole=j + minlat = tmpvar(i,j) + endif + enddo ; enddo + !--- only when maxlat is close to 90. the point is north pole + if(maxlat < 89.9 ) then + i_north_pole = 0 + j_north_pole = 0 + endif + if(minlat > -89.9 ) then + i_south_pole = 0 + j_south_pole = 0 + endif + print*, "minlat=", minlat, "maxlat=", maxlat + print*, "north pole supergrid index is ", + & i_north_pole, j_north_pole + print*, "south pole supergrid index is ", + & i_south_pole, j_south_pole + + end subroutine find_poles From b14925536b80e7550776db3dea2596c54d22576a Mon Sep 17 00:00:00 2001 From: George Gayno Date: Mon, 22 Jul 2024 19:44:35 +0000 Subject: [PATCH 19/54] Move logic that finds the model points which surround the pole to its own subroutine. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 153 +++++++++++------- 1 file changed, 97 insertions(+), 56 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index d3452d2a3..fc83deebe 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -317,8 +317,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, allocate (land_frac(IM,JM),lake_frac(IM,JM)) !--- reading grid file. - is_south_pole = .false. - is_north_pole = .false. inquire(file=trim(OUTGRID), exist=fexist) if(.not. fexist) then @@ -373,49 +371,11 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, & i_south_pole, j_south_pole) deallocate(tmpvar) - - if(i_south_pole >0 .and. j_south_pole > 0) then - if(mod(i_south_pole,2)==0) then ! stretched grid - do j = 1, JM; do i = 1, IM - if(i==i_south_pole/2 .and. (j==j_south_pole/2 - & .or. j==j_south_pole/2+1) ) then - is_south_pole(i,j) = .true. - print*, "south pole at i,j=", i, j - endif - enddo; enddo - else - do j = 1, JM; do i = 1, IM - if((i==i_south_pole/2 .or. i==i_south_pole/2+1) - & .and. (j==j_south_pole/2 .or. - & j==j_south_pole/2+1) ) then - is_south_pole(i,j) = .true. - print*, "south pole at i,j=", i, j - endif - enddo; enddo - endif - endif - - if(i_north_pole >0 .and. j_north_pole > 0) then - if(mod(i_north_pole,2)==0) then ! stretched grid - do j = 1, JM; do i = 1, IM - if(i==i_north_pole/2 .and. (j==j_north_pole/2 .or. - & j==j_north_pole/2+1) ) then - is_north_pole(i,j) = .true. - print*, "north pole at i,j=", i, j - endif - enddo; enddo - else - do j = 1, JM; do i = 1, IM - if((i==i_north_pole/2 .or. i==i_north_pole/2+1) - & .and. (j==j_north_pole/2 .or. - & j==j_north_pole/2+1) ) then - is_north_pole(i,j) = .true. - print*, "north pole at i,j=", i, j - endif - enddo; enddo - endif - endif + call find_nearest_pole_points(i_north_pole, j_north_pole, + & i_south_pole, j_south_pole, im, jm, is_north_pole, + & is_south_pole) + allocate(tmpvar(nx,ny)) error=nf_inq_varid(ncid, 'area', id_var) call netcdf_err(error, 'inquire varid of area from file ' @@ -2555,10 +2515,10 @@ real function timef() return end function timef -!> Find the i/j indices of the north/south poles on -!! a model grid tile. +!> Find the point on the model grid tile closest to the +!! north and south pole. !! -!! @param[in] tmpvar Latitude on the supergrid. +!! @param[in] geolat Latitude on the supergrid. !! @param[in] nx i-dimension of the supergrid. !! @param[in] ny j-dimension of the supergrid. !! @param[out] i_north_pole 'i' index of north pole. '0' if @@ -2570,14 +2530,14 @@ end function timef !! @param[out] j_south_pole 'j' index of south pole. '0' if !! pole is outside of grid. !! @author GFDL Programmer - subroutine find_poles(tmpvar, nx, ny, i_north_pole, j_north_pole, + subroutine find_poles(geolat, nx, ny, i_north_pole, j_north_pole, & i_south_pole, j_south_pole) implicit none integer, intent(in) :: nx, ny - real, intent(in) :: tmpvar(nx+1,ny+1) + real, intent(in) :: geolat(nx+1,ny+1) integer, intent(out) :: i_north_pole, j_north_pole integer, intent(out) :: i_south_pole, j_south_pole @@ -2586,6 +2546,7 @@ subroutine find_poles(tmpvar, nx, ny, i_north_pole, j_north_pole, real :: maxlat, minlat + print*,'- CHECK IF THE TILE CONTAINS A POLE.' !--- figure out pole location. maxlat = -90 minlat = 90 @@ -2594,15 +2555,15 @@ subroutine find_poles(tmpvar, nx, ny, i_north_pole, j_north_pole, i_south_pole = 0 j_south_pole = 0 do j = 1, ny+1; do i = 1, nx+1 - if( tmpvar(i,j) > maxlat ) then + if( geolat(i,j) > maxlat ) then i_north_pole=i j_north_pole=j - maxlat = tmpvar(i,j) + maxlat = geolat(i,j) endif - if( tmpvar(i,j) < minlat ) then + if( geolat(i,j) < minlat ) then i_south_pole=i j_south_pole=j - minlat = tmpvar(i,j) + minlat = geolat(i,j) endif enddo ; enddo !--- only when maxlat is close to 90. the point is north pole @@ -2614,10 +2575,90 @@ subroutine find_poles(tmpvar, nx, ny, i_north_pole, j_north_pole, i_south_pole = 0 j_south_pole = 0 endif - print*, "minlat=", minlat, "maxlat=", maxlat - print*, "north pole supergrid index is ", + print*, "- MINLAT=", minlat, "MAXLAT=", maxlat + print*, "- NORTH POLE SUPERGRID INDEX IS ", & i_north_pole, j_north_pole - print*, "south pole supergrid index is ", + print*, "- SOUTH POLE SUPERGRID INDEX IS ", & i_south_pole, j_south_pole end subroutine find_poles + +!> Find the point on the model grid tile closest to the +!! north and south pole. +!! +!! @param[in] i_north_pole 'i' index of north pole. '0' if +!! pole is outside of grid. +!! @param[in] j_north_pole 'j' index of north pole. '0' if +!! pole is outside of grid. +!! @param[in] i_south_pole 'i' index of south pole. '0' if +!! pole is outside of grid. +!! @param[in] j_south_pole 'j' index of south pole. '0' if +!! pole is outside of grid. +!! @param[in] im i-dimension of model tile +!! @param[in] jm j-dimension of model tile +!! @param[out] is_north_pole 'true' for points surrounding the north pole. +!! @param[out] is_south_pole 'true' for points surrounding the south pole. +!! @author GFDL Programmer + subroutine find_nearest_pole_points(i_north_pole, j_north_pole, + & i_south_pole, j_south_pole, im, jm, is_north_pole, + & is_south_pole) + + implicit none + + integer, intent(in) :: im, jm + integer, intent(in) :: i_north_pole, j_north_pole + integer, intent(in) :: i_south_pole, j_south_pole + + logical, intent(out) :: is_north_pole(im,jm) + logical, intent(out) :: is_south_pole(im,jm) + + integer :: i, j + + print*,'- FIND NEAREST POLE POINTS.' + + is_north_pole=.false. + is_south_pole=.false. + + if(i_south_pole >0 .and. j_south_pole > 0) then + if(mod(i_south_pole,2)==0) then ! stretched grid + do j = 1, JM; do i = 1, IM + if(i==i_south_pole/2 .and. (j==j_south_pole/2 + & .or. j==j_south_pole/2+1) ) then + is_south_pole(i,j) = .true. + print*, "- SOUTH POLE AT I,J= ", i, j + endif + enddo; enddo + else + do j = 1, JM; do i = 1, IM + if((i==i_south_pole/2 .or. i==i_south_pole/2+1) + & .and. (j==j_south_pole/2 .or. + & j==j_south_pole/2+1) ) then + is_south_pole(i,j) = .true. + print*, "- SOUTH POLE AT I,J= ", i, j + endif + enddo; enddo + endif + endif + + if(i_north_pole >0 .and. j_north_pole > 0) then + if(mod(i_north_pole,2)==0) then ! stretched grid + do j = 1, JM; do i = 1, IM + if(i==i_north_pole/2 .and. (j==j_north_pole/2 .or. + & j==j_north_pole/2+1) ) then + is_north_pole(i,j) = .true. + print*, "- NORTH POLE AT I,J= ", i, j + endif + enddo; enddo + else + do j = 1, JM; do i = 1, IM + if((i==i_north_pole/2 .or. i==i_north_pole/2+1) + & .and. (j==j_north_pole/2 .or. + & j==j_north_pole/2+1) ) then + is_north_pole(i,j) = .true. + print*, "- NORTH POLE AT I,J= ", i, j + endif + enddo; enddo + endif + endif + + end subroutine find_nearest_pole_points From c4f10c24d65bc91beba75c0d2861e84b6f0a706f Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 23 Jul 2024 13:50:14 +0000 Subject: [PATCH 20/54] Remove some unneeded diagnostic print. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 62 ------------------- 1 file changed, 62 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index fc83deebe..7a693075f 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -115,7 +115,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, integer :: id_var,fsize,wgta,IN,INW,INE,IS,ISW,ISE integer :: itest,jtest integer :: i_south_pole,j_south_pole,i_north_pole,j_north_pole - integer :: maxc3,maxc4,maxc5,maxc6,maxc7,maxc8 integer(1) :: i3save integer(2) :: i2save @@ -426,18 +425,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, call minmxj(IM,JM,SLM,' SLM') call minmxj(IM,JM,VAR,' VAR') call minmxj(IM,JM,VAR4,' VAR4') -! -C check antarctic pole -! DO J = 1,JM -! DO I = 1,IM -! if ( i .le. 100 .and. i .ge. 1 )then -! if (j .ge. JM-1 )then -! if (height .eq. 0.) print *,'I,J,SLM:',I,J,SLM(I,J) -! write(6,153)i,j,ORO(i,j),HEIGHT,SLM(i,j) -! endif -! endif -! ENDDO -! ENDDO C C === Compute mtn principal coord HTENSR: THETA,GAMMA,SIGMA C @@ -451,7 +438,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, call minmxj(IM,JM,THETA,' THETA') call minmxj(IM,JM,GAMMA,' GAMMA') call minmxj(IM,JM,SIGMA,' SIGMA') - C C COMPUTE MOUNTAIN DATA : OA OL C @@ -486,27 +472,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, call minmxj(IM,JM,ELVMAX,' ELVMAX') call minmxj(IM,JM,ORO,' ORO') - maxc3 = 0 - maxc4 = 0 - maxc5 = 0 - maxc6 = 0 - maxc7 = 0 - maxc8 = 0 - DO J = 1,JM - DO I = 1,IM - if (ELVMAX(I,J) .gt. 3000.) maxc3 = maxc3 +1 - if (ELVMAX(I,J) .gt. 4000.) maxc4 = maxc4 +1 - if (ELVMAX(I,J) .gt. 5000.) maxc5 = maxc5 +1 - if (ELVMAX(I,J) .gt. 6000.) maxc6 = maxc6 +1 - if (ELVMAX(I,J) .gt. 7000.) maxc7 = maxc7 +1 - if (ELVMAX(I,J) .gt. 8000.) maxc8 = maxc8 +1 - ENDDO - ENDDO - print *,' MAXC3:',maxc3,maxc4,maxc5,maxc6,maxc7,maxc8 -! -c itest=151 -c jtest=56 -C print *,' ===> Replacing ELVMAX with ELVMAX-ORO <=== ' print *,' ===> if ELVMAX<=ORO replace with proxy <=== ' print *,' ===> the sum of mean orog (ORO) and std dev <=== ' @@ -520,26 +485,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, endif ENDDO ENDDO - maxc3 = 0 - maxc4 = 0 - maxc5 = 0 - maxc6 = 0 - maxc7 = 0 - maxc8 = 0 - DO J = 1,JM - DO I = 1,IM - if (ELVMAX(I,J) .gt. 3000.) maxc3 = maxc3 +1 - if (ELVMAX(I,J) .gt. 4000.) maxc4 = maxc4 +1 - if (ELVMAX(I,J) .gt. 5000.) maxc5 = maxc5 +1 - if (ELVMAX(I,J) .gt. 6000.) maxc6 = maxc6 +1 - if (ELVMAX(I,J) .gt. 7000.) maxc7 = maxc7 +1 - if (ELVMAX(I,J) .gt. 8000.) maxc8 = maxc8 +1 - ENDDO - ENDDO - print *,' after MAXC 3-6 km:',maxc3,maxc4,maxc5,maxc6 c call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') -! if (JM .gt. 0) stop C C ZERO OVER OCEAN C @@ -729,15 +676,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, & ORO(itest,jtest),itest,jtest print *,' ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) -C check antarctic pole - DO J = 1,JM - DO I = 1,IM - if ( i .le. 21 .and. i .ge. 1 )then - if (j .eq. JM )write(6,153)i,j,ORO(i,j),ELVMAX(i,j),SLM(i,j) - 153 format(1x,' ORO,ELVMAX(i=',i4,' j=',i4,')=',2E14.5,f5.1) - endif - ENDDO - ENDDO tend=timef() write(6,*)' Timer 5 time= ',tend-tbeg C From b62cc65381cf6034c7256577659372cb45b585d6 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 23 Jul 2024 15:39:48 +0000 Subject: [PATCH 21/54] Move transpose of orography data to its own routine. Remove uneeded routine maxmin. Some general clean up. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 138 +++++++----------- 1 file changed, 54 insertions(+), 84 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 7a693075f..8349d9045 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -116,7 +116,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, integer :: itest,jtest integer :: i_south_pole,j_south_pole,i_north_pole,j_north_pole integer(1) :: i3save - integer(2) :: i2save integer, allocatable :: JST(:),JEN(:) @@ -184,28 +183,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, C C- READ_G for global 30" terrain C - print *,' Call read_g to read global topography' - call read_g(glob) -! --- transpose even though glob 30" is from S to N and NCEP std is N to S - do j=1,jmn/2 - do I=1,imn - jt=jmn - j + 1 - i2save = glob(I,j) - glob(I,j)=glob(I,jt) - glob(I,jt) = i2save - enddo - enddo -! --- transpose glob as USGS 30" is from dateline and NCEP std is 0 - do j=1,jmn - do I=1,imn/2 - it=imn/2 + i - i2save = glob(i,J) - glob(i,J)=glob(it,J) - glob(it,J) = i2save - enddo - enddo - print *,' After read_g, glob(500,500)=',glob(500,500) -! + call read_global_orog(imn,jmn,glob) ! --- IMN,JMN print*, ' IM, JM, EFAC' @@ -1930,19 +1908,24 @@ END SUBROUTINE mnmxja !> Read input global 30-arc second orography data. !! +!! @param[in] imn i-dimension of orography data. +!! @param[in] jmn j-dimension of orography data. !! @param[out] glob The orography data. !! @author Jordan Alpert NOAA/EMC - subroutine read_g(glob) + subroutine read_global_orog(imn,jmn,glob) implicit none include 'netcdf.inc' - integer*2, intent(out) :: glob(360*120,180*120) + integer, intent(in) :: imn, jmn + integer*2, intent(out) :: glob(imn,jmn) integer :: ncid, error, id_var, fsize fsize=65536 + print*,"- OPEN AND READ ./topography.gmted2010.30s.nc" + error=NF__OPEN("./topography.gmted2010.30s.nc", & NF_NOWRITE,fsize,ncid) call netcdf_err(error, 'Open file topography.gmted2010.30s.nc' ) @@ -1952,67 +1935,12 @@ subroutine read_g(glob) call netcdf_err(error, 'Read topo') error = nf_close(ncid) - print*,' ' - call maxmin (glob,360*120*180*120,'global0') + print*,"- MAX/MIN OF OROGRAPHY DATA ",maxval(glob),minval(glob) + + call transpose_orog(imn,jmn,glob) return - end subroutine read_g - -!> Print the maximum, mininum, mean and -!! standard deviation of an array. -!! -!! @param [in] ia The array to be checked. -!! @param [in] len The number of points to be checked. -!! @param [in] tile A name associated with the array. -!! @author Jordan Alpert NOAA/EMC - subroutine maxmin(ia,len,tile) -ccmr - implicit none -ccmr - integer*2 ia(len) - character*7 tile - integer iaamax, iaamin, len, m, ja, kount - integer(8) sum2,std,mean,isum - integer i_count_notset,kount_9 -! --- missing is -9999 -c - isum = 0 - sum2 = 0 - kount = 0 - kount_9 = 0 - iaamax = -9999999 -ccmr iaamin = 1 - iaamin = 9999999 - i_count_notset=0 - do 10 m=1,len - ja=ia(m) -ccmr if ( ja .lt. 0 ) print *,' ja < 0:',ja -ccmr if ( ja .eq. -9999 ) goto 10 - if ( ja .eq. -9999 ) then - kount_9=kount_9+1 - goto 10 - endif - if ( ja .eq. -12345 ) i_count_notset=i_count_notset+1 -ccmr if ( ja .eq. 0 ) goto 11 - iaamax = max0( iaamax, ja ) - iaamin = min0( iaamin, ja ) -! iaamax = max0( iaamax, ia(m,j) ) -! iaamin = min0( iaamin, ia(m,j) ) - 11 continue - kount = kount + 1 - isum = isum + ja -ccmr sum2 = sum2 + ifix( float(ja) * float(ja) ) - sum2 = sum2 + ja*ja - 10 continue -! - mean = isum/kount - std = ifix(sqrt(float((sum2/(kount))-mean**2))) - print*,tile,' max=',iaamax,' min=',iaamin,' sum=',isum, - & ' i_count_notset=',i_count_notset - print*,tile,' mean=',mean,' std.dev=',std, - & ' ko9s=',kount,kount_9,kount+kount_9 - return - end subroutine maxmin + end subroutine read_global_orog !> Convert from latitude and longitude to x,y,z coordinates. !! @@ -2600,3 +2528,45 @@ subroutine find_nearest_pole_points(i_north_pole, j_north_pole, endif end subroutine find_nearest_pole_points + +!> Transpose the global orography data by flipping +!! the poles and moving the starting longitude to +!! Greenwich. +!! +!! @param[in] imn i-dimension of orography data. +!! @param[in] jmn j-dimension of orography data. +!! @param[inout] glob The global orography data. +!! @author G. Gayno + subroutine transpose_orog(imn, jmn, glob) + + implicit none + + integer, intent(in) :: imn, jmn + integer(2), intent(inout) :: glob(imn,jmn) + + integer :: i, j, it, jt + integer(2) :: i2save + +! Transpose from S to N to the NCEP standard N to S. + + do j=1,jmn/2 + do I=1,imn + jt=jmn - j + 1 + i2save = glob(I,j) + glob(I,j)=glob(I,jt) + glob(I,jt) = i2save + enddo + enddo + +! Data begins at dateline. NCEP standard is Greenwich. + + do j=1,jmn + do I=1,imn/2 + it=imn/2 + i + i2save = glob(i,J) + glob(i,J)=glob(it,J) + glob(it,J) = i2save + enddo + enddo + + end subroutine transpose_orog From 428f6d6bcc2731b7ccd3bba3393678b7991526b0 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 23 Jul 2024 17:52:15 +0000 Subject: [PATCH 22/54] Place read of global mask data and its transpose in new routines. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 115 ++++++++++++------ 1 file changed, 81 insertions(+), 34 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 8349d9045..763241174 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -111,15 +111,14 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, integer, PARAMETER :: NMT=14 integer :: efac,zsave1,zsave2 - integer :: i,j,nx,ny,ncid,js,jn,iw,ie,k,it,jt,error,id_dim + integer :: i,j,nx,ny,ncid,js,jn,iw,ie,k,error,id_dim integer :: id_var,fsize,wgta,IN,INW,INE,IS,ISW,ISE integer :: itest,jtest integer :: i_south_pole,j_south_pole,i_north_pole,j_north_pole - integer(1) :: i3save integer, allocatable :: JST(:),JEN(:) - integer, allocatable :: IST(:,:),IEN(:,:),ZSLMX(:,:) + integer, allocatable :: IST(:,:),IEN(:,:) integer, allocatable :: ZAVG(:,:),ZSLM(:,:) integer(1), allocatable :: UMD(:,:) integer(2), allocatable :: glob(:,:) @@ -152,7 +151,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, fsize = 65536 ! integers allocate (JST(JM),JEN(JM)) - allocate (IST(IM,jm),IEN(IM,jm),ZSLMX(2700,1350)) + allocate (IST(IM,jm),IEN(IM,jm)) allocate (glob(IMN,JMN)) ! reals @@ -169,17 +168,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, print *,' In TERSUB' - print *,' Attempt to open/read UMD 30sec slmsk.' - - error=NF__OPEN("./landcover.umd.30s.nc",NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Open file landcover.umd.30s.nc' ) - error=nf_inq_varid(ncid, 'land_mask', id_var) - call netcdf_err(error, 'Inquire varid of land_mask') - error=nf_get_var_int1(ncid, id_var, UMD) - call netcdf_err(error, 'Inquire data of land_mask') - error = nf_close(ncid) - - print *,' UMD lake, UMD(50,50)=',UMD(50,50) + call read_global_mask(imn,jmn,umd) C C- READ_G for global 30" terrain C @@ -202,24 +191,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ! --- ZAVG initialize from glob ZAVG=glob -! --- transpose mask even though glob 30" is from N to S and NCEP std is S to N - do j=1,jmn/2 - do I=1,imn - jt=jmn - j + 1 - i3save = UMD(I,j) - UMD(I,j)=UMD(I,jt) - UMD(I,jt) = i3save - enddo - enddo -! --- transpose UMD as USGS 30" is from dateline and NCEP std is 0 - do j=1,jmn - do i=1,imn/2 - it=imn/2 + i - i3save = UMD(i,J) - UMD(i,J)=UMD(it,J) - UMD(it,J) = i3save - enddo - enddo ! --- Non-land is 0. do j=1,jmn do i=1,imn @@ -227,7 +198,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, enddo enddo - deallocate (ZSLMX,UMD,glob) + deallocate (UMD,glob) ! --- ! --- Fixing an error in the topo 30" data set at pole (-9999). do i=1,imn @@ -2570,3 +2541,79 @@ subroutine transpose_orog(imn, jmn, glob) enddo end subroutine transpose_orog + +!> Read input global 30-arc second land mask data. +!! +!! @param[in] imn i-dimension of orography data. +!! @param[in] jmn j-dimension of orography data. +!! @param[out] mask The land mask data. +!! @author G. Gayno NOAA/EMC + subroutine read_global_mask(imn, jmn, mask) + + implicit none + + include 'netcdf.inc' + + integer, intent(in) :: imn, jmn + + integer(1), intent(out) :: mask(imn,jmn) + + integer :: ncid, fsize, id_var, error + + fsize = 65536 + + print*,"- OPEN AND READ ./landcover.umd.30s.nc" + + error=NF__OPEN("./landcover.umd.30s.nc",NF_NOWRITE,fsize,ncid) + call netcdf_err(error, 'Open file landcover.umd.30s.nc' ) + error=nf_inq_varid(ncid, 'land_mask', id_var) + call netcdf_err(error, 'Inquire varid of land_mask') + error=nf_get_var_int1(ncid, id_var, mask) + call netcdf_err(error, 'Inquire data of land_mask') + error = nf_close(ncid) + + call transpose_mask(imn,jmn,mask) + + end subroutine read_global_mask + +!> Transpose the global landmask by flipping +!! the poles and moving the starting longitude to +!! Greenwich. +!! +!! @param[in] imn i-dimension of landmask data. +!! @param[in] jmn j-dimension of landmask data. +!! @param[inout] mask The global landmask data. +!! @author G. Gayno + subroutine transpose_mask(imn, jmn, mask) + + implicit none + + integer, intent(in) :: imn, jmn + integer(1), intent(inout) :: mask(imn,jmn) + + integer :: i, j, it, jt + integer(1) :: isave + +! Transpose from S to N to the NCEP standard N to S. + + do j=1,jmn/2 + do I=1,imn + jt=jmn - j + 1 + isave = mask(I,j) + mask(I,j)=mask(I,jt) + mask(I,jt) = isave + enddo + enddo + +! Data begins at dateline. NCEP standard is Greenwich. + + do j=1,jmn + do I=1,imn/2 + it=imn/2 + i + isave = mask(i,J) + mask(i,J)=mask(it,J) + mask(it,J) = isave + enddo + enddo + + end subroutine transpose_mask From 67a7df2f874f442f5c1e5afa420b96c817b01dd1 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 23 Jul 2024 18:50:53 +0000 Subject: [PATCH 23/54] Remove unused variable GLAT from routine TERSUB. Remove some old diagnostic print. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 106 ++++++------------ 1 file changed, 33 insertions(+), 73 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 763241174..c0e6f50a0 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -125,10 +125,10 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, integer, allocatable :: IWORK(:,:,:) - real :: DEGRAD,timef,tbeg,tend,tbeg1 - real :: DELXN,slma,oroa,vara,var4a,xn,XS + real :: timef,tbeg,tend,tbeg1 + real :: slma,oroa,vara,var4a,xn,XS - real, allocatable :: XLAT(:),XLON(:),oaa(:),ola(:),GLAT(:) + real, allocatable :: XLAT(:),XLON(:),oaa(:),ola(:) real, allocatable :: GEOLON(:,:),GEOLON_C(:,:),DX(:,:) real, allocatable :: GEOLAT(:,:),GEOLAT_C(:,:),DY(:,:) @@ -146,52 +146,36 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, logical :: fexist,opened logical :: is_south_pole(IM,JM), is_north_pole(IM,JM) + print *,' In TERSUB' + tbeg1=timef() tbeg=timef() fsize = 65536 -! integers + allocate (JST(JM),JEN(JM)) allocate (IST(IM,jm),IEN(IM,jm)) allocate (glob(IMN,JMN)) - -! reals - allocate (oaa(4),ola(4),GLAT(JMN)) - + allocate (oaa(4),ola(4)) allocate (ZAVG(IMN,JMN)) allocate (ZSLM(IMN,JMN)) allocate (UMD(IMN,JMN)) -! -! SET CONSTANTS AND ZERO FIELDS -! - DEGRAD = 180./PI - - print *,' In TERSUB' +! Read global mask data. call read_global_mask(imn,jmn,umd) -C -C- READ_G for global 30" terrain -C + +! Read global orography data. + call read_global_orog(imn,jmn,glob) -! --- IMN,JMN - print*, ' IM, JM, EFAC' - print*, IM,JM,EFAC - print *,' imn,jmn,glob(imn,jmn)=',imn,jmn,glob(imn,jmn) - print *,' UBOUND ZAVG=',UBOUND(ZAVG) - print *,' UBOUND glob=',UBOUND(glob) - print *,' UBOUND ZSLM=',UBOUND(ZSLM) - print *,' UBOUND GICE=',IMN+1,3601 -! -! --- 0 is ocean and 1 is land for slm -! -C -! --- ZSLM initialize with all land 1, ocean 0 +! ZSLM initialize with all land (1). Ocean is '0'. + ZSLM=1 -! --- ZAVG initialize from glob + +! ZAVG initialize from glob + ZAVG=glob -! --- Non-land is 0. do j=1,jmn do i=1,imn if ( UMD(i,j) .eq. 0 ) ZSLM(i,j) = 0 @@ -199,28 +183,15 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, enddo deallocate (UMD,glob) -! --- -! --- Fixing an error in the topo 30" data set at pole (-9999). - do i=1,imn - ZSLM(i,1)=0 - ZSLM(i,JMN)=1 - enddo -! + +! Fixing an error in the topo 30" data set at pole (-9999). + + do i=1,imn + ZSLM(i,1)=0 + ZSLM(i,JMN)=1 + enddo + allocate (GICE(IMN+1,3601)) -! - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO - print *, - & ' Before GICE ZAVG(1,2)=',ZAVG(1,2),ZSLM(1,2) - print *, - & ' Before GICE ZAVG(1,12)=',ZAVG(1,12),ZSLM(1,12) - print *, - & ' Before GICE ZAVG(1,52)=',ZAVG(1,52),ZSLM(1,52) - print *, - & ' Before GICE ZAVG(1,112)=',ZAVG(1,JMN-112),ZSLM(1,112) ! Read 30-sec Antarctica RAMP data. Points scan from South ! to North, and from Greenwich to Greenwich. @@ -250,8 +221,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ZSLM(i,j) = 1 endif endif - 152 format(1x,' ZAVG(i=',i4,' j=',i4,')=',i5,i3, - &' orig:',i5,i4,' Lat=',f7.3,f8.2,'E',' GICE=',f8.1) enddo enddo @@ -347,7 +316,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, tbeg=timef() IF (MERGE_FILE == 'none') then - CALL MAKE_MASK(ZSLM,SLM,land_frac,GLAT, + CALL MAKE_MASK(ZSLM,SLM,land_frac, & IM,JM,IMN,JMN,geolon_c,geolat_c) lake_frac=9999.9 ELSE @@ -364,7 +333,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, STOP END IF - CALL MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4,GLAT, + CALL MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, & IM,JM,IMN,JMN,geolon_c,geolat_c,lake_frac,land_frac) tend=timef() @@ -379,7 +348,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, C allocate (THETA(IM,JM),GAMMA(IM,JM),SIGMA(IM,JM),ELVMAX(IM,JM)) tbeg=timef() - CALL MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA,GLAT, + CALL MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, 1 IM,JM,IMN,JMN,geolon_c,geolat_c,SLM) tend=timef() write(6,*)' MAKEPC2 time= ',tend-tbeg @@ -399,7 +368,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, print*, "calling MAKEOA2 to compute OA, OL" tbeg=timef() - CALL MAKEOA2(ZAVG,zslm,VAR,GLAT,OA,OL,IWORK,ELVMAX,ORO, + CALL MAKEOA2(ZAVG,zslm,VAR,OA,OL,IWORK,ELVMAX,ORO, 1 WORK1,WORK2,WORK3,WORK4,WORK5,WORK6, 2 IM,JM,IMN,JMN,geolon_c,geolat_c, 3 geolon,geolat,dx,dy,is_south_pole,is_north_pole) @@ -627,8 +596,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, tend=timef() write(6,*)' Timer 5 time= ',tend-tbeg -C - DELXN = 360./IM allocate(xlat(jm), xlon(im)) do j = 1, jm @@ -649,7 +616,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ! Deallocate 1d vars deallocate(JST,JEN) - deallocate(XLAT,XLON,oaa,ola,GLAT) + deallocate(XLAT,XLON,oaa,ola) ! Deallocate 2d vars deallocate (GEOLON,GEOLON_C,GEOLAT,GEOLAT_C) @@ -760,8 +727,6 @@ END SUBROUTINE get_index !! @param[in] zslm The high-resolution input land-mask dataset. !! @param[out] slm Land-mask on the model tile. !! @param[out] land_frac Land fraction on the model tile. -!! @param[out] glat Latitude of each row of the high-resolution -!! orography and land-mask datasets. !! @param[in] im "i" dimension of the model grid. !! @param[in] jm "j" dimension of the model grid. !! @param[in] imn "i" dimension of the hi-res input orog/mask datasets. @@ -770,7 +735,7 @@ END SUBROUTINE get_index !! @param[in] lat_c Latitude on the model grid corner points. !! @author GFDL Programmer SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, - 1 GLAT,IM,JM,IMN,JMN,lon_c,lat_c) + 1 IM,JM,IMN,JMN,lon_c,lat_c) implicit none real, parameter :: D2R = 3.14159265358979/180. integer, parameter :: MAXSUM=20000000 @@ -889,8 +854,6 @@ END SUBROUTINE MAKE_MASK !! @param[in] slm Land-mask on the model tile. !! @param[out] var Standard deviation of orography on the model tile. !! @param[out] var4 Convexity on the model tile. -!! @param[out] glat Latitude of each row of the high-resolution -!! orography and land-mask datasets. !! @param[in] im "i" dimension of the model grid. !! @param[in] jm "j" dimension of the model grid. !! @param[in] imn "i" dimension of the hi-res input orog/mask datasets. @@ -901,7 +864,7 @@ END SUBROUTINE MAKE_MASK !! @param[in] land_frac Fractional land within the grid !! @author GFDL Programmer SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, - 1 GLAT,IM,JM,IMN,JMN,lon_c,lat_c,lake_frac,land_frac) + 1 IM,JM,IMN,JMN,lon_c,lat_c,lake_frac,land_frac) implicit none real, parameter :: D2R = 3.14159265358979/180. integer, parameter :: MAXSUM=20000000 @@ -1109,8 +1072,6 @@ END SUBROUTINE MAKEMT2 !! east for each model point. !! @param[out] gamma Anisotropy for each model point. !! @param[out] sigma Slope of orography for each model point. -!! @param[out] glat Latitude of each row of the high-resolution -!! orography and land-mask datasets. !! @param[in] im "i" dimension of the model grid tile. !! @param[in] jm "j" dimension of the model grid tile. !! @param[in] imn "i" dimension of the hi-res input orog/mask datasets. @@ -1120,7 +1081,7 @@ END SUBROUTINE MAKEMT2 !! @param[in] SLM mask !! @author GFDL Programmer SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, - 1 GLAT,IM,JM,IMN,JMN,lon_c,lat_c,SLM) + 1 IM,JM,IMN,JMN,lon_c,lat_c,SLM) C C=== PC: principal coordinates of each Z avg orog box for L&M C @@ -1392,7 +1353,6 @@ end function get_lat_angle !! @param[in] zavg High-resolution orography data. !! @param[in] zslm High-resolution land-mask data. !! @param[in] var Standard deviation of orography on the model grid. -!! @param[out] glat Latitude of each row of input terrain dataset. !! @param[out] oa4 Orographic asymmetry on the model grid. Four !! directional components - W/S/SW/NW !! @param[out] ol Orographic length scale on the model grid. Four @@ -1421,7 +1381,7 @@ end function get_lat_angle !! @param[in] is_south_pole Is the model point at the south pole? !! @param[in] is_north_pole is the model point at the north pole? !! @author GFDL Programmer - SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,GLAT,OA4,OL,IOA4,ELVMAX, + SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, 1 ORO,oro1,XNSUM,XNSUM1,XNSUM2,XNSUM3,XNSUM4, 2 IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t,dx,dy, 3 is_south_pole,is_north_pole ) From 030203f4406f7d31e4c60b00c7bfe2bbf56b89be Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 23 Jul 2024 19:56:55 +0000 Subject: [PATCH 24/54] Move read of RAMP data and the QC of the global data to its own routine. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 99 ++++++++++++------- 1 file changed, 64 insertions(+), 35 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index c0e6f50a0..50236e203 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -107,10 +107,9 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, logical, intent(in) :: mask_only real, parameter :: MISSING_VALUE=-9999. - real, PARAMETER :: PI=3.1415926535897931 integer, PARAMETER :: NMT=14 - integer :: efac,zsave1,zsave2 + integer :: efac integer :: i,j,nx,ny,ncid,js,jn,iw,ie,k,error,id_dim integer :: id_var,fsize,wgta,IN,INW,INE,IS,ISW,ISE integer :: itest,jtest @@ -139,7 +138,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, real, allocatable :: WORK1(:,:),WORK2(:,:),WORK3(:,:),WORK4(:,:) real, allocatable :: WORK5(:,:),WORK6(:,:) real, allocatable :: tmpvar(:,:) - real(4), allocatable:: GICE(:,:) real, allocatable :: OA(:,:,:),OL(:,:,:),HPRIME(:,:,:) @@ -191,40 +189,11 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ZSLM(i,JMN)=1 enddo - allocate (GICE(IMN+1,3601)) - -! Read 30-sec Antarctica RAMP data. Points scan from South -! to North, and from Greenwich to Greenwich. +! Quality control the global topography data over Antarctica +! using RAMP data. - error=NF__OPEN("./topography.antarctica.ramp.30s.nc", - & NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Opening RAMP topo file' ) - error=nf_inq_varid(ncid, 'topo', id_var) - call netcdf_err(error, 'Inquire varid of RAMP topo') - error=nf_get_var_real(ncid, id_var, GICE) - call netcdf_err(error, 'Inquire data of RAMP topo') - error = nf_close(ncid) - - print *,' GICE 30" Antarctica RAMP orog 43201x3601 read OK' - print *,' Processing! ' - print *,' Processing! ' - print *,' Processing! ' - do j = 1, 3601 - do i = 1, IMN - zsave1 = ZAVG(i,j) - zsave2 = ZSLM(i,j) - if( GICE(i,j) .ne. -99. .and. GICE(i,j) .ne. -1.0 ) then - if ( GICE(i,j) .gt. 0.) then - ZAVG(i,j) = int( GICE(i,j) + 0.5 ) -!! --- for GICE values less than or equal to 0 (0, -1, or -99) then -!! --- radar-sat (RAMP) values are not valid and revert back to old orog - ZSLM(i,j) = 1 - endif - endif - enddo - enddo + call qc_orog_by_ramp(imn, jmn, zavg, zslm) - deallocate (GICE) C C COMPUTE MOUNTAIN DATA : ORO SLM VAR (Std Dev) OC C @@ -2577,3 +2546,63 @@ subroutine transpose_mask(imn, jmn, mask) enddo end subroutine transpose_mask + +!> Quality control the global orography and landmask +!! data over Antarctica using RAMP data. +!! +!! @param[in] imn i-dimension of the global data. +!! @param[in] jmn j-dimension of the global data. +!! @param[inout] zavg The global orography data. +!! @param[inout] zslm The global landmask data. +!! @author G. Gayno + subroutine qc_orog_by_ramp(imn, jmn, zavg, zslm) + + implicit none + + include 'netcdf.inc' + + integer, intent(in) :: imn, jmn + integer, intent(inout) :: zavg(imn,jmn) + integer, intent(inout) :: zslm(imn,jmn) + + integer :: i, j, error, ncid, id_var, fsize + + real(4), allocatable :: gice(:,:) + + fsize = 65536 + + allocate (GICE(IMN+1,3601)) + +! Read 30-sec Antarctica RAMP data. Points scan from South +! to North, and from Greenwich to Greenwich. + + print*,"- OPEN/READ RAMP DATA ./topography.antarctica.ramp.30s.nc" + + error=NF__OPEN("./topography.antarctica.ramp.30s.nc", + & NF_NOWRITE,fsize,ncid) + call netcdf_err(error, 'Opening RAMP topo file' ) + error=nf_inq_varid(ncid, 'topo', id_var) + call netcdf_err(error, 'Inquire varid of RAMP topo') + error=nf_get_var_real(ncid, id_var, GICE) + call netcdf_err(error, 'Inquire data of RAMP topo') + error = nf_close(ncid) + + print*,"- QC GLOBAL OROGRAPHY DATA WITH RAMP." + +! If RAMP values are valid, replace the global value with the RAMP +! value. Invalid values are less than or equal to 0 (0, -1, or -99). + + do j = 1, 3601 + do i = 1, IMN + if( GICE(i,j) .ne. -99. .and. GICE(i,j) .ne. -1.0 ) then + if ( GICE(i,j) .gt. 0.) then + ZAVG(i,j) = int( GICE(i,j) + 0.5 ) + ZSLM(i,j) = 1 + endif + endif + enddo + enddo + + deallocate (GICE) + + end subroutine qc_orog_by_ramp From dd3dcc4b79af632bbfb66e8385a2f41ee89c07ae Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 24 Jul 2024 17:07:02 +0000 Subject: [PATCH 25/54] Move read of model grid file to its own routine. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 85 +------------- sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 | 106 ++++++++++++++++++ 2 files changed, 111 insertions(+), 80 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 50236e203..1d1ade19e 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -110,10 +110,9 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, integer, PARAMETER :: NMT=14 integer :: efac - integer :: i,j,nx,ny,ncid,js,jn,iw,ie,k,error,id_dim - integer :: id_var,fsize,wgta,IN,INW,INE,IS,ISW,ISE + integer :: i,j,js,jn,iw,ie,k + integer :: fsize,wgta,IN,INW,INE,IS,ISW,ISE integer :: itest,jtest - integer :: i_south_pole,j_south_pole,i_north_pole,j_north_pole integer, allocatable :: JST(:),JEN(:) @@ -137,11 +136,9 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, real, allocatable :: VAR4(:,:) real, allocatable :: WORK1(:,:),WORK2(:,:),WORK3(:,:),WORK4(:,:) real, allocatable :: WORK5(:,:),WORK6(:,:) - real, allocatable :: tmpvar(:,:) real, allocatable :: OA(:,:,:),OL(:,:,:),HPRIME(:,:,:) - logical :: fexist,opened logical :: is_south_pole(IM,JM), is_north_pole(IM,JM) print *,' In TERSUB' @@ -202,82 +199,10 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, allocate (SLM(IM,JM),ORO(IM,JM),VAR(IM,JM),VAR4(IM,JM)) allocate (land_frac(IM,JM),lake_frac(IM,JM)) -!--- reading grid file. +! Reading grid file. - inquire(file=trim(OUTGRID), exist=fexist) - if(.not. fexist) then - print*, "FATAL ERROR: file "//trim(OUTGRID) - print*, "does not exist." - CALL ERREXIT(4) - endif - do ncid = 103, 512 - inquire( ncid,OPENED=opened ) - if( .NOT.opened )exit - end do - - print*, "outgrid=", trim(outgrid) - error=NF__OPEN(trim(OUTGRID),NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Open file '//trim(OUTGRID) ) - error=nf_inq_dimid(ncid, 'nx', id_dim) - call netcdf_err(error, 'inquire dimension nx from file '// - & trim(OUTGRID) ) - nx = 2*IM - ny = 2*JM - print*, "Read the grid from file "//trim(OUTGRID) - - allocate(tmpvar(nx+1,ny+1)) - - error=nf_inq_varid(ncid, 'x', id_var) - call netcdf_err(error, 'inquire varid of x from file ' - & //trim(OUTGRID) ) - error=nf_get_var_double(ncid, id_var, tmpvar) - call netcdf_err(error, 'inquire data of x from file ' - & //trim(OUTGRID) ) - !--- adjust lontitude to be between 0 and 360. - do j = 1,ny+1; do i = 1,nx+1 - if(tmpvar(i,j) .NE. MISSING_VALUE) then - if(tmpvar(i,j) .GT. 360) tmpvar(i,j) = tmpvar(i,j) - 360 - if(tmpvar(i,j) .LT. 0) tmpvar(i,j) = tmpvar(i,j) + 360 - endif - enddo; enddo - - geolon(1:IM,1:JM) = tmpvar(2:nx:2,2:ny:2) - geolon_c(1:IM+1,1:JM+1) = tmpvar(1:nx+1:2,1:ny+1:2) - - error=nf_inq_varid(ncid, 'y', id_var) - call netcdf_err(error, 'inquire varid of y from file ' - & //trim(OUTGRID) ) - error=nf_get_var_double(ncid, id_var, tmpvar) - call netcdf_err(error, 'inquire data of y from file ' - & //trim(OUTGRID) ) - geolat(1:IM,1:JM) = tmpvar(2:nx:2,2:ny:2) - geolat_c(1:IM+1,1:JM+1) = tmpvar(1:nx+1:2,1:ny+1:2) - - call find_poles(tmpvar, nx, ny, i_north_pole, j_north_pole, - & i_south_pole, j_south_pole) - - deallocate(tmpvar) - - call find_nearest_pole_points(i_north_pole, j_north_pole, - & i_south_pole, j_south_pole, im, jm, is_north_pole, - & is_south_pole) - - allocate(tmpvar(nx,ny)) - error=nf_inq_varid(ncid, 'area', id_var) - call netcdf_err(error, 'inquire varid of area from file ' - & //trim(OUTGRID) ) - error=nf_get_var_double(ncid, id_var, tmpvar) - call netcdf_err(error, 'inquire data of area from file ' - & //trim(OUTGRID) ) - - do j = 1, jm - do i = 1, im - dx(i,j) = sqrt(tmpvar(2*i-1,2*j-1)+tmpvar(2*i,2*j-1) - & +tmpvar(2*i-1,2*j )+tmpvar(2*i,2*j )) - dy(i,j) = dx(i,j) - enddo - enddo - deallocate(tmpvar) + call read_mdl_grid_file(outgrid,im,jm,geolon,geolon_c, + & geolat,geolat_c,dx,dy,is_north_pole,is_south_pole) tend=timef() write(6,*)' Timer 1 time= ',tend-tbeg diff --git a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 index 347957e4d..5c259e912 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 @@ -420,3 +420,109 @@ subroutine read_mdl_dims(mdl_grid_file, im, jm) print*,"- MDL GRID DIMENSIONS ", im, jm end subroutine read_mdl_dims + +!> Read the grid dimensions from the model 'grid' file +!! +!! @param[in] mdl_grid_file Path/name of model 'grid' file. +!! @param[in] im 'i' Dimension of a model grid tile. +!! @param[in] jm 'j' Dimension of a model grid tile. +!! @param[out] geolon Longitude at the grid point centers. +!! @param[out] geolon_c Longitude at the grid point corners. +!! @param[out] geolat Latitude at the grid point centers. +!! @param[out] geolat_c Latitude at the grid point corners. +!! @param[out] dx Length of model grid points in the 'x' direction. +!! @param[out] dy Length of model grid points in the 'y' direction. +!! @param[out] is_north_pole 'true' for points surrounding the north pole. +!! @param[out] is_south_pole 'true' for points surrounding the south pole. +!! @author George Gayno NOAA/EMC + subroutine read_mdl_grid_file(mdl_grid_file, im, jm, & + geolon, geolon_c, geolat, geolat_c, dx, dy, & + is_north_pole, is_south_pole) + + implicit none + include "netcdf.inc" + + character(len=*), intent(in) :: mdl_grid_file + + integer, intent(in) :: im, jm + + logical, intent(out) :: is_north_pole(im,jm) + logical, intent(out) :: is_south_pole(im,jm) + + real, intent(out) :: geolat(im,jm) + real, intent(out) :: geolat_c(im+1,jm+1) + real, intent(out) :: geolon(im,jm) + real, intent(out) :: geolon_c(im+1,jm+1) + real, intent(out) :: dx(im,jm), dy(im,jm) + + integer :: i, j + integer :: ncid, error, fsize, id_var, nx, ny + integer :: i_south_pole,j_south_pole + integer :: i_north_pole,j_north_pole + + real, allocatable :: tmpvar(:,:) + fsize = 66536 + + nx = 2*im + ny = 2*jm + + allocate(tmpvar(nx+1,ny+1)) + + print*, "- OPEN AND READ= ", trim(mdl_grid_file) + + error=NF__OPEN(mdl_grid_file,NF_NOWRITE,fsize,ncid) + call netcdf_err(error, 'Opening file '//trim(mdl_grid_file) ) + + error=nf_inq_varid(ncid, 'x', id_var) + call netcdf_err(error, 'inquire varid of x from file ' // trim(mdl_grid_file)) + error=nf_get_var_double(ncid, id_var, tmpvar) + call netcdf_err(error, 'inquire data of x from file ' // trim(mdl_grid_file)) + +! Adjust lontitude to be between 0 and 360. + do j = 1,ny+1 + do i = 1,nx+1 + if(tmpvar(i,j) .GT. 360) tmpvar(i,j) = tmpvar(i,j) - 360 + if(tmpvar(i,j) .LT. 0) tmpvar(i,j) = tmpvar(i,j) + 360 + enddo + enddo + + geolon(1:IM,1:JM) = tmpvar(2:nx:2,2:ny:2) + geolon_c(1:IM+1,1:JM+1) = tmpvar(1:nx+1:2,1:ny+1:2) + + error=nf_inq_varid(ncid, 'y', id_var) + call netcdf_err(error, 'inquire varid of y from file ' // trim(mdl_grid_file)) + error=nf_get_var_double(ncid, id_var, tmpvar) + call netcdf_err(error, 'inquire data of y from file ' // trim(mdl_grid_file)) + + geolat(1:IM,1:JM) = tmpvar(2:nx:2,2:ny:2) + geolat_c(1:IM+1,1:JM+1) = tmpvar(1:nx+1:2,1:ny+1:2) + + call find_poles(tmpvar, nx, ny, i_north_pole, j_north_pole, & + i_south_pole, j_south_pole) + + deallocate(tmpvar) + + call find_nearest_pole_points(i_north_pole, j_north_pole, & + i_south_pole, j_south_pole, im, jm, is_north_pole, & + is_south_pole) + + allocate(tmpvar(nx,ny)) + + error=nf_inq_varid(ncid, 'area', id_var) + call netcdf_err(error, 'inquire varid of area from file ' // trim(mdl_grid_file)) + error=nf_get_var_double(ncid, id_var, tmpvar) + call netcdf_err(error, 'inquire data of area from file ' // trim(mdl_grid_file)) + + error = nf_close(ncid) + + do j = 1, jm + do i = 1, im + dx(i,j) = sqrt(tmpvar(2*i-1,2*j-1)+tmpvar(2*i,2*j-1) & + + tmpvar(2*i-1,2*j )+tmpvar(2*i,2*j )) + dy(i,j) = dx(i,j) + enddo + enddo + + deallocate(tmpvar) + + end subroutine read_mdl_grid_file From d78a42da2c8c5fffbbff1bcfc99fcd97ea4d8d8e Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 24 Jul 2024 18:43:10 +0000 Subject: [PATCH 26/54] Update argument list for inside_a_polygon to eliminate warnings when running in debug mode. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 28 +++++++++++++------ 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 1d1ade19e..542e39345 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -640,6 +640,7 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, real SLM(IM,JM) real lon_c(IM+1,JM+1), lat_c(IM+1,JM+1) real LONO(4),LATO(4),LONI,LATI + real LONO_RAD(4), LATO_RAD(4) integer JM1,i,j,nsum,nsum_all,ii,jj,numx,i2 integer ilist(IMN) real DELXN,XNSUM,XLAND,XWATR,XL1,XS1,XW1 @@ -666,7 +667,7 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, C (*j*) for hard wired zero offset (lambda s =0) for terr05 !$omp parallel do !$omp* private (j,i,xnsum,xland,xwatr,nsum,xl1,xs1,xw1,lono, -!$omp* lato,jst,jen,ilist,numx,jj,i2,ii,loni,lati, +!$omp* lato,lono_rad,lato_rad,jst,jen,ilist,numx,jj,i2,ii,loni,lati, !$omp* xnsum_all,xland_all,xwatr_all,nsum_all) !$omp* DO J=1,JM @@ -689,6 +690,8 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, LATO(2) = lat_c(i+1,j) LATO(3) = lat_c(i+1,j+1) LATO(4) = lat_c(i,j+1) + LONO_RAD=LONO*D2R + LATO_RAD=LATO*D2R call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) do jj = jst, jen; do i2 = 1, numx ii = ilist(i2) @@ -706,7 +709,7 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, endif if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO*D2R,LATO*D2R))then + & LONO_RAD,LATO_RAD))then XLAND = XLAND + FLOAT(ZSLM(ii,jj)) XWATR = XWATR + FLOAT(1-ZSLM(ii,jj)) @@ -771,6 +774,7 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, integer JST, JEN real lon_c(IM+1,JM+1), lat_c(IM+1,JM+1) real LONO(4),LATO(4),LONI,LATI + real LONO_RAD(4), LATO_RAD(4) real HEIGHT integer JM1,i,j,nsum,nsum_all,ii,jj,i1,numx,i2 integer ilist(IMN) @@ -802,7 +806,7 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, !$omp parallel do !$omp* private (j,i,xnsum,xland,xwatr,nsum,xl1,xs1,xw1,xw2,xw4,lono, !$omp* lato,jst,jen,ilist,numx,jj,i2,ii,loni,lati,height, -!$omp* hgt_1d, +!$omp* lato_rad,lono_rad,hgt_1d, !$omp* xnsum_all,xland_all,xwatr_all,nsum_all, !$omp* xl1_all,xs1_all,xw1_all,xw2_all,xw4_all, !$omp* height_all,hgt_1d_all) @@ -839,6 +843,8 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, LATO(2) = lat_c(i+1,j) LATO(3) = lat_c(i+1,j+1) LATO(4) = lat_c(i,j+1) + LONO_RAD = LONO*D2R + LATO_RAD = LATO*D2R call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) do jj = jst, jen; do i2 = 1, numx ii = ilist(i2) @@ -863,7 +869,7 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, XW2_ALL = XW2_ALL + HEIGHT_ALL ** 2 if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO*D2R,LATO*D2R))then + & LONO_RAD,LATO_RAD))then XLAND = XLAND + FLOAT(ZSLM(ii,jj)) XWATR = XWATR + FLOAT(1-ZSLM(ii,jj)) @@ -994,6 +1000,7 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, real xfp,yfp,xfpyfp,xfp2,yfp2 real hi0,hip1,hj0,hjp1,hijax,hi1j1 real LONO(4),LATO(4),LONI,LATI + real LONO_RAD(4), LATO_RAD(4) integer i,j,i1,j1,i2,jst,jen,numx,i0,ip1,ijax integer ilist(IMN) logical inside_a_polygon @@ -1023,7 +1030,7 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, !$omp* private (j,i,xnsum,xland,xfp,yfp,xfpyfp, !$omp* xfp2,yfp2,lono,lato,jst,jen,ilist,numx,j1,i2,i1, !$omp* loni,lati,i0,ip1,hi0,hip1,hj0,hjp1,ijax, -!$omp* hijax,hi1j1) +!$omp* hijax,hi1j1,lono_rad,lato_rad) JLOOP : DO J=1,JM ! print*, "J=", J ILOOP : DO I=1,IM @@ -1053,6 +1060,8 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, LATO(2) = lat_c(i+1,j) LATO(3) = lat_c(i+1,j+1) LATO(4) = lat_c(i,j+1) + LATO_RAD = LATO *D2R + LONO_RAD = LONO *D2R call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) do j1 = jst, jen; do i2 = 1, numx @@ -1060,7 +1069,7 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, LONI = i1*DELXN LATI = -90 + j1*DELXN INSIDE : if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO*D2R,LATO*D2R))then + & LONO_RAD,LATO_RAD))then C=== set the rest of the indexs for ave: 2pt staggered derivitive C @@ -1299,6 +1308,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, integer i,j,ilist(IMN),numx,i1,j1,ii1 integer KWD real LONO(4),LATO(4),LONI,LATI + real LONO_RAD(4), LATO_RAD(4) real DELXN,HC,HEIGHT,XNPU,XNPD,T integer NS0,NS1,NS2,NS3,NS4,NS5,NS6 logical inside_a_polygon @@ -1343,7 +1353,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, ! --- to JM or to JM1 !$omp parallel do !$omp* private (j,i,hc,lono,lato,jst,jen,ilist,numx,j1,ii1,i1,loni, -!$omp* lati,height) +!$omp* lati,height,lono_rad,lato_rad) DO J=1,JM ! print*, "J=", J DO I=1,IM @@ -1356,13 +1366,15 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, LATO(2) = lat_c(i+1,j) LATO(3) = lat_c(i+1,j+1) LATO(4) = lat_c(i,j+1) + LONO_RAD = LONO * D2R + LATO_RAD = LATO * D2R call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) do j1 = jst, jen; do ii1 = 1, numx i1 = ilist(ii1) LONI = i1*DELXN LATI = -90 + j1*DELXN if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO*D2R,LATO*D2R))then + & LONO_RAD,LATO_RAD))then HEIGHT = FLOAT(ZAVG(I1,J1)) IF(HEIGHT.LT.-990.) HEIGHT = 0.0 From 1b9707bdfd93e9bfaf061a16721731e3bb78bd60 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 24 Jul 2024 20:26:56 +0000 Subject: [PATCH 27/54] General clean up. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 124 ++++++++---------- 1 file changed, 56 insertions(+), 68 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 542e39345..7929080bc 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -106,17 +106,11 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, logical, intent(in) :: mask_only - real, parameter :: MISSING_VALUE=-9999. - integer, PARAMETER :: NMT=14 - integer :: efac integer :: i,j,js,jn,iw,ie,k - integer :: fsize,wgta,IN,INW,INE,IS,ISW,ISE + integer :: wgta,IN,INW,INE,IS,ISW,ISE integer :: itest,jtest - integer, allocatable :: JST(:),JEN(:) - - integer, allocatable :: IST(:,:),IEN(:,:) integer, allocatable :: ZAVG(:,:),ZSLM(:,:) integer(1), allocatable :: UMD(:,:) integer(2), allocatable :: glob(:,:) @@ -145,12 +139,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, tbeg1=timef() tbeg=timef() - fsize = 65536 - allocate (JST(JM),JEN(JM)) - allocate (IST(IM,jm),IEN(IM,jm)) allocate (glob(IMN,JMN)) - allocate (oaa(4),ola(4)) allocate (ZAVG(IMN,JMN)) allocate (ZSLM(IMN,JMN)) allocate (UMD(IMN,JMN)) @@ -173,7 +163,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, do j=1,jmn do i=1,imn - if ( UMD(i,j) .eq. 0 ) ZSLM(i,j) = 0 + if ( UMD(i,j) .eq. 0 ) ZSLM(i,j) = 0 enddo enddo @@ -191,12 +181,9 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, call qc_orog_by_ramp(imn, jmn, zavg, zslm) -C -C COMPUTE MOUNTAIN DATA : ORO SLM VAR (Std Dev) OC -C allocate (GEOLON(IM,JM),GEOLON_C(IM+1,JM+1),DX(IM,JM)) allocate (GEOLAT(IM,JM),GEOLAT_C(IM+1,JM+1),DY(IM,JM)) - allocate (SLM(IM,JM),ORO(IM,JM),VAR(IM,JM),VAR4(IM,JM)) + allocate (SLM(IM,JM)) allocate (land_frac(IM,JM),lake_frac(IM,JM)) ! Reading grid file. @@ -207,59 +194,63 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, tend=timef() write(6,*)' Timer 1 time= ',tend-tbeg ! - tbeg=timef() + tbeg=timef() - IF (MERGE_FILE == 'none') then - CALL MAKE_MASK(ZSLM,SLM,land_frac, - & IM,JM,IMN,JMN,geolon_c,geolat_c) - lake_frac=9999.9 - ELSE - print*,'Read in external mask ',merge_file - CALL READ_MASK(MERGE_FILE,SLM,land_frac,lake_frac,im,jm) - ENDIF + IF (MERGE_FILE == 'none') then + CALL MAKE_MASK(ZSLM,SLM,land_frac, + & IM,JM,IMN,JMN,geolon_c,geolat_c) + lake_frac=9999.9 + ELSE + print*,'- READ IN EXTERNAL LANDMASK FILE: ',trim(merge_file) + CALL READ_MASK(MERGE_FILE,SLM,land_frac,lake_frac,im,jm) + ENDIF + + IF (MASK_ONLY) THEN + print*,'- WILL COMPUTE LANDMASK ONLY.' + CALL WRITE_MASK_NETCDF(IM,JM,SLM,land_frac, + & 1,1,GEOLON,GEOLAT) - IF (MASK_ONLY) THEN - print*,'Computing mask only.' - CALL WRITE_MASK_NETCDF(IM,JM,SLM,land_frac, - 1 1,1,GEOLON,GEOLAT) + DEALLOCATE(ZAVG, ZSLM, SLM, LAND_FRAC, LAKE_FRAC) + DEALLOCATE(GEOLON, GEOLON_C, GEOLAT, GEOLAT_C) + print*,' DONE.' + STOP + END IF - print*,' DONE.' - STOP - END IF + allocate (VAR(IM,JM),VAR4(IM,JM),ORO(IM,JM)) - CALL MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, - & IM,JM,IMN,JMN,geolon_c,geolat_c,lake_frac,land_frac) + CALL MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, + & IM,JM,IMN,JMN,geolon_c,geolat_c,lake_frac,land_frac) tend=timef() write(6,*)' MAKEMT2 time= ',tend-tbeg - call minmxj(IM,JM,ORO,' ORO') - call minmxj(IM,JM,SLM,' SLM') - call minmxj(IM,JM,VAR,' VAR') - call minmxj(IM,JM,VAR4,' VAR4') -C -C === Compute mtn principal coord HTENSR: THETA,GAMMA,SIGMA -C + call minmxj(IM,JM,ORO,' ORO') + call minmxj(IM,JM,SLM,' SLM') + call minmxj(IM,JM,VAR,' VAR') + call minmxj(IM,JM,VAR4,' VAR4') + +! Compute mtn principal coord HTENSR: THETA,GAMMA,SIGMA + allocate (THETA(IM,JM),GAMMA(IM,JM),SIGMA(IM,JM),ELVMAX(IM,JM)) + tbeg=timef() CALL MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, 1 IM,JM,IMN,JMN,geolon_c,geolat_c,SLM) tend=timef() + write(6,*)' MAKEPC2 time= ',tend-tbeg - call minmxj(IM,JM,THETA,' THETA') - call minmxj(IM,JM,GAMMA,' GAMMA') - call minmxj(IM,JM,SIGMA,' SIGMA') -C -C COMPUTE MOUNTAIN DATA : OA OL -C + call minmxj(IM,JM,THETA,' THETA') + call minmxj(IM,JM,GAMMA,' GAMMA') + call minmxj(IM,JM,SIGMA,' SIGMA') + +! COMPUTE MOUNTAIN DATA : OA OL + allocate (IWORK(IM,JM,4)) - allocate (OA(IM,JM,4),OL(IM,JM,4),HPRIME(IM,JM,14)) + allocate (OA(IM,JM,4),OL(IM,JM,4)) allocate (WORK1(IM,JM),WORK2(IM,JM),WORK3(IM,JM),WORK4(IM,JM)) allocate (WORK5(IM,JM),WORK6(IM,JM)) - call minmxj(IM,JM,ORO,' ORO') - print*, "calling MAKEOA2 to compute OA, OL" tbeg=timef() CALL MAKEOA2(ZAVG,zslm,VAR,OA,OL,IWORK,ELVMAX,ORO, @@ -270,7 +261,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, write(6,*)' MAKEOA2 time= ',tend-tbeg ! Deallocate 2d vars - deallocate(IST,IEN) deallocate (ZSLM,ZAVG) deallocate (dx,dy) deallocate (WORK2,WORK3,WORK4,WORK5,WORK6) @@ -297,14 +287,11 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, endif ENDDO ENDDO -c - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') -C -C ZERO OVER OCEAN -C - print *,' Testing at point (itest,jtest)=',itest,jtest - print *,' SLM(itest,jtest)=',slm(itest,jtest),itest,jtest - print *,' ORO(itest,jtest)=',oro(itest,jtest),itest,jtest + + call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') + +! ZERO FIELDS OVER OCEAN + DO J = 1,JM DO I = 1,IM IF(SLM(I,J).EQ.0.) THEN @@ -331,6 +318,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, C IF (MERGE_FILE == 'none') then + allocate (oaa(4),ola(4)) C REMOVE ISOLATED POINTS iso_loop : DO J=2,JM-1 JN=J-1 @@ -434,6 +422,9 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ENDIF ENDDO ENDDO iso_loop + + deallocate (oaa,ola) + C--- print for testing after isolated points removed print *,' after isolated points removed' call minmxj(IM,JM,ORO,' ORO') @@ -458,6 +449,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, endif C + allocate(hprime(im,jm,14)) + DO J=1,JM DO I=1,IM ORO(I,J) = ORO(I,J) + EFAC*VAR(I,J) @@ -504,18 +497,13 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, 1 GEOLON(1:IM,1:JM),GEOLAT(1:IM,1:JM), XLON,XLAT) tend=timef() write(6,*)' WRITE_NETCDF time= ',tend-tbeg - print *,' wrote netcdf file out.oro.tile?.nc' print *,' ===== Deallocate Arrays and ENDING MTN VAR OROG program' -! Deallocate 1d vars - deallocate(JST,JEN) - deallocate(XLAT,XLON,oaa,ola) - -! Deallocate 2d vars + deallocate(XLAT,XLON) deallocate (GEOLON,GEOLON_C,GEOLAT,GEOLAT_C) deallocate (SLM,ORO,VAR,land_frac) - deallocate (THETA,GAMMA,SIGMA,ELVMAX) + deallocate (THETA,GAMMA,SIGMA,ELVMAX,HPRIME) tend=timef() write(6,*)' Total runtime time= ',tend-tbeg1 @@ -1699,8 +1687,8 @@ SUBROUTINE minmxj(IM,JM,A,title) ENDDO ENDDO write(6,150)rmin,rmax,title -150 format('rmin=',e13.4,2x,'rmax=',e13.4,2x,a8,' ') -C +150 format('- MIN=',e13.4,2x,'MAX=',e13.4,2x,a8,' ') + RETURN END SUBROUTINE minmxj From a4d0b303b7e68274cc8450aa3d5cc44f07444171 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Thu, 25 Jul 2024 09:15:40 -0500 Subject: [PATCH 28/54] Move logic that removes isolated model points to its own subroutine. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 254 ++++++++++-------- 1 file changed, 143 insertions(+), 111 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 7929080bc..a6bd8c77e 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -107,8 +107,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, logical, intent(in) :: mask_only integer :: efac - integer :: i,j,js,jn,iw,ie,k - integer :: wgta,IN,INW,INE,IS,ISW,ISE + integer :: i,j integer :: itest,jtest integer, allocatable :: ZAVG(:,:),ZSLM(:,:) @@ -118,10 +117,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, integer, allocatable :: IWORK(:,:,:) real :: timef,tbeg,tend,tbeg1 - real :: slma,oroa,vara,var4a,xn,XS - - real, allocatable :: XLAT(:),XLON(:),oaa(:),ola(:) + real, allocatable :: XLAT(:),XLON(:) real, allocatable :: GEOLON(:,:),GEOLON_C(:,:),DX(:,:) real, allocatable :: GEOLAT(:,:),GEOLAT_C(:,:),DY(:,:) real, allocatable :: SLM(:,:),ORO(:,:),VAR(:,:) @@ -130,7 +127,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, real, allocatable :: VAR4(:,:) real, allocatable :: WORK1(:,:),WORK2(:,:),WORK3(:,:),WORK4(:,:) real, allocatable :: WORK5(:,:),WORK6(:,:) - real, allocatable :: OA(:,:,:),OL(:,:,:),HPRIME(:,:,:) logical :: is_south_pole(IM,JM), is_north_pole(IM,JM) @@ -318,112 +314,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, C IF (MERGE_FILE == 'none') then - allocate (oaa(4),ola(4)) -C REMOVE ISOLATED POINTS - iso_loop : DO J=2,JM-1 - JN=J-1 - JS=J+1 - DO I=1,IM - IW=MOD(I+IM-2,IM)+1 - IE=MOD(I,IM)+1 - SLMA=SLM(IW,J)+SLM(IE,J) - OROA=ORO(IW,J)+ORO(IE,J) - VARA=VAR(IW,J)+VAR(IE,J) - VAR4A=VAR4(IW,J)+VAR4(IE,J) - DO K=1,4 - OAA(K)=OA(IW,J,K)+OA(IE,J,K) -! --- (*j*) fix typo: - OLA(K)=OL(IW,J,K)+OL(IE,J,K) - ENDDO - WGTA=2 - XN=(I-1)+1 - IF(ABS(XN-NINT(XN)).LT.1.E-2) THEN - IN=MOD(NINT(XN)-1,IM)+1 - INW=MOD(IN+IM-2,IM)+1 - INE=MOD(IN,IM)+1 - SLMA=SLMA+SLM(INW,JN)+SLM(IN,JN)+SLM(INE,JN) - OROA=OROA+ORO(INW,JN)+ORO(IN,JN)+ORO(INE,JN) - VARA=VARA+VAR(INW,JN)+VAR(IN,JN)+VAR(INE,JN) - VAR4A=VAR4A+VAR4(INW,JN)+VAR4(IN,JN)+VAR4(INE,JN) - DO K=1,4 - OAA(K)=OAA(K)+OA(INW,JN,K)+OA(IN,JN,K)+OA(INE,JN,K) - OLA(K)=OLA(K)+OL(INW,JN,K)+OL(IN,JN,K)+OL(INE,JN,K) - ENDDO - WGTA=WGTA+3 - ELSE - INW=INT(XN) - INE=MOD(INW,IM)+1 - SLMA=SLMA+SLM(INW,JN)+SLM(INE,JN) - OROA=OROA+ORO(INW,JN)+ORO(INE,JN) - VARA=VARA+VAR(INW,JN)+VAR(INE,JN) - VAR4A=VAR4A+VAR4(INW,JN)+VAR4(INE,JN) - DO K=1,4 - OAA(K)=OAA(K)+OA(INW,JN,K)+OA(INE,JN,K) - OLA(K)=OLA(K)+OL(INW,JN,K)+OL(INE,JN,K) - ENDDO - WGTA=WGTA+2 - ENDIF - XS=(I-1)+1 - IF(ABS(XS-NINT(XS)).LT.1.E-2) THEN - IS=MOD(NINT(XS)-1,IM)+1 - ISW=MOD(IS+IM-2,IM)+1 - ISE=MOD(IS,IM)+1 - SLMA=SLMA+SLM(ISW,JS)+SLM(IS,JS)+SLM(ISE,JS) - OROA=OROA+ORO(ISW,JS)+ORO(IS,JS)+ORO(ISE,JS) - VARA=VARA+VAR(ISW,JS)+VAR(IS,JS)+VAR(ISE,JS) - VAR4A=VAR4A+VAR4(ISW,JS)+VAR4(IS,JS)+VAR4(ISE,JS) - DO K=1,4 - OAA(K)=OAA(K)+OA(ISW,JS,K)+OA(IS,JS,K)+OA(ISE,JS,K) - OLA(K)=OLA(K)+OL(ISW,JS,K)+OL(IS,JS,K)+OL(ISE,JS,K) - ENDDO - WGTA=WGTA+3 - ELSE - ISW=INT(XS) - ISE=MOD(ISW,IM)+1 - SLMA=SLMA+SLM(ISW,JS)+SLM(ISE,JS) - OROA=OROA+ORO(ISW,JS)+ORO(ISE,JS) - VARA=VARA+VAR(ISW,JS)+VAR(ISE,JS) - VAR4A=VAR4A+VAR4(ISW,JS)+VAR4(ISE,JS) - DO K=1,4 - OAA(K)=OAA(K)+OA(ISW,JS,K)+OA(ISE,JS,K) - OLA(K)=OLA(K)+OL(ISW,JS,K)+OL(ISE,JS,K) - ENDDO - WGTA=WGTA+2 - ENDIF - OROA=OROA/WGTA - VARA=VARA/WGTA - VAR4A=VAR4A/WGTA - DO K=1,4 - OAA(K)=OAA(K)/WGTA - OLA(K)=OLA(K)/WGTA - ENDDO - IF(SLM(I,J).EQ.0..AND.SLMA.EQ.WGTA) THEN - PRINT '("SEA ",2F8.0," MODIFIED TO LAND",2F8.0," AT ",2I8)', - & ORO(I,J),VAR(I,J),OROA,VARA,I,J - SLM(I,J)=1. - ORO(I,J)=OROA - VAR(I,J)=VARA - VAR4(I,J)=VAR4A - DO K=1,4 - OA(I,J,K)=OAA(K) - OL(I,J,K)=OLA(K) - ENDDO - ELSEIF(SLM(I,J).EQ.1..AND.SLMA.EQ.0.) THEN - PRINT '("LAND",2F8.0," MODIFIED TO SEA ",2F8.0," AT ",2I8)', - & ORO(I,J),VAR(I,J),OROA,VARA,I,J - SLM(I,J)=0. - ORO(I,J)=OROA - VAR(I,J)=VARA - VAR4(I,J)=VAR4A - DO K=1,4 - OA(I,J,K)=OAA(K) - OL(I,J,K)=OLA(K) - ENDDO - ENDIF - ENDDO - ENDDO iso_loop - deallocate (oaa,ola) + call remove_isolated_pts(im,jm,slm,oro,var,var4,oa,ol) C--- print for testing after isolated points removed print *,' after isolated points removed' @@ -2531,3 +2423,143 @@ subroutine qc_orog_by_ramp(imn, jmn, zavg, zslm) deallocate (GICE) end subroutine qc_orog_by_ramp + +!> Remove isolated model points. +!! +!! @param[in] im 'i' dimension of a model grid tile. +!! @param[in] jm 'j' dimension of a model grid tile. +!! @param[inout] slm Land-mask on the model tile. +!! @param[inout] oro Orography on the model tile. +!! @param[inout] var Standard deviation of orography on the model tile. +!! @param[inout] var4 Convexity on the model tile. +!! @param[inout] oa Orographic asymmetry on the model tile. +!! @param[inout] ol Orographic length scale on the model tile. +!! @author Jordan Alpert NOAA/EMC + subroutine remove_isolated_pts(im,jm,slm,oro,var,var4,oa,ol) + + implicit none + + integer, intent(in) :: im, jm + + real, intent(inout) :: slm(im,jm) + real, intent(inout) :: oro(im,jm) + real, intent(inout) :: var(im,jm) + real, intent(inout) :: var4(im,jm) + real, intent(inout) :: oa(im,jm,4) + real, intent(inout) :: ol(im,jm,4) + + integer :: i, j, jn, js, k + integer :: iw, ie, wgta, is, ise + integer :: in, ine, inw, isw + + real :: slma, oroa, vara, var4a, xn, xs + real, allocatable :: oaa(:), ola(:) + + allocate (oaa(4),ola(4)) + +C REMOVE ISOLATED POINTS + iso_loop : DO J=2,JM-1 + JN=J-1 + JS=J+1 + DO I=1,IM + IW=MOD(I+IM-2,IM)+1 + IE=MOD(I,IM)+1 + SLMA=SLM(IW,J)+SLM(IE,J) + OROA=ORO(IW,J)+ORO(IE,J) + VARA=VAR(IW,J)+VAR(IE,J) + VAR4A=VAR4(IW,J)+VAR4(IE,J) + DO K=1,4 + OAA(K)=OA(IW,J,K)+OA(IE,J,K) +! --- (*j*) fix typo: + OLA(K)=OL(IW,J,K)+OL(IE,J,K) + ENDDO + WGTA=2 + XN=(I-1)+1 + IF(ABS(XN-NINT(XN)).LT.1.E-2) THEN + IN=MOD(NINT(XN)-1,IM)+1 + INW=MOD(IN+IM-2,IM)+1 + INE=MOD(IN,IM)+1 + SLMA=SLMA+SLM(INW,JN)+SLM(IN,JN)+SLM(INE,JN) + OROA=OROA+ORO(INW,JN)+ORO(IN,JN)+ORO(INE,JN) + VARA=VARA+VAR(INW,JN)+VAR(IN,JN)+VAR(INE,JN) + VAR4A=VAR4A+VAR4(INW,JN)+VAR4(IN,JN)+VAR4(INE,JN) + DO K=1,4 + OAA(K)=OAA(K)+OA(INW,JN,K)+OA(IN,JN,K)+OA(INE,JN,K) + OLA(K)=OLA(K)+OL(INW,JN,K)+OL(IN,JN,K)+OL(INE,JN,K) + ENDDO + WGTA=WGTA+3 + ELSE + INW=INT(XN) + INE=MOD(INW,IM)+1 + SLMA=SLMA+SLM(INW,JN)+SLM(INE,JN) + OROA=OROA+ORO(INW,JN)+ORO(INE,JN) + VARA=VARA+VAR(INW,JN)+VAR(INE,JN) + VAR4A=VAR4A+VAR4(INW,JN)+VAR4(INE,JN) + DO K=1,4 + OAA(K)=OAA(K)+OA(INW,JN,K)+OA(INE,JN,K) + OLA(K)=OLA(K)+OL(INW,JN,K)+OL(INE,JN,K) + ENDDO + WGTA=WGTA+2 + ENDIF + XS=(I-1)+1 + IF(ABS(XS-NINT(XS)).LT.1.E-2) THEN + IS=MOD(NINT(XS)-1,IM)+1 + ISW=MOD(IS+IM-2,IM)+1 + ISE=MOD(IS,IM)+1 + SLMA=SLMA+SLM(ISW,JS)+SLM(IS,JS)+SLM(ISE,JS) + OROA=OROA+ORO(ISW,JS)+ORO(IS,JS)+ORO(ISE,JS) + VARA=VARA+VAR(ISW,JS)+VAR(IS,JS)+VAR(ISE,JS) + VAR4A=VAR4A+VAR4(ISW,JS)+VAR4(IS,JS)+VAR4(ISE,JS) + DO K=1,4 + OAA(K)=OAA(K)+OA(ISW,JS,K)+OA(IS,JS,K)+OA(ISE,JS,K) + OLA(K)=OLA(K)+OL(ISW,JS,K)+OL(IS,JS,K)+OL(ISE,JS,K) + ENDDO + WGTA=WGTA+3 + ELSE + ISW=INT(XS) + ISE=MOD(ISW,IM)+1 + SLMA=SLMA+SLM(ISW,JS)+SLM(ISE,JS) + OROA=OROA+ORO(ISW,JS)+ORO(ISE,JS) + VARA=VARA+VAR(ISW,JS)+VAR(ISE,JS) + VAR4A=VAR4A+VAR4(ISW,JS)+VAR4(ISE,JS) + DO K=1,4 + OAA(K)=OAA(K)+OA(ISW,JS,K)+OA(ISE,JS,K) + OLA(K)=OLA(K)+OL(ISW,JS,K)+OL(ISE,JS,K) + ENDDO + WGTA=WGTA+2 + ENDIF + OROA=OROA/WGTA + VARA=VARA/WGTA + VAR4A=VAR4A/WGTA + DO K=1,4 + OAA(K)=OAA(K)/WGTA + OLA(K)=OLA(K)/WGTA + ENDDO + IF(SLM(I,J).EQ.0..AND.SLMA.EQ.WGTA) THEN + PRINT '("SEA ",2F8.0," MODIFIED TO LAND",2F8.0," AT ",2I8)', + & ORO(I,J),VAR(I,J),OROA,VARA,I,J + SLM(I,J)=1. + ORO(I,J)=OROA + VAR(I,J)=VARA + VAR4(I,J)=VAR4A + DO K=1,4 + OA(I,J,K)=OAA(K) + OL(I,J,K)=OLA(K) + ENDDO + ELSEIF(SLM(I,J).EQ.1..AND.SLMA.EQ.0.) THEN + PRINT '("LAND",2F8.0," MODIFIED TO SEA ",2F8.0," AT ",2I8)', + & ORO(I,J),VAR(I,J),OROA,VARA,I,J + SLM(I,J)=0. + ORO(I,J)=OROA + VAR(I,J)=VARA + VAR4(I,J)=VAR4A + DO K=1,4 + OA(I,J,K)=OAA(K) + OL(I,J,K)=OLA(K) + ENDDO + ENDIF + ENDDO + ENDDO iso_loop + + deallocate (oaa,ola) + end subroutine remove_isolated_pts From 083657360bd78a9a1ed6f027c403351fc2b2cb39 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Thu, 25 Jul 2024 13:45:39 -0500 Subject: [PATCH 29/54] Clean up print statements and general clean up. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 166 ++++++++---------- 1 file changed, 75 insertions(+), 91 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index a6bd8c77e..8be5a1ee3 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -58,28 +58,40 @@ C> C> @return 0 for success, error code otherwise. implicit none - integer imn, jmn - character(len=256) :: MDL_GRID_FILE = "none" - character(len=256) :: merge_file = "none" - logical :: mask_only = .false. - integer :: IM,JM,EFAC - READ(5,*) MDL_GRID_FILE - READ(5,*) mask_only - READ(5,*) merge_file - EFAC=0 - print*, "MASK_ONLY", mask_only - print*, "MERGE_FILE ", trim(merge_file) - print*, EFAC - IMN = 360*120 - JMN = 180*120 - print *, ' Starting terr12 mtnlm7_slm30.f IMN,JMN:',IMN,JMN + + character(len=256) :: mdl_grid_file = "none" + character(len=256) :: merge_file = "none" + integer :: imn, jmn, im, jm, efac + logical :: mask_only = .false. + + print*,"- BEGIN OROGRAPHY PROGRAM." + + read(5,*) mdl_grid_file + read(5,*) mask_only + read(5,*) merge_file + + efac = 0 + imn = 360*120 + jmn = 180*120 + + if (mask_only) then + print*,"- WILL COMPUTE LANDMASK ONLY." + endif + + if (trim(merge_file) /= "none") then + print*,"- WILL USE EXTERNAL LANDMASK FROM FILE: ", + & trim(merge_file) + endif call read_mdl_dims(mdl_grid_file, im, jm) - CALL TERSUB(IMN,JMN,IM,JM,EFAC, - & MDL_GRID_FILE,MASK_ONLY,MERGE_FILE) - STOP - END + call tersub(imn,jmn,im,jm,efac, + & mdl_grid_file,mask_only,merge_file) + + print*,"- NORMAL TERMINATION." + + stop + end !> Driver routine to compute terrain. !! @@ -131,8 +143,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, logical :: is_south_pole(IM,JM), is_north_pole(IM,JM) - print *,' In TERSUB' - tbeg1=timef() tbeg=timef() @@ -188,7 +198,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, & geolat,geolat_c,dx,dy,is_north_pole,is_south_pole) tend=timef() - write(6,*)' Timer 1 time= ',tend-tbeg + print*,"- TIMING: READING INPUT DATA ",tend-tbeg ! tbeg=timef() @@ -208,7 +218,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, DEALLOCATE(ZAVG, ZSLM, SLM, LAND_FRAC, LAKE_FRAC) DEALLOCATE(GEOLON, GEOLON_C, GEOLAT, GEOLAT_C) - print*,' DONE.' + print*,' NORMAL TERMINATION.' STOP END IF @@ -218,12 +228,12 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, & IM,JM,IMN,JMN,geolon_c,geolat_c,lake_frac,land_frac) tend=timef() - write(6,*)' MAKEMT2 time= ',tend-tbeg + print*,"- TIMING: MASK AND OROG CREATION ", tend-tbeg - call minmxj(IM,JM,ORO,' ORO') - call minmxj(IM,JM,SLM,' SLM') - call minmxj(IM,JM,VAR,' VAR') - call minmxj(IM,JM,VAR4,' VAR4') + call minmxj(IM,JM,ORO,'ORO ') + call minmxj(IM,JM,SLM,'SLM ') + call minmxj(IM,JM,VAR,'VAR ') + call minmxj(IM,JM,VAR4,'VAR4 ') ! Compute mtn principal coord HTENSR: THETA,GAMMA,SIGMA @@ -234,11 +244,11 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, 1 IM,JM,IMN,JMN,geolon_c,geolat_c,SLM) tend=timef() - write(6,*)' MAKEPC2 time= ',tend-tbeg + print*,"- TIMING: CREATE PRINCIPLE COORDINATE ",tend-tbeg - call minmxj(IM,JM,THETA,' THETA') - call minmxj(IM,JM,GAMMA,' GAMMA') - call minmxj(IM,JM,SIGMA,' SIGMA') + call minmxj(IM,JM,THETA,'THETA ') + call minmxj(IM,JM,GAMMA,'GAMMA ') + call minmxj(IM,JM,SIGMA,'SIGMA ') ! COMPUTE MOUNTAIN DATA : OA OL @@ -247,14 +257,14 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, allocate (WORK1(IM,JM),WORK2(IM,JM),WORK3(IM,JM),WORK4(IM,JM)) allocate (WORK5(IM,JM),WORK6(IM,JM)) - print*, "calling MAKEOA2 to compute OA, OL" tbeg=timef() CALL MAKEOA2(ZAVG,zslm,VAR,OA,OL,IWORK,ELVMAX,ORO, 1 WORK1,WORK2,WORK3,WORK4,WORK5,WORK6, 2 IM,JM,IMN,JMN,geolon_c,geolat_c, 3 geolon,geolat,dx,dy,is_south_pole,is_north_pole) tend=timef() - write(6,*)' MAKEOA2 time= ',tend-tbeg + + print*,"- TIMING: CREATE ASYMETRY AND LENGTH SCALE ",tend-tbeg ! Deallocate 2d vars deallocate (ZSLM,ZAVG) @@ -265,10 +275,10 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, deallocate(IWORK) tbeg=timef() - call minmxj(IM,JM,OA,' OA') - call minmxj(IM,JM,OL,' OL') - call minmxj(IM,JM,ELVMAX,' ELVMAX') - call minmxj(IM,JM,ORO,' ORO') + call minmxj(IM,JM,OA,'OA ') + call minmxj(IM,JM,OL,'OL ') + call minmxj(IM,JM,ELVMAX,'ELVMAX ') + call minmxj(IM,JM,ORO,'ORO ') print *,' ===> Replacing ELVMAX with ELVMAX-ORO <=== ' print *,' ===> if ELVMAX<=ORO replace with proxy <=== ' @@ -284,7 +294,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ENDDO ENDDO - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') + call mnmxja(IM,JM,ELVMAX,itest,jtest,'ELVMAX ') ! ZERO FIELDS OVER OCEAN @@ -311,36 +321,13 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ENDIF ENDDO ENDDO -C + IF (MERGE_FILE == 'none') then - - call remove_isolated_pts(im,jm,slm,oro,var,var4,oa,ol) - -C--- print for testing after isolated points removed - print *,' after isolated points removed' - call minmxj(IM,JM,ORO,' ORO') - print *,' ORO(itest,jtest)=',oro(itest,jtest) - print *,' VAR(itest,jtest)=',var(itest,jtest) - print *,' VAR4(itest,jtest)=',var4(itest,jtest) - print *,' OA(itest,jtest,1)=',oa(itest,jtest,1) - print *,' OA(itest,jtest,2)=',oa(itest,jtest,2) - print *,' OA(itest,jtest,3)=',oa(itest,jtest,3) - print *,' OA(itest,jtest,4)=',oa(itest,jtest,4) - print *,' OL(itest,jtest,1)=',ol(itest,jtest,1) - print *,' OL(itest,jtest,2)=',ol(itest,jtest,2) - print *,' OL(itest,jtest,3)=',ol(itest,jtest,3) - print *,' OL(itest,jtest,4)=',ol(itest,jtest,4) - print *,' Testing at point (itest,jtest)=',itest,jtest - print *,' THETA(itest,jtest)=',theta(itest,jtest) - print *,' GAMMA(itest,jtest)=',GAMMA(itest,jtest) - print *,' SIGMA(itest,jtest)=',SIGMA(itest,jtest) - print *,' ELVMAX(itest,jtest)=',ELVMAX(itest,jtest) - print *,' EFAC=',EFAC + call remove_isolated_pts(im,jm,slm,oro,var,var4,oa,ol) endif -C allocate(hprime(im,jm,14)) DO J=1,JM @@ -362,19 +349,19 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, HPRIME(I,J,14)= ELVMAX(I,J) ENDDO ENDDO -! + deallocate(VAR4) deallocate (WORK1) - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') - call minmxj(IM,JM,ORO,' ORO') + call mnmxja(IM,JM,ELVMAX,itest,jtest,'ELVMAX ') + call minmxj(IM,JM,ORO,'ORO ') print *,' ORO(itest,jtest),itest,jtest:', & ORO(itest,jtest),itest,jtest print *,' ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) tend=timef() - write(6,*)' Timer 5 time= ',tend-tbeg + print*,"- TIMING: FINAL QUALITY CONTROL ", tend-tbeg allocate(xlat(jm), xlon(im)) do j = 1, jm @@ -388,7 +375,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, CALL WRITE_NETCDF(IM,JM,SLM,land_frac,ORO,HPRIME,1,1, 1 GEOLON(1:IM,1:JM),GEOLAT(1:IM,1:JM), XLON,XLAT) tend=timef() - write(6,*)' WRITE_NETCDF time= ',tend-tbeg + print*,"- TIMING: WRITE OUTPUT FILE ", tend-tbeg print *,' ===== Deallocate Arrays and ENDING MTN VAR OROG program' @@ -398,8 +385,9 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, deallocate (THETA,GAMMA,SIGMA,ELVMAX,HPRIME) tend=timef() - write(6,*)' Total runtime time= ',tend-tbeg1 - RETURN + print*,"- TIMING: TOTAL RUNTIME ", tend-tbeg1 + + return END SUBROUTINE TERSUB !> Determine the location of a cubed-sphere point within @@ -527,7 +515,7 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, real XNSUM_ALL,XLAND_ALL,XWATR_ALL logical inside_a_polygon C - print *,' _____ SUBROUTINE MAKE_MASK ' + print *,'- CREATE LANDMASK AND LAND FRACTION.' C---- GLOBAL XLAT AND XLON ( DEGREE ) C JM1 = JM - 1 @@ -617,13 +605,11 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, ENDDO ENDDO !$omp end parallel do - WRITE(6,*) "! MAKE_MASK DONE" -C + RETURN END SUBROUTINE MAKE_MASK -!> Create the orography, land-mask, land fraction, standard -!! deviation of orography and the convexity on a model -!! cubed-sphere tile. This routine is used for the FV3GFS model. +!> Create the orography, standard deviation of orography +!! and the convexity on a model tile. !! !! @param[in] zavg The high-resolution input orography dataset. !! @param[in] zslm The high-resolution input land-mask dataset. @@ -663,7 +649,7 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, real XL1_ALL,XS1_ALL,XW1_ALL,XW2_ALL,XW4_ALL logical inside_a_polygon C - print *,' _____ SUBROUTINE MAKEMT2 ' + print*,'- CREATE OROGRAPHY AND CONVEXITY.' allocate(hgt_1d(MAXSUM)) allocate(hgt_1d_all(MAXSUM)) C---- GLOBAL XLAT AND XLON ( DEGREE ) @@ -835,8 +821,7 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, ENDDO ENDDO !$omp end parallel do - WRITE(6,*) "! MAKEMT2 ORO SLM VAR VAR4 DONE" -C + deallocate(hgt_1d) deallocate(hgt_1d_all) RETURN @@ -888,13 +873,13 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, C=== DATA DEBUG/.TRUE./ DATA DEBUG/.FALSE./ C + print*,"- CREATE PRINCIPLE COORDINATES." PI = 4.0 * ATAN(1.0) CERTH = PI * REARTH C---- GLOBAL XLAT AND XLON ( DEGREE ) C DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION DELTAY = CERTH / FLOAT(JMN) - print *, 'MAKEPC2: DELTAY=',DELTAY C DO J=1,JMN GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 @@ -1085,8 +1070,7 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, ENDDO ILOOP ENDDO JLOOP !$omp end parallel do - WRITE(6,*) "! MAKE Principal Coord DONE" -C + RETURN END SUBROUTINE MAKEPC2 @@ -1200,6 +1184,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, real xnsum2_11,xnsum2_12,xnsum2_21,xnsum2_22 real get_lon_angle, get_lat_angle, get_xnsum integer jst, jen + + print*,"- CREATE ASYMETRY AND LENGTH SCALE." C C---- GLOBAL XLAT AND XLON ( DEGREE ) C @@ -1208,7 +1194,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, DO J=1,JMN GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 ENDDO - print *,' IM=',IM,' JM=',JM,' IMN=',IMN,' JMN=',JMN + print*,'- IM=',IM,' JM=',JM,' IMN=',IMN,' JMN=',JMN C C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX C @@ -1545,9 +1531,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, ENDDO ENDDO ENDDO -C - WRITE(6,*) "! MAKEOA2 EXIT" -C + RETURN END SUBROUTINE MAKEOA2 @@ -1578,8 +1562,8 @@ SUBROUTINE minmxj(IM,JM,A,title) if(A(i,j).le.rmin)rmin=A(i,j) ENDDO ENDDO - write(6,150)rmin,rmax,title -150 format('- MIN=',e13.4,2x,'MAX=',e13.4,2x,a8,' ') + write(6,150) title,rmin,rmax +150 format(' - ',a8,' MIN=',e13.4,2x,'MAX=',e13.4) RETURN END SUBROUTINE minmxj @@ -1617,8 +1601,8 @@ SUBROUTINE mnmxja(IM,JM,A,imax,jmax,title) if(A(i,j).le.rmin)rmin=A(i,j) ENDDO ENDDO - write(6,150)rmin,rmax,title -150 format('rmin=',e13.4,2x,'rmax=',e13.4,2x,a8,' ') + write(6,150) title,rmin,rmax +150 format(' - ',a8,' MIN=',e13.4,2x,'MAX=',e13.4) C RETURN END SUBROUTINE mnmxja From e2681c105b16a9e11aab62724cabe640c11a0591 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 26 Jul 2024 10:14:56 -0500 Subject: [PATCH 30/54] Standardize print statements. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 83 +++++++++---------- sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 | 13 +-- 2 files changed, 41 insertions(+), 55 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 8be5a1ee3..4275d4908 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -207,7 +207,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, & IM,JM,IMN,JMN,geolon_c,geolat_c) lake_frac=9999.9 ELSE - print*,'- READ IN EXTERNAL LANDMASK FILE: ',trim(merge_file) CALL READ_MASK(MERGE_FILE,SLM,land_frac,lake_frac,im,jm) ENDIF @@ -218,7 +217,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, DEALLOCATE(ZAVG, ZSLM, SLM, LAND_FRAC, LAKE_FRAC) DEALLOCATE(GEOLON, GEOLON_C, GEOLAT, GEOLAT_C) - print*,' NORMAL TERMINATION.' + print*,'- NORMAL TERMINATION.' STOP END IF @@ -280,23 +279,24 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, call minmxj(IM,JM,ELVMAX,'ELVMAX ') call minmxj(IM,JM,ORO,'ORO ') - print *,' ===> Replacing ELVMAX with ELVMAX-ORO <=== ' - print *,' ===> if ELVMAX<=ORO replace with proxy <=== ' - print *,' ===> the sum of mean orog (ORO) and std dev <=== ' +! Replace maximum elevation with max elevation minus orography. +! If maximum elevation is less than the orography, replace with +! a proxy. + + print*,"- QC MAXIMUM ELEVATION." DO J = 1,JM DO I = 1,IM if (ELVMAX(I,J) .lt. ORO(I,J) ) then -C--- subtracting off ORO leaves std dev (this should never happen) - ELVMAX(I,J) = MAX( 3. * VAR(I,J),0.) + ELVMAX(I,J) = MAX( 3. * VAR(I,J),0.) else - ELVMAX(I,J) = MAX( ELVMAX(I,J) - ORO(I,J),0.) + ELVMAX(I,J) = MAX( ELVMAX(I,J) - ORO(I,J),0.) endif ENDDO ENDDO call mnmxja(IM,JM,ELVMAX,itest,jtest,'ELVMAX ') -! ZERO FIELDS OVER OCEAN + print*,"- ZERO FIELDS OVER OCEAN." DO J = 1,JM DO I = 1,IM @@ -356,9 +356,9 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, call mnmxja(IM,JM,ELVMAX,itest,jtest,'ELVMAX ') call minmxj(IM,JM,ORO,'ORO ') - print *,' ORO(itest,jtest),itest,jtest:', + print *,'- ORO(itest,jtest),itest,jtest:', & ORO(itest,jtest),itest,jtest - print *,' ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) + print *,'- ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) tend=timef() print*,"- TIMING: FINAL QUALITY CONTROL ", tend-tbeg @@ -377,8 +377,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, tend=timef() print*,"- TIMING: WRITE OUTPUT FILE ", tend-tbeg - print *,' ===== Deallocate Arrays and ENDING MTN VAR OROG program' - deallocate(XLAT,XLON) deallocate (GEOLON,GEOLON_C,GEOLAT,GEOLAT_C) deallocate (SLM,ORO,VAR,land_frac) @@ -450,7 +448,9 @@ SUBROUTINE get_index(IMN,JMN,npts,lonO,latO,DELXN, ien = IMN+1 do i2 = 1, npts ii = LONO(i2)/DELXN+1 - if(ii <0 .or. ii>IMN) print*,"ii=",ii,IMN,LONO(i2),DELXN + if(ii <0 .or. ii>IMN) then + print*,"- II=",ii,IMN,LONO(i2),DELXN + endif if( ii < IMN/2 ) then ist = max(ist,ii) else if( ii > IMN/2 ) then @@ -539,7 +539,6 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, !$omp* xnsum_all,xland_all,xwatr_all,nsum_all) !$omp* DO J=1,JM -! print*, "J=", J DO I=1,IM XNSUM = 0.0 XLAND = 0.0 @@ -677,7 +676,6 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, !$omp* xl1_all,xs1_all,xw1_all,xw2_all,xw4_all, !$omp* height_all,hgt_1d_all) DO J=1,JM -! print*, "J=", J DO I=1,IM ORO(I,J) = 0.0 VAR(I,J) = 0.0 @@ -897,7 +895,6 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, !$omp* loni,lati,i0,ip1,hi0,hip1,hj0,hjp1,ijax, !$omp* hijax,hi1j1,lono_rad,lato_rad) JLOOP : DO J=1,JM -! print*, "J=", J ILOOP : DO I=1,IM HX2(I,J) = 0.0 HY2(I,J) = 0.0 @@ -989,7 +986,6 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, C C === the SH pole: NB J1 goes from High at NP to Low toward SP C -!RAB elseif ( J1 .eq. JEN(JM) ) then elseif ( J1 .eq. JMN ) then ijax = i1 + imn/2 if (ijax .le. 0 ) ijax = ijax + imn @@ -998,8 +994,6 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, hi1j1 = float(zavg(i1,j1)) if(hijax .lt. -990.) hijax = 0.0 if(hi1j1 .lt. -990.) hi1j1 = 0.0 - if ( i1 .lt. 5 )print *,' S.Pole i1,j1 :',i1,j1, - & hijax,hi1j1 C..... yfp = yfp + 0.5 * (0.5 * ( hijax - hi1j1) )/DELTAY yfp = 0.5 * (0.5 * ( hijax - hi1j1) )/DELTAY yfp2 = yfp2 + 0.25 * ( (0.5 * (hijax - hi1j1) ) @@ -1221,7 +1215,6 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, !$omp* private (j,i,hc,lono,lato,jst,jen,ilist,numx,j1,ii1,i1,loni, !$omp* lati,height,lono_rad,lato_rad) DO J=1,JM -! print*, "J=", J DO I=1,IM HC = 1116.2 - 0.878 * VAR(I,J) LONO(1) = lon_c(i,j) @@ -1287,20 +1280,19 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, !$omp* hc_12,xnsum1_21,xnsum2_21,hc_21, xnsum1_22, !$omp* xnsum2_22,hc_22) DO J=1,JM -! print*, "j = ", j DO I=1,IM lon = lon_t(i,j) lat = lat_t(i,j) !--- for around north pole, oa and ol are all 0 if(is_north_pole(i,j)) then - print*, "set oa1 = 0 and ol=0 at i,j=", i,j + print*, "- SET OA1 = 0 AND OL=0 AT I,J=", i,j do kwd = 1, 4 oa4(i,j,kwd) = 0. ol(i,j,kwd) = 0. enddo else if(is_south_pole(i,j)) then - print*, "set oa1 = 0 and ol=1 at i,j=", i,j + print*, "- SET OA1 = 0 AND OL=1 AT I,J=", i,j do kwd = 1, 4 oa4(i,j,kwd) = 0. ol(i,j,kwd) = 1. @@ -1312,15 +1304,15 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, dlat = get_lat_angle(dy(i,j), R2D) !--- adjust dlat if the points are close to pole. if( lat-dlat*0.5<-90.) then - print*, "at i,j =", i,j, lat, dlat, lat-dlat*0.5 + print*, "- AT I,J =", i,j, lat, dlat, lat-dlat*0.5 print*, "FATAL ERROR: lat-dlat*0.5<-90." call ERREXIT(4) endif if( lat+dlat*2 > 90.) then dlat_old = dlat dlat = (90-lat)*0.5 - print*, "at i,j=",i,j," adjust dlat from ", - & dlat_old, " to ", dlat + print*, "- AT I,J=",i,j," ADJUST DLAT FROM ", + & dlat_old, " TO ", dlat endif !--- lower left lon1 = lon-dlon*1.5 @@ -1329,7 +1321,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, lat2 = lat+dlat*0.5 if(lat1<-90 .or. lat2>90) then - print*, "at upper left i=,j=", i, j, lat, dlat,lat1,lat2 + print*, "- AT UPPER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 endif xnsum11 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & zavg,zslm,delxn) @@ -1340,7 +1332,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, lat1 = lat+dlat*0.5 lat2 = lat+dlat*1.5 if(lat1<-90 .or. lat2>90) then - print*, "at lower left i=,j=", i, j, lat, dlat,lat1,lat2 + print*, "- AT LOWER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 endif xnsum12 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & zavg,zslm,delxn) @@ -1351,7 +1343,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, lat1 = lat-dlat*0.5 lat2 = lat+dlat*0.5 if(lat1<-90 .or. lat2>90) then - print*, "at upper right i=,j=", i, j, lat, dlat,lat1,lat2 + print*, "- AT UPPER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 endif xnsum21 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & zavg,zslm,delxn) @@ -1362,7 +1354,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, lat1 = lat+dlat*0.5 lat2 = lat+dlat*1.5 if(lat1<-90 .or. lat2>90) then - print*, "at lower right i=,j=", i, j, lat, dlat,lat1,lat2 + print*, "- AT LOWER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 endif xnsum22 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, @@ -1392,7 +1384,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, lat1 = lat-dlat*0.5 lat2 = lat+dlat*0.5 if(lat1<-90 .or. lat2>90) then - print*, "at upper left i=,j=", i, j, lat, dlat,lat1,lat2 + print*, "- AT UPPER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 endif call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & zavg,delxn, xnsum1_11, xnsum2_11, HC_11) @@ -1403,7 +1395,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, lat1 = lat+dlat*0.5 lat2 = lat+dlat*1.5 if(lat1<-90 .or. lat2>90) then - print*, "at lower left i=,j=", i, j, lat, dlat,lat1,lat2 + print*, "- AT LOWER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 endif call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & zavg,delxn, xnsum1_12, xnsum2_12, HC_12) @@ -1414,7 +1406,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, lat1 = lat-dlat*0.5 lat2 = lat+dlat*0.5 if(lat1<-90 .or. lat2>90) then - print*, "at upper right i=,j=", i, j, lat, dlat,lat1,lat2 + print*, "- AT UPPER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 endif call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & zavg,delxn, xnsum1_21, xnsum2_21, HC_21) @@ -1425,7 +1417,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, lat1 = lat+dlat*0.5 lat2 = lat+dlat*1.5 if(lat1<-90 .or. lat2>90) then - print*, "at lower right i=,j=", i, j, lat, dlat,lat1,lat2 + print*, "- AT LOWER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 endif call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & zavg,delxn, xnsum1_22, xnsum2_22, HC_22) @@ -1440,7 +1432,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, lat1 = lat lat2 = lat+dlat if(lat1<-90 .or. lat2>90) then - print*, "at upper left i=,j=", i, j, lat, dlat,lat1,lat2 + print*, "- AT UPPER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 endif call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & zavg,delxn, xnsum1_11, xnsum2_11, HC_11) @@ -1451,7 +1443,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, lat1 = lat+dlat lat2 = lat+dlat*2.0 if(lat1<-90 .or. lat2>90) then - print*, "at lower left i=,j=", i, j, lat, dlat,lat1,lat2 + print*, "- AT LOWER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 endif call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, @@ -1463,7 +1455,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, lat1 = lat lat2 = lat+dlat if(lat1<-90 .or. lat2>90) then - print*, "at upper right i=,j=", i, j, lat, dlat,lat1,lat2 + print*, "- AT UPPER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 endif call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & zavg,delxn, xnsum1_21, xnsum2_21, HC_21) @@ -1474,7 +1466,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, lat1 = lat+dlat lat2 = lat+dlat*2.0 if(lat1<-90 .or. lat2>90) then - print*, "at lower right i=,j=", i, j, lat, dlat,lat1,lat2 + print*, "- AT LOWER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 endif call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, @@ -2439,9 +2431,12 @@ subroutine remove_isolated_pts(im,jm,slm,oro,var,var4,oa,ol) real :: slma, oroa, vara, var4a, xn, xs real, allocatable :: oaa(:), ola(:) +! REMOVE ISOLATED POINTS + + print*,"- REMOVE ISOLATED POINTS." + allocate (oaa(4),ola(4)) -C REMOVE ISOLATED POINTS iso_loop : DO J=2,JM-1 JN=J-1 JS=J+1 @@ -2520,8 +2515,8 @@ subroutine remove_isolated_pts(im,jm,slm,oro,var,var4,oa,ol) OLA(K)=OLA(K)/WGTA ENDDO IF(SLM(I,J).EQ.0..AND.SLMA.EQ.WGTA) THEN - PRINT '("SEA ",2F8.0," MODIFIED TO LAND",2F8.0," AT ",2I8)', - & ORO(I,J),VAR(I,J),OROA,VARA,I,J + PRINT '(" - SEA ",2F8.0," MODIFIED TO LAND",2F8.0, + & " AT ",2I8)',ORO(I,J),VAR(I,J),OROA,VARA,I,J SLM(I,J)=1. ORO(I,J)=OROA VAR(I,J)=VARA @@ -2531,8 +2526,8 @@ subroutine remove_isolated_pts(im,jm,slm,oro,var,var4,oa,ol) OL(I,J,K)=OLA(K) ENDDO ELSEIF(SLM(I,J).EQ.1..AND.SLMA.EQ.0.) THEN - PRINT '("LAND",2F8.0," MODIFIED TO SEA ",2F8.0," AT ",2I8)', - & ORO(I,J),VAR(I,J),OROA,VARA,I,J + PRINT '(" - LAND",2F8.0," MODIFIED TO SEA ",2F8.0, + & " AT ",2I8)',ORO(I,J),VAR(I,J),OROA,VARA,I,J SLM(I,J)=0. ORO(I,J)=OROA VAR(I,J)=VARA diff --git a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 index 5c259e912..a62080baa 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 @@ -45,7 +45,6 @@ subroutine write_netcdf(im, jm, slm, land_frac, oro, hprime, ntiles, tile, geolo dim1=size(lon,1) dim2=size(lat,1) - write(6,*) ' netcdf dims are: ',dim1, dim2 !--- open the file error = NF__CREATE(outfile, IOR(NF_NETCDF4,NF_CLASSIC_MODEL), inital, fsize, ncid) @@ -263,7 +262,6 @@ subroutine write_mask_netcdf(im, jm, slm, land_frac, ntiles, tile, geolon, geola dim1=im dim2=jm - write(6,*) ' netcdf dims are: ',dim1, dim2 !--- open the file error = NF__CREATE(outfile, IOR(NF_NETCDF4,NF_CLASSIC_MODEL), inital, fsize, ncid) @@ -348,7 +346,7 @@ subroutine read_mask(merge_file,slm,land_frac,lake_frac,im,jm) fsize = 66536 - print*, "merge_file=", trim(merge_file) + print*,'- READ IN EXTERNAL LANDMASK FILE: ',trim(merge_file) error=NF__OPEN(merge_file,NF_NOWRITE,fsize,ncid) call netcdf_err(error, 'Open file '//trim(merge_file) ) @@ -357,24 +355,17 @@ subroutine read_mask(merge_file,slm,land_frac,lake_frac,im,jm) error=nf_get_var_double(ncid, id_var, land_frac) call netcdf_err(error, 'inquire data of land_frac') - print*,'land_frac ',maxval(land_frac),minval(land_frac) - error=nf_inq_varid(ncid, 'slmsk', id_var) call netcdf_err(error, 'inquire varid of slmsk') error=nf_get_var_double(ncid, id_var, slm) call netcdf_err(error, 'inquire data of slmsk') - print*,'slmsk ',maxval(slm),minval(slm) - error=nf_inq_varid(ncid, 'lake_frac', id_var) call netcdf_err(error, 'inquire varid of lake_frac') error=nf_get_var_double(ncid, id_var, lake_frac) call netcdf_err(error, 'inquire data of lake_frac') - print*,'lake_frac ',maxval(lake_frac),minval(lake_frac) - error = nf_close(ncid) - print*,'bot of read_mask' end subroutine read_mask @@ -397,7 +388,7 @@ subroutine read_mdl_dims(mdl_grid_file, im, jm) fsize = 66536 - print*, "- OPEN AND READ= ", trim(mdl_grid_file) + print*, "- READ MDL GRID DIMENSIONS FROM= ", trim(mdl_grid_file) error=NF__OPEN(mdl_grid_file,NF_NOWRITE,fsize,ncid) call netcdf_err(error, 'Opening file '//trim(mdl_grid_file) ) From b3da9455fb5e0c2e6371bd4afe664be23717cbd6 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Mon, 29 Jul 2024 14:54:25 -0500 Subject: [PATCH 31/54] Move routine latlon2xyz to a new module that will host most utility routines. Create unit test for that routine. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/CMakeLists.txt | 2 +- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 25 +----- .../orog_mask_tools.fd/orog.fd/orog_utils.F90 | 45 ++++++++++ tests/CMakeLists.txt | 1 + tests/orog/CMakeLists.txt | 16 ++++ tests/orog/ftst_ll2xyz.F90 | 87 +++++++++++++++++++ 6 files changed, 151 insertions(+), 25 deletions(-) create mode 100644 sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 create mode 100644 tests/orog/CMakeLists.txt create mode 100644 tests/orog/ftst_ll2xyz.F90 diff --git a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt index ec8168faa..dda71f227 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt +++ b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt @@ -1,4 +1,4 @@ -set(lib_src netcdf_io.F90) +set(lib_src netcdf_io.F90 orog_utils.F90) set(exe_src mtnlm7_oclsm.F) if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 4275d4908..5a286d86a 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -1635,30 +1635,6 @@ subroutine read_global_orog(imn,jmn,glob) return end subroutine read_global_orog -!> Convert from latitude and longitude to x,y,z coordinates. -!! -!! @param[in] siz Number of points to convert. -!! @param[in] lon Longitude of points to convert. -!! @param[in] lat Latitude of points to convert. -!! @param[out] x 'x' coordinate of the converted points. -!! @param[out] y 'y' coordinate of the converted points. -!! @param[out] z 'z' coordinate of the converted points. -!! @author GFDL programmer - subroutine latlon2xyz(siz,lon, lat, x, y, z) - implicit none - integer, intent(in) :: siz - real, intent(in) :: lon(siz), lat(siz) - real, intent(out) :: x(siz), y(siz), z(siz) - - integer n - - do n = 1, siz - x(n) = cos(lat(n))*cos(lon(n)) - y(n) = cos(lat(n))*sin(lon(n)) - z(n) = sin(lat(n)) - enddo - end subroutine latlon2xyz - !> Compute spherical angle. !! !! @param[in] v1 Vector 1. @@ -1717,6 +1693,7 @@ END FUNCTION spherical_angle !! the polygon. !! @author GFDL programmer FUNCTION inside_a_polygon(lon1, lat1, npts, lon2, lat2) + use orog_utils, only : latlon2xyz implicit none real, parameter :: EPSLN10 = 1.e-10 real, parameter :: EPSLN8 = 1.e-8 diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 new file mode 100644 index 000000000..358ed6071 --- /dev/null +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -0,0 +1,45 @@ +!> @file +!! @brief Utilities for orog code. +!! @author George Gayno NOAA/EMC + +!> Module containing utilites used by the orog program. +!! +!! @author George Gayno NOAA/EMC + module orog_utils + + implicit none + + private + + public :: latlon2xyz + + contains + +!> Convert from latitude and longitude to x,y,z coordinates. +!! +!! @param[in] siz Number of points to convert. +!! @param[in] lon Longitude (radians) of points to convert. +!! @param[in] lat Latitude (radians) of points to convert. +!! @param[out] x 'x' Coordinate of the converted points. +!! @param[out] y 'y' Coordinate of the converted points. +!! @param[out] z 'z' Coordinate of the converted points. +!! @author GFDL programmer + subroutine latlon2xyz(siz,lon, lat, x, y, z) + + implicit none + + integer, intent(in) :: siz + real, intent(in) :: lon(siz), lat(siz) + real, intent(out) :: x(siz), y(siz), z(siz) + + integer :: n + + do n = 1, siz + x(n) = cos(lat(n))*cos(lon(n)) + y(n) = cos(lat(n))*sin(lon(n)) + z(n) = sin(lat(n)) + enddo + + end subroutine latlon2xyz + + end module orog_utils diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt index 95b28c8fe..9a5850084 100644 --- a/tests/CMakeLists.txt +++ b/tests/CMakeLists.txt @@ -42,3 +42,4 @@ add_subdirectory(sfc_climo_gen) add_subdirectory(cpld_gridgen) add_subdirectory(emcsfc_snow2mdl) add_subdirectory(ocnice_prep) +add_subdirectory(orog) diff --git a/tests/orog/CMakeLists.txt b/tests/orog/CMakeLists.txt new file mode 100644 index 000000000..d0d265e10 --- /dev/null +++ b/tests/orog/CMakeLists.txt @@ -0,0 +1,16 @@ +# This is the cmake build file for the tests directory of the +# UFS_UTILS project. +# +# George Gayno, Lin Gan, Ed Hartnett, Larissa Reames + +if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -r8") +elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -ffree-line-length-0 -fdefault-real-8") +endif() + +include_directories(${PROJECT_SOURCE_DIR}) + +add_executable(ftst_ll2xyz ftst_ll2xyz.F90) +add_test(NAME orog-ftst_ll2xyz COMMAND ftst_ll2xyz) +target_link_libraries(ftst_ll2xyz orog_lib) diff --git a/tests/orog/ftst_ll2xyz.F90 b/tests/orog/ftst_ll2xyz.F90 new file mode 100644 index 000000000..37b9ea6b8 --- /dev/null +++ b/tests/orog/ftst_ll2xyz.F90 @@ -0,0 +1,87 @@ + program ll2xyz + +! Unit test for routine latlon2xyz, which converts +! lat/lon to x/y/z coordinates. +! +! Author George Gayno NCEP/EMC + + use orog_utils, only : latlon2xyz + + implicit none + + integer, parameter :: siz = 6 + + real, parameter :: d2r = 3.14159265358979/180. + real, parameter :: EPSILON=0.0001 + + integer :: j + + real :: lon(siz), lat(siz), x(siz), y(siz), z(siz) + real :: expected_x_component(siz) + real :: expected_y_component(siz) + real :: expected_z_component(siz) + +! These are the expected x/y/z components returned from +! latlon2xyz for our test points. + + data expected_x_component/1.0, 0.0, -1.0, & + 0.0, 0.0, 0.7071068/ + + data expected_y_component/0.0, 1.0, 0.0, & + -1.0, 0.0, 0.0/ + + data expected_z_component/0.0, 0.0, 0.0, & + 0.0, 1.0, -0.7071068/ + + print*,"Starting test of latlon2xyz." + +! Test point 1 - the equator/greenwich. + + lat(1) = 0.0 + lon(1) = 0.0 + +! Test point 2 - the equator/90E + + lat(2) = 0.0 + lon(2) = 90.0 + +! Test point 3 - the equator/dateline + + lat(3) = 0.0 + lon(3) = 180.0 + +! Test point 4 - the equator/90W + + lat(4) = 0.0 + lon(4) = 270.0 + +! Test point 5 - the north pole/greenwich + + lat(5) = 90.0 + lon(5) = 0.0 + +! Test point 6 - 45S/greenwich + + lat(6) = -45.0 + lon(6) = 0.0 + + lat = lat * d2r + lon = lon * d2r + +! Call the routine to unit test. + + call latlon2xyz(siz,lon,lat,x,y,z) + +! Check results. + + do j = 1, siz + if (abs(x(j) - expected_x_component(j)) > EPSILON) stop 2 + if (abs(y(j) - expected_y_component(j)) > EPSILON) stop 3 + if (abs(z(j) - expected_z_component(j)) > EPSILON) stop 4 + enddo + + print*,"OK" + + print*,"SUCCESS" + + end program ll2xyz From 5d931876a0d216bb149be7f028b69dea6d223ee9 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 31 Jul 2024 08:33:42 -0500 Subject: [PATCH 32/54] Update prolog. Change name of 'merge_file' to a more descriptive 'external_mask_file'. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 97 +++++++++++-------- 1 file changed, 55 insertions(+), 42 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 5a286d86a..b5df991f8 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -1,20 +1,38 @@ C> @file -C> Terrain maker for global spectral model. +C> Terrain maker for the ufs weather model. C> @author Mark Iredell @date 92-04-16 -C> This program creates 7 terrain-related files computed from the -C> GMTED2010 terrain dataset. The model physics grid parameters and -C> spectral truncation and filter parameters are read by this program as -C> input. +C> This program creates landmask, land fraction, terrain and +C> and fields required for the model's gravity wave drag +C> (GWD) scheme. +C> +C> Specifically: +C> +C> - Land mask (yes/no flag) +C> - Land fraction +C> - Terrain (orography) +C> - Maximum elevation +C> - Standard deviation of terrain +C> - Convexity +C> - Orographic Asymetry - W/S/SW/NW directional components. +C> - Orographic Length Scale - W/S/SW/NW directional components. +C> - Anisotropy +C> - Slope of terrain +C> - Angle of mountain range with respect to East. C> -C> The 7 files produced are: -C> 1. sea-land mask on model physics grid -C> 2. gridded orography on model physics grid -C> 3. mountain std dev on model physics grid -C> 4. spectral orography in spectral domain -C> 5. unfiltered gridded orography on model physics grid -C> 6. grib sea-land mask on model physics grid -C> 7. grib gridded orography on model physics grid +C> This program operates on a single cubed-sphere tile. +C> +C> Optionally, the program can compute and output only the +C> land mask and land fraction. Or, it can read in the mask +C> and fraction from an external file, then compute the +C> terrain and GWD fields using that mask. These options +C> are used to support coupled (atm/oceann) runs of the UFS. +C> The process is: +C> - Run this program and output the mask/fraction only. +C> - Adjust or merge the mask/fraction with the ocean +C> mask (using another program). +C> - Read in this 'merged' mask/fraction and compute the +C> terrain and GWD fields. C> C> PROGRAM HISTORY LOG: C> - 92-04-16 IREDELL @@ -32,35 +50,28 @@ C> - 05-09-05 if test on HK and HLPRIM for GAMMA SQRT C> - 07-08-07 replace 8' with 30" incl GICE, conintue w/ S-Y. lake slm C> - 08-08-07 All input 30", UMD option, and filter as described below +C> - 24-08-15 Remove old code used by spectral GFS. C> C> INPUT FILES: -C> - UNIT5 - PHYSICS LONGITUDES (IM), PHYSICS LATITUDES (JM), -C> SPECTRAL TRUNCATION (NM), RHOMBOIDAL FLAG (NR), -C> AND FIRST AND SECOND FILTER PARAMETERS (NF0,NF1). -C> RESPECTIVELY READ IN FREE FORMAT. +C> - UNIT5 - PROGRAM CONTROL NAMELIST. +C> - NCID - MODEL 'GRID' FILE C> - NCID - GMTED2010 USGS orography (NetCDF) C> - NCID - 30" UMD land cover mask. (NetCDF) -C> - NCID - GICE Grumbine 30" RAMP Antarctica orog IMNx3601. (NetCDF) -C> -C> OUTPUT FILES: -C> - UNIT51 - SEA-LAND MASK (IM,JM) -C> - UNIT52 - GRIDDED OROGRAPHY (IM,JM) -C> - UNIT54 - SPECTRAL OROGRAPHY ((NM+1)*((NR+1)*NM+2)) -C> - UNIT55 - UNFILTERED GRIDDED OROGRAPHY (IM,JM) -C> - UNIT57 - GRIB GRIDDED OROGRAPHY (IM,JM) +C> - NCID - GICE Grumbine 30" RAMP Antarctica orog. (NetCDF) +C> - NCID - MERGE FILE. CONTAINS LAND MASK, FRACTION AND +C> LAKE FRACTION THAT HAS BEEN MERGED WITH AN +C> OCEAN GRID. (NetCDF) C> -C> SUBPROGRAMS CALLED: -C> - UNIQUE: -C> - TERSUB - MAIN SUBPROGRAM -C> - SPLAT - COMPUTE GAUSSIAN LATITUDES OR EQUALLY-SPACED LATITUDES -C> - LIBRARY: -C> - SPTEZ - SPHERICAL TRANSFORM +C> OUTPUT FILES (ALL ON A SINGLE CUBED-SPHERE TILE) : +C> - NCID - OROGRAPHY FILE (NetCDF) IF MASK_ONLY=FALSE +C> - NCID - MASK FILE (NetCDF) IF MASK_ONLY=TRUE +C> - CONTAINS ONLY LAND MASK AND FRACTION. C> C> @return 0 for success, error code otherwise. implicit none character(len=256) :: mdl_grid_file = "none" - character(len=256) :: merge_file = "none" + character(len=256) :: external_mask_file = "none" integer :: imn, jmn, im, jm, efac logical :: mask_only = .false. @@ -68,7 +79,7 @@ read(5,*) mdl_grid_file read(5,*) mask_only - read(5,*) merge_file + read(5,*) external_mask_file efac = 0 imn = 360*120 @@ -78,15 +89,15 @@ print*,"- WILL COMPUTE LANDMASK ONLY." endif - if (trim(merge_file) /= "none") then + if (trim(external_mask_file) /= "none") then print*,"- WILL USE EXTERNAL LANDMASK FROM FILE: ", - & trim(merge_file) + & trim(external_mask_file) endif call read_mdl_dims(mdl_grid_file, im, jm) call tersub(imn,jmn,im,jm,efac, - & mdl_grid_file,mask_only,merge_file) + & mdl_grid_file,mask_only,external_mask_file) print*,"- NORMAL TERMINATION." @@ -105,16 +116,17 @@ !! When not specified, program will create fields from !! raw high-resolution topography data. !! @param[in] MASK_ONLY Flag to generate the Land Mask only -!! @param[in] MERGE_FILE Ocean merge file +!! @param[in] EXTERNAL_MASK_FILE File containing an externally +!! generated land mask/fraction. !! @author Jordan Alpert NOAA/EMC SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, - & OUTGRID,MASK_ONLY,MERGE_FILE) + & OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) implicit none include 'netcdf.inc' C integer :: IMN,JMN,IM,JM character(len=*), intent(in) :: OUTGRID - character(len=*), intent(in) :: MERGE_FILE + character(len=*), intent(in) :: EXTERNAL_MASK_FILE logical, intent(in) :: mask_only @@ -202,12 +214,13 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ! tbeg=timef() - IF (MERGE_FILE == 'none') then + IF (EXTERNAL_MASK_FILE == 'none') then CALL MAKE_MASK(ZSLM,SLM,land_frac, & IM,JM,IMN,JMN,geolon_c,geolat_c) lake_frac=9999.9 ELSE - CALL READ_MASK(MERGE_FILE,SLM,land_frac,lake_frac,im,jm) + CALL READ_MASK(EXTERNAL_MASK_FILE,SLM,land_frac, + & lake_frac,im,jm) ENDIF IF (MASK_ONLY) THEN @@ -322,7 +335,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ENDDO ENDDO - IF (MERGE_FILE == 'none') then + IF (EXTERNAL_MASK_FILE == 'none') then call remove_isolated_pts(im,jm,slm,oro,var,var4,oa,ol) From be2a680ddb49cbf8496ba002aa5c830d44bd5ccb Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 31 Jul 2024 13:55:23 -0500 Subject: [PATCH 33/54] Combine routine minmxj and mnmxja into a single routine called minmax. Write unit test for this new routine. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 102 +++--------------- .../orog_mask_tools.fd/orog.fd/orog_utils.F90 | 55 ++++++++++ tests/orog/CMakeLists.txt | 9 +- tests/orog/ftst_minmax.F90 | 44 ++++++++ 4 files changed, 122 insertions(+), 88 deletions(-) create mode 100644 tests/orog/ftst_minmax.F90 diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index b5df991f8..b0cbc939c 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -121,6 +121,9 @@ !! @author Jordan Alpert NOAA/EMC SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, & OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) + + use orog_utils, only : minmax + implicit none include 'netcdf.inc' C @@ -242,10 +245,10 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, tend=timef() print*,"- TIMING: MASK AND OROG CREATION ", tend-tbeg - call minmxj(IM,JM,ORO,'ORO ') - call minmxj(IM,JM,SLM,'SLM ') - call minmxj(IM,JM,VAR,'VAR ') - call minmxj(IM,JM,VAR4,'VAR4 ') + call minmax(IM,JM,ORO,'ORO ') + call minmax(IM,JM,SLM,'SLM ') + call minmax(IM,JM,VAR,'VAR ') + call minmax(IM,JM,VAR4,'VAR4 ') ! Compute mtn principal coord HTENSR: THETA,GAMMA,SIGMA @@ -258,9 +261,9 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, print*,"- TIMING: CREATE PRINCIPLE COORDINATE ",tend-tbeg - call minmxj(IM,JM,THETA,'THETA ') - call minmxj(IM,JM,GAMMA,'GAMMA ') - call minmxj(IM,JM,SIGMA,'SIGMA ') + call minmax(IM,JM,THETA,'THETA ') + call minmax(IM,JM,GAMMA,'GAMMA ') + call minmax(IM,JM,SIGMA,'SIGMA ') ! COMPUTE MOUNTAIN DATA : OA OL @@ -287,10 +290,10 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, deallocate(IWORK) tbeg=timef() - call minmxj(IM,JM,OA,'OA ') - call minmxj(IM,JM,OL,'OL ') - call minmxj(IM,JM,ELVMAX,'ELVMAX ') - call minmxj(IM,JM,ORO,'ORO ') + call minmax(IM,JM,OA,'OA ') + call minmax(IM,JM,OL,'OL ') + call minmax(IM,JM,ELVMAX,'ELVMAX ') + call minmax(IM,JM,ORO,'ORO ') ! Replace maximum elevation with max elevation minus orography. ! If maximum elevation is less than the orography, replace with @@ -307,7 +310,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ENDDO ENDDO - call mnmxja(IM,JM,ELVMAX,itest,jtest,'ELVMAX ') + call minmax(IM,JM,ELVMAX,'ELVMAX ',itest,jtest) print*,"- ZERO FIELDS OVER OCEAN." @@ -366,8 +369,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, deallocate(VAR4) deallocate (WORK1) - call mnmxja(IM,JM,ELVMAX,itest,jtest,'ELVMAX ') - call minmxj(IM,JM,ORO,'ORO ') + call minmax(IM,JM,ELVMAX,'ELVMAX ',itest,jtest) + call minmax(IM,JM,ORO,'ORO ') print *,'- ORO(itest,jtest),itest,jtest:', & ORO(itest,jtest),itest,jtest @@ -1541,77 +1544,6 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, END SUBROUTINE MAKEOA2 -!> Print out the maximum and minimum values of -!! an array. -!! -!! @param[in] im The 'i' dimension of the array. -!! @param[in] jm The 'i' dimension of the array. -!! @param[in] a The array to check. -!! @param[in] title Name of the data to be checked. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE minmxj(IM,JM,A,title) - implicit none - - real A(IM,JM),rmin,rmax - integer i,j,IM,JM - character*8 title - - rmin=1.e+10 - rmax=-rmin -csela.................................................... -csela if(rmin.eq.1.e+10)return -csela.................................................... - DO j=1,JM - DO i=1,IM - if(A(i,j).ge.rmax)rmax=A(i,j) - if(A(i,j).le.rmin)rmin=A(i,j) - ENDDO - ENDDO - write(6,150) title,rmin,rmax -150 format(' - ',a8,' MIN=',e13.4,2x,'MAX=',e13.4) - - RETURN - END SUBROUTINE minmxj - -!> Print out the maximum and minimum values of -!! an array. Pass back the i/j location of the -!! maximum value. -!! -!! @param[in] im The 'i' dimension of the array. -!! @param[in] jm The 'i' dimension of the array. -!! @param[in] a The array to check. -!! @param[out] imax 'i' location of maximum -!! @param[out] jmax 'j' location of maximum -!! @param[in] title Name of the data to be checked. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE mnmxja(IM,JM,A,imax,jmax,title) - implicit none - - real A(IM,JM),rmin,rmax - integer i,j,IM,JM,imax,jmax - character*8 title - - rmin=1.e+10 - rmax=-rmin -csela.................................................... -csela if(rmin.eq.1.e+10)return -csela.................................................... - DO j=1,JM - DO i=1,IM - if(A(i,j).ge.rmax)then - rmax=A(i,j) - imax=i - jmax=j - endif - if(A(i,j).le.rmin)rmin=A(i,j) - ENDDO - ENDDO - write(6,150) title,rmin,rmax -150 format(' - ',a8,' MIN=',e13.4,2x,'MAX=',e13.4) -C - RETURN - END SUBROUTINE mnmxja - !> Read input global 30-arc second orography data. !! !! @param[in] imn i-dimension of orography data. diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 index 358ed6071..2e77a0cdd 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -12,9 +12,63 @@ module orog_utils private public :: latlon2xyz + public :: minmax contains +!> Print out the maximum and minimum values of +!! an array and optionally pass back the i/j +!! location of the maximum. +!! +!! @param[in] im The 'i' dimension of the array. +!! @param[in] jm The 'j' dimension of the array. +!! @param[in] a The array to check. +!! @param[in] title Name of the data to be checked. +!! @param[out] imax The 'i' location of the maximum. +!! @param[out] jmax The 'j' location of the maximum. +!! +!! @author Jordan Alpert NOAA/EMC + subroutine minmax(im,jm,a,title,imax,jmax) + + implicit none + + character(len=8), intent(in) :: title + + integer, intent(in) :: im, jm + integer, intent(out), optional :: imax, jmax + + real, intent(in) :: a(im,jm) + + integer :: i, j + + real :: rmin,rmax + + rmin=huge(a) + rmax=-rmin + + if (present(imax) .and. present(jmax)) then + imax=0 + jmax=0 + endif + + do j=1,jm + do i=1,im + if(a(i,j) >= rmax) then + rmax=a(i,j) + if (present(imax) .and. present(jmax)) then + imax = i + jmax = j + endif + endif + if(a(i,j) <= rmin)rmin=a(i,j) + enddo + enddo + + write(6,150) title,rmin,rmax +150 format(' - ',a8,' MIN=',e13.4,2x,'MAX=',e13.4) + + end subroutine minmax + !> Convert from latitude and longitude to x,y,z coordinates. !! !! @param[in] siz Number of points to convert. @@ -23,6 +77,7 @@ module orog_utils !! @param[out] x 'x' Coordinate of the converted points. !! @param[out] y 'y' Coordinate of the converted points. !! @param[out] z 'z' Coordinate of the converted points. +!! !! @author GFDL programmer subroutine latlon2xyz(siz,lon, lat, x, y, z) diff --git a/tests/orog/CMakeLists.txt b/tests/orog/CMakeLists.txt index d0d265e10..586b00731 100644 --- a/tests/orog/CMakeLists.txt +++ b/tests/orog/CMakeLists.txt @@ -1,7 +1,6 @@ -# This is the cmake build file for the tests directory of the -# UFS_UTILS project. +# This is the cmake build file. # -# George Gayno, Lin Gan, Ed Hartnett, Larissa Reames +# George Gayno, Ed Hartnett if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -r8") @@ -14,3 +13,7 @@ include_directories(${PROJECT_SOURCE_DIR}) add_executable(ftst_ll2xyz ftst_ll2xyz.F90) add_test(NAME orog-ftst_ll2xyz COMMAND ftst_ll2xyz) target_link_libraries(ftst_ll2xyz orog_lib) + +add_executable(ftst_minmax ftst_minmax.F90) +add_test(NAME orog-ftst_minmax COMMAND ftst_minmax) +target_link_libraries(ftst_minmax orog_lib) diff --git a/tests/orog/ftst_minmax.F90 b/tests/orog/ftst_minmax.F90 new file mode 100644 index 000000000..3f90bef0c --- /dev/null +++ b/tests/orog/ftst_minmax.F90 @@ -0,0 +1,44 @@ + program minmax_test + +! Unit test for routine minmax, which finds the +! minimum and maximum value of an array and +! the indices of the maximum. +! +! Author George Gayno NCEP/EMC + + use orog_utils, only : minmax + + implicit none + + character(len=8) :: title + + integer, parameter :: im = 3 + integer, parameter :: jm = 2 + integer :: imax, jmax + + real :: a(im,jm) + + print*,"Starting test of minmax." + +! Test array. + + a(1,1) = 3. + a(2,1) = 4. + a(3,1) = 2. + a(1,2) = 1. + a(2,2) = 4. + a(3,2) = -1. + + title = 'test ' + +! Call the routine to unit test. + + call minmax(im,jm,a,title,imax,jmax) + + if (imax /= 2 .or. jmax /= 2) stop 3 + + print*,"OK" + + print*,"SUCCESS" + + end program minmax_test From fde1c2e7b9ebeb36d7c12b582da926b7ed837a77 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Thu, 1 Aug 2024 08:39:58 -0500 Subject: [PATCH 34/54] Move function get_lat_angle to the orog_utils module and create a unit test for it. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 24 ++------------- .../orog_mask_tools.fd/orog.fd/orog_utils.F90 | 24 +++++++++++++++ tests/orog/CMakeLists.txt | 4 +++ tests/orog/ftst_get_ll_angle.F90 | 29 +++++++++++++++++++ 4 files changed, 60 insertions(+), 21 deletions(-) create mode 100644 tests/orog/ftst_get_ll_angle.F90 diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index b0cbc939c..dc5488bc0 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -1103,25 +1103,6 @@ function get_lon_angle(dx,lat, DEGRAD) get_lon_angle = 2*asin( sin(dx/RADIUS*0.5)/cos(lat) )*DEGRAD end function get_lon_angle - -!> Convert the 'y' direction distance of a cubed-sphere grid -!! point to the corresponding distance in latitude. -!! -!! @param[in] dy Distance along the 'y' direction of a cubed-sphere -!! point. -!! @param[in] degrad Conversion from radians to degrees. -!! @return get_lat_angle Corresponding distance in latitude. -!! @author GFDL programmer - function get_lat_angle(dy, DEGRAD) - implicit none - real dy, DEGRAD - - real get_lat_angle - real, parameter :: RADIUS = 6371200 - - get_lat_angle = dy/RADIUS*DEGRAD - - end function get_lat_angle !> Create orographic asymmetry and orographic length scale on !! the model grid. This routine is used for the cubed-sphere @@ -1162,6 +1143,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, 1 ORO,oro1,XNSUM,XNSUM1,XNSUM2,XNSUM3,XNSUM4, 2 IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t,dx,dy, 3 is_south_pole,is_north_pole ) + use orog_utils, only : get_lat_angle implicit none real, parameter :: MISSING_VALUE = -9999. real, parameter :: D2R = 3.14159265358979/180. @@ -1192,7 +1174,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, real HC_11, HC_12, HC_21, HC_22 real xnsum1_11,xnsum1_12,xnsum1_21,xnsum1_22 real xnsum2_11,xnsum2_12,xnsum2_21,xnsum2_22 - real get_lon_angle, get_lat_angle, get_xnsum + real get_lon_angle, get_xnsum integer jst, jen print*,"- CREATE ASYMETRY AND LENGTH SCALE." @@ -1317,7 +1299,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, !--- for each point, find a lat-lon grid box with same dx and dy as the cubic grid box dlon = get_lon_angle(dx(i,j), lat*D2R, R2D ) - dlat = get_lat_angle(dy(i,j), R2D) + dlat = get_lat_angle(dy(i,j)) !--- adjust dlat if the points are close to pole. if( lat-dlat*0.5<-90.) then print*, "- AT I,J =", i,j, lat, dlat, lat-dlat*0.5 diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 index 2e77a0cdd..cf63ba2f3 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -13,6 +13,7 @@ module orog_utils public :: latlon2xyz public :: minmax + public :: get_lat_angle contains @@ -97,4 +98,27 @@ subroutine latlon2xyz(siz,lon, lat, x, y, z) end subroutine latlon2xyz +!> Convert the 'y' direction distance of a cubed-sphere grid +!! point to the corresponding distance in latitude. +!! +!! @param[in] dy Distance along the 'y' direction of a cubed-sphere +!! point in meters. +!! @return get_lat_angle Corresponding latitudinal distance in degrees. +!! +!! @author GFDL programmer + + function get_lat_angle(dy) + + implicit none + + real, intent(in) :: dy + + real :: get_lat_angle + real, parameter :: earth_radius = 6371200 ! meters + real, parameter :: rad2deg = 180./3.14159265358979 + + get_lat_angle = dy/earth_radius*rad2deg + + end function get_lat_angle + end module orog_utils diff --git a/tests/orog/CMakeLists.txt b/tests/orog/CMakeLists.txt index 586b00731..b1bd2179b 100644 --- a/tests/orog/CMakeLists.txt +++ b/tests/orog/CMakeLists.txt @@ -17,3 +17,7 @@ target_link_libraries(ftst_ll2xyz orog_lib) add_executable(ftst_minmax ftst_minmax.F90) add_test(NAME orog-ftst_minmax COMMAND ftst_minmax) target_link_libraries(ftst_minmax orog_lib) + +add_executable(ftst_get_ll_angle ftst_get_ll_angle.F90) +add_test(NAME orog-ftst_get_ll_angle COMMAND ftst_get_ll_angle) +target_link_libraries(ftst_get_ll_angle orog_lib) diff --git a/tests/orog/ftst_get_ll_angle.F90 b/tests/orog/ftst_get_ll_angle.F90 new file mode 100644 index 000000000..cf063b3a9 --- /dev/null +++ b/tests/orog/ftst_get_ll_angle.F90 @@ -0,0 +1,29 @@ + program get_ll_angle + +! Unit test for function get_lat_angle. +! +! Author George Gayno NCEP/EMC + + use orog_utils, only : get_lat_angle + + implicit none + + real :: dlat, dy + real, parameter :: EPSILON=0.001 + +! dy is the approximate distance in meters of one +! degree of latitude. + + dy = 111139.0 + + dlat = get_lat_angle(dy) + +! Is dlat approximately one degree? + + if (abs(dlat - 1.0) > EPSILON) stop 2 + + print*,"OK" + + print*,"SUCCESS" + + end program get_ll_angle From 79426f4dc28deafe12119aa0cd26a14199a8c17d Mon Sep 17 00:00:00 2001 From: George Gayno Date: Thu, 1 Aug 2024 14:04:12 -0500 Subject: [PATCH 35/54] Move function get_lon_angle to the orog_utils module. Add logic to prevent divide by zero at poles. Add unit testing for this function. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 27 ++------------ .../orog_mask_tools.fd/orog.fd/orog_utils.F90 | 35 +++++++++++++++++- tests/orog/ftst_get_ll_angle.F90 | 37 +++++++++++++++++-- 3 files changed, 69 insertions(+), 30 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index dc5488bc0..be16edf1b 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -1084,26 +1084,6 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, RETURN END SUBROUTINE MAKEPC2 -!> Convert the 'x' direction distance of a cubed-sphere grid -!! point to the corresponding distance in longitude. -!! -!! @param[in] dx Distance along the 'x' direction of a -!! cubed-sphere grid point. -!! @param[in] lat Latitude of the cubed-sphere point. -!! @param[in] degrad Conversion from radians to degrees. -!! @return get_lon_angle Corresponding distance in longitude. -!! @author GFDL programmer - function get_lon_angle(dx,lat, DEGRAD) - implicit none - real dx, lat, DEGRAD - - real get_lon_angle - real, parameter :: RADIUS = 6371200 - - get_lon_angle = 2*asin( sin(dx/RADIUS*0.5)/cos(lat) )*DEGRAD - - end function get_lon_angle - !> Create orographic asymmetry and orographic length scale on !! the model grid. This routine is used for the cubed-sphere !! grid. @@ -1143,11 +1123,10 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, 1 ORO,oro1,XNSUM,XNSUM1,XNSUM2,XNSUM3,XNSUM4, 2 IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t,dx,dy, 3 is_south_pole,is_north_pole ) - use orog_utils, only : get_lat_angle + use orog_utils, only : get_lat_angle, get_lon_angle implicit none real, parameter :: MISSING_VALUE = -9999. real, parameter :: D2R = 3.14159265358979/180. - real, PARAMETER :: R2D=180./3.14159265358979 integer IM,JM,IMN,JMN real GLAT(JMN) INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) @@ -1174,7 +1153,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, real HC_11, HC_12, HC_21, HC_22 real xnsum1_11,xnsum1_12,xnsum1_21,xnsum1_22 real xnsum2_11,xnsum2_12,xnsum2_21,xnsum2_22 - real get_lon_angle, get_xnsum + real get_xnsum integer jst, jen print*,"- CREATE ASYMETRY AND LENGTH SCALE." @@ -1298,7 +1277,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, else !--- for each point, find a lat-lon grid box with same dx and dy as the cubic grid box - dlon = get_lon_angle(dx(i,j), lat*D2R, R2D ) + dlon = get_lon_angle(dx(i,j), lat ) dlat = get_lat_angle(dy(i,j)) !--- adjust dlat if the points are close to pole. if( lat-dlat*0.5<-90.) then diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 index cf63ba2f3..c19836f05 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -11,9 +11,14 @@ module orog_utils private + real, parameter :: earth_radius = 6371200. ! meters + real, parameter :: rad2deg = 180./3.14159265358979 + real, parameter :: deg2rad = 3.14159265358979/180. + public :: latlon2xyz public :: minmax public :: get_lat_angle + public :: get_lon_angle contains @@ -114,11 +119,37 @@ function get_lat_angle(dy) real, intent(in) :: dy real :: get_lat_angle - real, parameter :: earth_radius = 6371200 ! meters - real, parameter :: rad2deg = 180./3.14159265358979 get_lat_angle = dy/earth_radius*rad2deg end function get_lat_angle +!> Convert the 'x' direction distance of a cubed-sphere grid +!! point to the corresponding distance in longitude. +!! +!! @param[in] dx Distance along the 'x' direction of a +!! cubed-sphere grid point in meters. +!! @param[in] lat_in Latitude of the cubed-sphere point in +!! degrees. +!! @return get_lon_angle Corresponding distance in longitude +!! in degrees. +!! +!! @author GFDL programmer + + function get_lon_angle(dx,lat_in) + + implicit none + + real, intent(in) :: dx, lat_in + + real :: get_lon_angle, lat + + lat = lat_in + if (lat > 89.5) lat = 89.5 + if (lat < -89.5) lat = -89.5 + + get_lon_angle = 2*asin( sin(dx/earth_radius*0.5)/cos(lat*deg2rad) )*rad2deg + + end function get_lon_angle + end module orog_utils diff --git a/tests/orog/ftst_get_ll_angle.F90 b/tests/orog/ftst_get_ll_angle.F90 index cf063b3a9..e1812f4d6 100644 --- a/tests/orog/ftst_get_ll_angle.F90 +++ b/tests/orog/ftst_get_ll_angle.F90 @@ -1,18 +1,21 @@ program get_ll_angle -! Unit test for function get_lat_angle. +! Unit test for functions get_lat_angle and +! get_lon_angle. ! ! Author George Gayno NCEP/EMC - use orog_utils, only : get_lat_angle + use orog_utils, only : get_lat_angle, get_lon_angle implicit none - real :: dlat, dy + real :: dlat, dlon, dy, lat real, parameter :: EPSILON=0.001 + print*,'Test get_lat_angle' + ! dy is the approximate distance in meters of one -! degree of latitude. +! degree of latitude (or longitude at the equator). dy = 111139.0 @@ -22,6 +25,32 @@ program get_ll_angle if (abs(dlat - 1.0) > EPSILON) stop 2 + print*,'Test get_lon_angle' + +! Test equator point. Should be about 1-degree. + + lat = 0.0 + dlon = get_lon_angle(dy,lat) + if (abs(dlon - 1.0) > EPSILON) stop 3 + +! Test point at 60S. Should be about 2-degrees. + + lat = -60.0 + dlon = get_lon_angle(dy,lat) + if (abs(dlon - 2.0) > EPSILON) stop 4 + +! Test both poles. To prevent a divide by zero, +! the function has special logic at the poles. +! The result is about 176 degrees. + + lat = -90.0 + dlon = get_lon_angle(dy,lat) + if (abs(dlon - 176.254) > EPSILON) stop 5 + + lat = 90.0 + dlon = get_lon_angle(dy,lat) + if (abs(dlon - 176.254) > EPSILON) stop 6 + print*,"OK" print*,"SUCCESS" From f94d1493d085dd0816eee07bfa9aded602298b34 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Mon, 16 Sep 2024 10:26:12 -0500 Subject: [PATCH 36/54] Move routines 'timef', 'transpose_mask' and 'spherical_angle' to orog_utils.F90. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 118 +---------------- .../orog_mask_tools.fd/orog.fd/orog_utils.F90 | 123 ++++++++++++++++++ 2 files changed, 129 insertions(+), 112 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index be16edf1b..6795dfa9f 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -122,7 +122,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, & OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) - use orog_utils, only : minmax + use orog_utils, only : minmax, timef implicit none include 'netcdf.inc' @@ -143,7 +143,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, integer, allocatable :: IWORK(:,:,:) - real :: timef,tbeg,tend,tbeg1 + real :: tbeg,tend,tbeg1 real, allocatable :: XLAT(:),XLON(:) real, allocatable :: GEOLON(:,:),GEOLON_C(:,:),DX(:,:) @@ -1540,53 +1540,6 @@ subroutine read_global_orog(imn,jmn,glob) return end subroutine read_global_orog - -!> Compute spherical angle. -!! -!! @param[in] v1 Vector 1. -!! @param[in] v2 Vector 2. -!! @param[in] v3 Vector 3. -!! @return spherical_angle Spherical Angle. -!! @author GFDL programmer - FUNCTION spherical_angle(v1, v2, v3) - implicit none - real, parameter :: EPSLN30 = 1.e-30 - real, parameter :: PI=3.1415926535897931 - real v1(3), v2(3), v3(3) - real spherical_angle - - real px, py, pz, qx, qy, qz, ddd; - - ! vector product between v1 and v2 - px = v1(2)*v2(3) - v1(3)*v2(2) - py = v1(3)*v2(1) - v1(1)*v2(3) - pz = v1(1)*v2(2) - v1(2)*v2(1) - ! vector product between v1 and v3 - qx = v1(2)*v3(3) - v1(3)*v3(2); - qy = v1(3)*v3(1) - v1(1)*v3(3); - qz = v1(1)*v3(2) - v1(2)*v3(1); - - ddd = (px*px+py*py+pz*pz)*(qx*qx+qy*qy+qz*qz); - if ( ddd <= 0.0 ) then - spherical_angle = 0. - else - ddd = (px*qx+py*qy+pz*qz) / sqrt(ddd); - if( abs(ddd-1) < EPSLN30 ) ddd = 1; - if( abs(ddd+1) < EPSLN30 ) ddd = -1; - if ( ddd>1. .or. ddd<-1. ) then - !FIX to correctly handle co-linear points (angle near pi or 0) */ - if (ddd < 0.) then - spherical_angle = PI - else - spherical_angle = 0. - endif - else - spherical_angle = acos( ddd ) - endif - endif - - return - END FUNCTION spherical_angle !> Check if a point is inside a polygon. !! @@ -1599,13 +1552,13 @@ END FUNCTION spherical_angle !! the polygon. !! @author GFDL programmer FUNCTION inside_a_polygon(lon1, lat1, npts, lon2, lat2) - use orog_utils, only : latlon2xyz + use orog_utils, only : latlon2xyz, spherical_angle implicit none real, parameter :: EPSLN10 = 1.e-10 real, parameter :: EPSLN8 = 1.e-8 real, parameter :: PI=3.1415926535897931 real, parameter :: RANGE_CHECK_CRITERIA=0.05 - real :: anglesum, angle, spherical_angle + real :: anglesum, angle integer i, ip1 real lon1, lat1 integer npts @@ -1657,7 +1610,6 @@ FUNCTION inside_a_polygon(lon1, lat1, npts, lon2, lat2) pnt2(3) = z2(ip1) angle = spherical_angle(pnt0, pnt2, pnt1); -! anglesum = anglesum + spherical_angle(pnt0, pnt2, pnt1); anglesum = anglesum + angle enddo @@ -1938,24 +1890,6 @@ subroutine get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN, enddo end subroutine get_xnsum3 -!> Get the date/time for the system clock. -!! -!! @author Mark Iredell -!! @return timef - real function timef() - character(8) :: date - character(10) :: time - character(5) :: zone - integer,dimension(8) :: values - integer :: total - real :: elapsed - call date_and_time(date,time,zone,values) - total=(3600*values(5))+(60*values(6)) - * +values(7) - elapsed=float(total) + (1.0e-3*float(values(8))) - timef=elapsed - return - end function timef !> Find the point on the model grid tile closest to the !! north and south pole. @@ -2155,6 +2089,8 @@ end subroutine transpose_orog !! @author G. Gayno NOAA/EMC subroutine read_global_mask(imn, jmn, mask) + use orog_utils, only : transpose_mask + implicit none include 'netcdf.inc' @@ -2181,48 +2117,6 @@ subroutine read_global_mask(imn, jmn, mask) end subroutine read_global_mask -!> Transpose the global landmask by flipping -!! the poles and moving the starting longitude to -!! Greenwich. -!! -!! @param[in] imn i-dimension of landmask data. -!! @param[in] jmn j-dimension of landmask data. -!! @param[inout] mask The global landmask data. -!! @author G. Gayno - subroutine transpose_mask(imn, jmn, mask) - - implicit none - - integer, intent(in) :: imn, jmn - integer(1), intent(inout) :: mask(imn,jmn) - - integer :: i, j, it, jt - integer(1) :: isave - -! Transpose from S to N to the NCEP standard N to S. - - do j=1,jmn/2 - do I=1,imn - jt=jmn - j + 1 - isave = mask(I,j) - mask(I,j)=mask(I,jt) - mask(I,jt) = isave - enddo - enddo - -! Data begins at dateline. NCEP standard is Greenwich. - - do j=1,jmn - do I=1,imn/2 - it=imn/2 + i - isave = mask(i,J) - mask(i,J)=mask(it,J) - mask(it,J) = isave - enddo - enddo - - end subroutine transpose_mask - !> Quality control the global orography and landmask !! data over Antarctica using RAMP data. !! diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 index c19836f05..c388aa8a8 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -12,6 +12,7 @@ module orog_utils private real, parameter :: earth_radius = 6371200. ! meters + real, parameter :: pi=3.1415926535897931 real, parameter :: rad2deg = 180./3.14159265358979 real, parameter :: deg2rad = 3.14159265358979/180. @@ -19,6 +20,9 @@ module orog_utils public :: minmax public :: get_lat_angle public :: get_lon_angle + public :: timef + public :: transpose_mask + public :: spherical_angle contains @@ -152,4 +156,123 @@ function get_lon_angle(dx,lat_in) end function get_lon_angle +!> Transpose the global landmask by flipping +!! the poles and moving the starting longitude to +!! Greenwich. +!! +!! @param[in] imn i-dimension of landmask data. +!! @param[in] jmn j-dimension of landmask data. +!! @param[inout] mask The global landmask data. +!! @author G. Gayno + + subroutine transpose_mask(imn, jmn, mask) + + implicit none + + integer, intent(in) :: imn, jmn + integer(1), intent(inout) :: mask(imn,jmn) + + integer :: i, j, it, jt + integer(1) :: isave + +! Transpose from S to N to the NCEP standard N to S. + + do j=1,jmn/2 + do I=1,imn + jt=jmn - j + 1 + isave = mask(I,j) + mask(I,j)=mask(I,jt) + mask(I,jt) = isave + enddo + enddo + +! Data begins at dateline. NCEP standard is Greenwich. + + do j=1,jmn + do I=1,imn/2 + it=imn/2 + i + isave = mask(i,J) + mask(i,J)=mask(it,J) + mask(it,J) = isave + enddo + enddo + + end subroutine transpose_mask + +!> Compute spherical angle. +!! +!! @param[in] v1 Vector 1. +!! @param[in] v2 Vector 2. +!! @param[in] v3 Vector 3. +!! @return spherical_angle Spherical Angle. +!! @author GFDL programmer + + function spherical_angle(v1, v2, v3) + + implicit none + + real :: spherical_angle + + real, parameter :: EPSLN30 = 1.e-30 + + real, intent(in) :: v1(3), v2(3), v3(3) + + real :: px, py, pz, qx, qy, qz, ddd + +! vector product between v1 and v2 + + px = v1(2)*v2(3) - v1(3)*v2(2) + py = v1(3)*v2(1) - v1(1)*v2(3) + pz = v1(1)*v2(2) - v1(2)*v2(1) + +! vector product between v1 and v3 + + qx = v1(2)*v3(3) - v1(3)*v3(2); + qy = v1(3)*v3(1) - v1(1)*v3(3); + qz = v1(1)*v3(2) - v1(2)*v3(1); + + ddd = (px*px+py*py+pz*pz)*(qx*qx+qy*qy+qz*qz); + if ( ddd <= 0.0 ) then + spherical_angle = 0. + else + ddd = (px*qx+py*qy+pz*qz) / sqrt(ddd); + if( abs(ddd-1) < EPSLN30 ) ddd = 1; + if( abs(ddd+1) < EPSLN30 ) ddd = -1; + if ( ddd>1. .or. ddd<-1. ) then + !FIX to correctly handle co-linear points (angle near pi or 0) */ + if (ddd < 0.) then + spherical_angle = PI + else + spherical_angle = 0. + endif + else + spherical_angle = acos( ddd ) + endif + endif + + end function spherical_angle + +!> Get the date/time from the system clock. +!! +!! @return timef +!! @author Mark Iredell + + real function timef() + + implicit none + + character(8) :: date + character(10) :: time + character(5) :: zone + integer,dimension(8) :: values + integer :: total + real :: elapsed + + call date_and_time(date,time,zone,values) + total=(3600*values(5)) + (60*values(6))+values(7) + elapsed=float(total) + (1.0e-3*float(values(8))) + timef=elapsed + + end function timef + end module orog_utils From e51a6dc454558b0ab48262afadc82bcfd9d71824 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Mon, 16 Sep 2024 14:14:19 -0500 Subject: [PATCH 37/54] Move 'transpose_orog' and 'inside_a_polygon' to new module orog_utils.F90. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 137 +----------------- .../orog_mask_tools.fd/orog.fd/orog_utils.F90 | 135 ++++++++++++++++- 2 files changed, 141 insertions(+), 131 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 6795dfa9f..510d249f5 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -514,6 +514,7 @@ END SUBROUTINE get_index !! @author GFDL Programmer SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, 1 IM,JM,IMN,JMN,lon_c,lat_c) + use orog_utils, only : inside_a_polygon implicit none real, parameter :: D2R = 3.14159265358979/180. integer, parameter :: MAXSUM=20000000 @@ -529,7 +530,6 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, integer ilist(IMN) real DELXN,XNSUM,XLAND,XWATR,XL1,XS1,XW1 real XNSUM_ALL,XLAND_ALL,XWATR_ALL - logical inside_a_polygon C print *,'- CREATE LANDMASK AND LAND FRACTION.' C---- GLOBAL XLAT AND XLON ( DEGREE ) @@ -643,6 +643,7 @@ END SUBROUTINE MAKE_MASK !! @author GFDL Programmer SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, 1 IM,JM,IMN,JMN,lon_c,lat_c,lake_frac,land_frac) + use orog_utils, only : inside_a_polygon implicit none real, parameter :: D2R = 3.14159265358979/180. integer, parameter :: MAXSUM=20000000 @@ -662,7 +663,6 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, real DELXN,XNSUM,XLAND,XWATR,XL1,XS1,XW1,XW2,XW4 real XNSUM_ALL,XLAND_ALL,XWATR_ALL,HEIGHT_ALL real XL1_ALL,XS1_ALL,XW1_ALL,XW2_ALL,XW4_ALL - logical inside_a_polygon C print*,'- CREATE OROGRAPHY AND CONVEXITY.' allocate(hgt_1d(MAXSUM)) @@ -864,6 +864,7 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, C C=== PC: principal coordinates of each Z avg orog box for L&M C + use orog_utils, only : inside_a_polygon implicit none real, parameter :: REARTH=6.3712E+6 real, parameter :: D2R = 3.14159265358979/180. @@ -882,7 +883,6 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, real LONO_RAD(4), LATO_RAD(4) integer i,j,i1,j1,i2,jst,jen,numx,i0,ip1,ijax integer ilist(IMN) - logical inside_a_polygon LOGICAL DEBUG C=== DATA DEBUG/.TRUE./ DATA DEBUG/.FALSE./ @@ -1123,7 +1123,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, 1 ORO,oro1,XNSUM,XNSUM1,XNSUM2,XNSUM3,XNSUM4, 2 IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t,dx,dy, 3 is_south_pole,is_north_pole ) - use orog_utils, only : get_lat_angle, get_lon_angle + use orog_utils, only : get_lat_angle, get_lon_angle, + & inside_a_polygon implicit none real, parameter :: MISSING_VALUE = -9999. real, parameter :: D2R = 3.14159265358979/180. @@ -1146,7 +1147,6 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, real LONO_RAD(4), LATO_RAD(4) real DELXN,HC,HEIGHT,XNPU,XNPD,T integer NS0,NS1,NS2,NS3,NS4,NS5,NS6 - logical inside_a_polygon real lon,lat,dlon,dlat,dlat_old real lon1,lat1,lon2,lat2 real xnsum11,xnsum12,xnsum21,xnsum22 @@ -1512,6 +1512,9 @@ END SUBROUTINE MAKEOA2 !! @param[out] glob The orography data. !! @author Jordan Alpert NOAA/EMC subroutine read_global_orog(imn,jmn,glob) + + use orog_utils, only : transpose_orog + implicit none include 'netcdf.inc' @@ -1541,88 +1544,6 @@ subroutine read_global_orog(imn,jmn,glob) return end subroutine read_global_orog -!> Check if a point is inside a polygon. -!! -!! @param[in] lon1 Longitude of the point to check. -!! @param[in] lat1 Latitude of the point to check. -!! @param[in] npts Number of polygon vertices. -!! @param[in] lon2 Longitude of the polygon vertices. -!! @param[in] lat2 Latitude of the polygon vertices. -!! @return inside_a_polygon When true, point is within -!! the polygon. -!! @author GFDL programmer - FUNCTION inside_a_polygon(lon1, lat1, npts, lon2, lat2) - use orog_utils, only : latlon2xyz, spherical_angle - implicit none - real, parameter :: EPSLN10 = 1.e-10 - real, parameter :: EPSLN8 = 1.e-8 - real, parameter :: PI=3.1415926535897931 - real, parameter :: RANGE_CHECK_CRITERIA=0.05 - real :: anglesum, angle - integer i, ip1 - real lon1, lat1 - integer npts - real lon2(npts), lat2(npts) - real x2(npts), y2(npts), z2(npts) - real lon1_1d(1), lat1_1d(1) - real x1(1), y1(1), z1(1) - real pnt0(3),pnt1(3),pnt2(3) - logical inside_a_polygon - real max_x2,min_x2,max_y2,min_y2,max_z2,min_z2 - !first convert to cartesian grid */ - call latlon2xyz(npts,lon2, lat2, x2, y2, z2); - lon1_1d(1) = lon1 - lat1_1d(1) = lat1 - call latlon2xyz(1,lon1_1d, lat1_1d, x1, y1, z1); - inside_a_polygon = .false. - max_x2 = maxval(x2) - if( x1(1) > max_x2+RANGE_CHECK_CRITERIA ) return - min_x2 = minval(x2) - if( x1(1)+RANGE_CHECK_CRITERIA < min_x2 ) return - max_y2 = maxval(y2) - if( y1(1) > max_y2+RANGE_CHECK_CRITERIA ) return - min_y2 = minval(y2) - if( y1(1)+RANGE_CHECK_CRITERIA < min_y2 ) return - max_z2 = maxval(z2) - if( z1(1) > max_z2+RANGE_CHECK_CRITERIA ) return - min_z2 = minval(z2) - if( z1(1)+RANGE_CHECK_CRITERIA < min_z2 ) return - - pnt0(1) = x1(1) - pnt0(2) = y1(1) - pnt0(3) = z1(1) - - anglesum = 0; - do i = 1, npts - if(abs(x1(1)-x2(i)) < EPSLN10 .and. - & abs(y1(1)-y2(i)) < EPSLN10 .and. - & abs(z1(1)-z2(i)) < EPSLN10 ) then ! same as the corner point - inside_a_polygon = .true. - return - endif - ip1 = i+1 - if(ip1>npts) ip1 = 1 - pnt1(1) = x2(i) - pnt1(2) = y2(i) - pnt1(3) = z2(i) - pnt2(1) = x2(ip1) - pnt2(2) = y2(ip1) - pnt2(3) = z2(ip1) - - angle = spherical_angle(pnt0, pnt2, pnt1); - anglesum = anglesum + angle - enddo - - if(abs(anglesum-2*PI) < EPSLN8) then - inside_a_polygon = .true. - else - inside_a_polygon = .false. - endif - - return - - end function inside_a_polygon - !> Count the number of high-resolution orography points that !! are higher than the model grid box average orography height. !! @@ -2039,48 +1960,6 @@ subroutine find_nearest_pole_points(i_north_pole, j_north_pole, end subroutine find_nearest_pole_points -!> Transpose the global orography data by flipping -!! the poles and moving the starting longitude to -!! Greenwich. -!! -!! @param[in] imn i-dimension of orography data. -!! @param[in] jmn j-dimension of orography data. -!! @param[inout] glob The global orography data. -!! @author G. Gayno - subroutine transpose_orog(imn, jmn, glob) - - implicit none - - integer, intent(in) :: imn, jmn - integer(2), intent(inout) :: glob(imn,jmn) - - integer :: i, j, it, jt - integer(2) :: i2save - -! Transpose from S to N to the NCEP standard N to S. - - do j=1,jmn/2 - do I=1,imn - jt=jmn - j + 1 - i2save = glob(I,j) - glob(I,j)=glob(I,jt) - glob(I,jt) = i2save - enddo - enddo - -! Data begins at dateline. NCEP standard is Greenwich. - - do j=1,jmn - do I=1,imn/2 - it=imn/2 + i - i2save = glob(i,J) - glob(i,J)=glob(it,J) - glob(it,J) = i2save - enddo - enddo - - end subroutine transpose_orog - !> Read input global 30-arc second land mask data. !! !! @param[in] imn i-dimension of orography data. diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 index c388aa8a8..29cab9fba 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -16,13 +16,13 @@ module orog_utils real, parameter :: rad2deg = 180./3.14159265358979 real, parameter :: deg2rad = 3.14159265358979/180. - public :: latlon2xyz public :: minmax public :: get_lat_angle public :: get_lon_angle public :: timef + public :: transpose_orog public :: transpose_mask - public :: spherical_angle + public :: inside_a_polygon contains @@ -199,6 +199,49 @@ subroutine transpose_mask(imn, jmn, mask) end subroutine transpose_mask +!> Transpose the global orography data by flipping +!! the poles and moving the starting longitude to +!! Greenwich. +!! +!! @param[in] imn i-dimension of orography data. +!! @param[in] jmn j-dimension of orography data. +!! @param[inout] glob The global orography data. +!! @author G. Gayno + + subroutine transpose_orog(imn, jmn, glob) + + implicit none + + integer, intent(in) :: imn, jmn + integer(2), intent(inout) :: glob(imn,jmn) + + integer :: i, j, it, jt + integer(2) :: i2save + +! Transpose from S to N to the NCEP standard N to S. + + do j=1,jmn/2 + do I=1,imn + jt=jmn - j + 1 + i2save = glob(I,j) + glob(I,j)=glob(I,jt) + glob(I,jt) = i2save + enddo + enddo + +! Data begins at dateline. NCEP standard is Greenwich. + + do j=1,jmn + do I=1,imn/2 + it=imn/2 + i + i2save = glob(i,J) + glob(i,J)=glob(it,J) + glob(it,J) = i2save + enddo + enddo + + end subroutine transpose_orog + !> Compute spherical angle. !! !! @param[in] v1 Vector 1. @@ -252,6 +295,94 @@ function spherical_angle(v1, v2, v3) end function spherical_angle +!> Check if a point is inside a polygon. +!! +!! @param[in] lon1 Longitude of the point to check. +!! @param[in] lat1 Latitude of the point to check. +!! @param[in] npts Number of polygon vertices. +!! @param[in] lon2 Longitude of the polygon vertices. +!! @param[in] lat2 Latitude of the polygon vertices. +!! @return inside_a_polygon When true, point is within +!! the polygon. +!! @author GFDL programmer + + function inside_a_polygon(lon1, lat1, npts, lon2, lat2) + + implicit none + + logical inside_a_polygon + + real, parameter :: EPSLN10 = 1.e-10 + real, parameter :: EPSLN8 = 1.e-8 + real, parameter :: RANGE_CHECK_CRITERIA=0.05 + + integer, intent(in) :: npts + + real, intent(in) :: lon1, lat1 + real, intent(in) :: lon2(npts), lat2(npts) + + integer :: i, ip1 + + real :: anglesum, angle + real :: x2(npts), y2(npts), z2(npts) + real :: lon1_1d(1), lat1_1d(1) + real :: x1(1), y1(1), z1(1) + real :: pnt0(3),pnt1(3),pnt2(3) + real :: max_x2,min_x2,max_y2,min_y2,max_z2,min_z2 + +! first convert to cartesian grid. + + call latlon2xyz(npts,lon2, lat2, x2, y2, z2); + lon1_1d(1) = lon1 + lat1_1d(1) = lat1 + call latlon2xyz(1,lon1_1d, lat1_1d, x1, y1, z1); + inside_a_polygon = .false. + max_x2 = maxval(x2) + if( x1(1) > max_x2+RANGE_CHECK_CRITERIA ) return + min_x2 = minval(x2) + if( x1(1)+RANGE_CHECK_CRITERIA < min_x2 ) return + max_y2 = maxval(y2) + if( y1(1) > max_y2+RANGE_CHECK_CRITERIA ) return + min_y2 = minval(y2) + if( y1(1)+RANGE_CHECK_CRITERIA < min_y2 ) return + max_z2 = maxval(z2) + if( z1(1) > max_z2+RANGE_CHECK_CRITERIA ) return + min_z2 = minval(z2) + if( z1(1)+RANGE_CHECK_CRITERIA < min_z2 ) return + + pnt0(1) = x1(1) + pnt0(2) = y1(1) + pnt0(3) = z1(1) + + anglesum = 0 + + do i = 1, npts + if(abs(x1(1)-x2(i)) < EPSLN10 .and. & + abs(y1(1)-y2(i)) < EPSLN10 .and. & + abs(z1(1)-z2(i)) < EPSLN10 ) then ! same as the corner point + inside_a_polygon = .true. + return + endif + ip1 = i+1 + if(ip1>npts) ip1 = 1 + pnt1(1) = x2(i) + pnt1(2) = y2(i) + pnt1(3) = z2(i) + pnt2(1) = x2(ip1) + pnt2(2) = y2(ip1) + pnt2(3) = z2(ip1) + angle = spherical_angle(pnt0, pnt2, pnt1); + anglesum = anglesum + angle + enddo + + if(abs(anglesum-2*PI) < EPSLN8) then + inside_a_polygon = .true. + else + inside_a_polygon = .false. + endif + + end function inside_a_polygon + !> Get the date/time from the system clock. !! !! @return timef From ddc2d1c1441701df3797b52dda8488698f47a0f8 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Mon, 16 Sep 2024 15:00:31 -0500 Subject: [PATCH 38/54] Move 'find_poles' and 'find_nearest_pole_points' to orog_utils.F90. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 148 ----------------- sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 | 2 + .../orog_mask_tools.fd/orog.fd/orog_utils.F90 | 155 ++++++++++++++++++ 3 files changed, 157 insertions(+), 148 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 510d249f5..730f00a39 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -1812,154 +1812,6 @@ subroutine get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN, end subroutine get_xnsum3 -!> Find the point on the model grid tile closest to the -!! north and south pole. -!! -!! @param[in] geolat Latitude on the supergrid. -!! @param[in] nx i-dimension of the supergrid. -!! @param[in] ny j-dimension of the supergrid. -!! @param[out] i_north_pole 'i' index of north pole. '0' if -!! pole is outside of grid. -!! @param[out] j_north_pole 'j' index of north pole. '0' if -!! pole is outside of grid. -!! @param[out] i_south_pole 'i' index of south pole. '0' if -!! pole is outside of grid. -!! @param[out] j_south_pole 'j' index of south pole. '0' if -!! pole is outside of grid. -!! @author GFDL Programmer - subroutine find_poles(geolat, nx, ny, i_north_pole, j_north_pole, - & i_south_pole, j_south_pole) - - implicit none - - integer, intent(in) :: nx, ny - - real, intent(in) :: geolat(nx+1,ny+1) - - integer, intent(out) :: i_north_pole, j_north_pole - integer, intent(out) :: i_south_pole, j_south_pole - - integer :: i, j - - real :: maxlat, minlat - - print*,'- CHECK IF THE TILE CONTAINS A POLE.' - !--- figure out pole location. - maxlat = -90 - minlat = 90 - i_north_pole = 0 - j_north_pole = 0 - i_south_pole = 0 - j_south_pole = 0 - do j = 1, ny+1; do i = 1, nx+1 - if( geolat(i,j) > maxlat ) then - i_north_pole=i - j_north_pole=j - maxlat = geolat(i,j) - endif - if( geolat(i,j) < minlat ) then - i_south_pole=i - j_south_pole=j - minlat = geolat(i,j) - endif - enddo ; enddo - !--- only when maxlat is close to 90. the point is north pole - if(maxlat < 89.9 ) then - i_north_pole = 0 - j_north_pole = 0 - endif - if(minlat > -89.9 ) then - i_south_pole = 0 - j_south_pole = 0 - endif - print*, "- MINLAT=", minlat, "MAXLAT=", maxlat - print*, "- NORTH POLE SUPERGRID INDEX IS ", - & i_north_pole, j_north_pole - print*, "- SOUTH POLE SUPERGRID INDEX IS ", - & i_south_pole, j_south_pole - - end subroutine find_poles - -!> Find the point on the model grid tile closest to the -!! north and south pole. -!! -!! @param[in] i_north_pole 'i' index of north pole. '0' if -!! pole is outside of grid. -!! @param[in] j_north_pole 'j' index of north pole. '0' if -!! pole is outside of grid. -!! @param[in] i_south_pole 'i' index of south pole. '0' if -!! pole is outside of grid. -!! @param[in] j_south_pole 'j' index of south pole. '0' if -!! pole is outside of grid. -!! @param[in] im i-dimension of model tile -!! @param[in] jm j-dimension of model tile -!! @param[out] is_north_pole 'true' for points surrounding the north pole. -!! @param[out] is_south_pole 'true' for points surrounding the south pole. -!! @author GFDL Programmer - subroutine find_nearest_pole_points(i_north_pole, j_north_pole, - & i_south_pole, j_south_pole, im, jm, is_north_pole, - & is_south_pole) - - implicit none - - integer, intent(in) :: im, jm - integer, intent(in) :: i_north_pole, j_north_pole - integer, intent(in) :: i_south_pole, j_south_pole - - logical, intent(out) :: is_north_pole(im,jm) - logical, intent(out) :: is_south_pole(im,jm) - - integer :: i, j - - print*,'- FIND NEAREST POLE POINTS.' - - is_north_pole=.false. - is_south_pole=.false. - - if(i_south_pole >0 .and. j_south_pole > 0) then - if(mod(i_south_pole,2)==0) then ! stretched grid - do j = 1, JM; do i = 1, IM - if(i==i_south_pole/2 .and. (j==j_south_pole/2 - & .or. j==j_south_pole/2+1) ) then - is_south_pole(i,j) = .true. - print*, "- SOUTH POLE AT I,J= ", i, j - endif - enddo; enddo - else - do j = 1, JM; do i = 1, IM - if((i==i_south_pole/2 .or. i==i_south_pole/2+1) - & .and. (j==j_south_pole/2 .or. - & j==j_south_pole/2+1) ) then - is_south_pole(i,j) = .true. - print*, "- SOUTH POLE AT I,J= ", i, j - endif - enddo; enddo - endif - endif - - if(i_north_pole >0 .and. j_north_pole > 0) then - if(mod(i_north_pole,2)==0) then ! stretched grid - do j = 1, JM; do i = 1, IM - if(i==i_north_pole/2 .and. (j==j_north_pole/2 .or. - & j==j_north_pole/2+1) ) then - is_north_pole(i,j) = .true. - print*, "- NORTH POLE AT I,J= ", i, j - endif - enddo; enddo - else - do j = 1, JM; do i = 1, IM - if((i==i_north_pole/2 .or. i==i_north_pole/2+1) - & .and. (j==j_north_pole/2 .or. - & j==j_north_pole/2+1) ) then - is_north_pole(i,j) = .true. - print*, "- NORTH POLE AT I,J= ", i, j - endif - enddo; enddo - endif - endif - - end subroutine find_nearest_pole_points - !> Read input global 30-arc second land mask data. !! !! @param[in] imn i-dimension of orography data. diff --git a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 index a62080baa..46a354e6d 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 @@ -430,6 +430,8 @@ subroutine read_mdl_grid_file(mdl_grid_file, im, jm, & geolon, geolon_c, geolat, geolat_c, dx, dy, & is_north_pole, is_south_pole) + use orog_utils, only : find_poles, find_nearest_pole_points + implicit none include "netcdf.inc" diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 index 29cab9fba..ad15811fc 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -16,6 +16,8 @@ module orog_utils real, parameter :: rad2deg = 180./3.14159265358979 real, parameter :: deg2rad = 3.14159265358979/180. + public :: find_nearest_pole_points + public :: find_poles public :: minmax public :: get_lat_angle public :: get_lon_angle @@ -383,6 +385,159 @@ function inside_a_polygon(lon1, lat1, npts, lon2, lat2) end function inside_a_polygon +!> Find the point on the model grid tile closest to the +!! north and south pole. +!! +!! @param[in] geolat Latitude on the supergrid. +!! @param[in] nx i-dimension of the supergrid. +!! @param[in] ny j-dimension of the supergrid. +!! @param[out] i_north_pole 'i' index of north pole. '0' if +!! pole is outside of grid. +!! @param[out] j_north_pole 'j' index of north pole. '0' if +!! pole is outside of grid. +!! @param[out] i_south_pole 'i' index of south pole. '0' if +!! pole is outside of grid. +!! @param[out] j_south_pole 'j' index of south pole. '0' if +!! pole is outside of grid. +!! @author GFDL Programmer + subroutine find_poles(geolat, nx, ny, i_north_pole, j_north_pole, & + i_south_pole, j_south_pole) + + implicit none + + integer, intent(in) :: nx, ny + + real, intent(in) :: geolat(nx+1,ny+1) + + integer, intent(out) :: i_north_pole, j_north_pole + integer, intent(out) :: i_south_pole, j_south_pole + + integer :: i, j + + real :: maxlat, minlat + + print*,'- CHECK IF THE TILE CONTAINS A POLE.' + +!--- figure out pole location. + + maxlat = -90 + minlat = 90 + i_north_pole = 0 + j_north_pole = 0 + i_south_pole = 0 + j_south_pole = 0 + do j = 1, ny+1; do i = 1, nx+1 + if( geolat(i,j) > maxlat ) then + i_north_pole=i + j_north_pole=j + maxlat = geolat(i,j) + endif + if( geolat(i,j) < minlat ) then + i_south_pole=i + j_south_pole=j + minlat = geolat(i,j) + endif + enddo ; enddo + +!--- only when maxlat is close to 90. the point is north pole + + if(maxlat < 89.9 ) then + i_north_pole = 0 + j_north_pole = 0 + endif + if(minlat > -89.9 ) then + i_south_pole = 0 + j_south_pole = 0 + endif + + print*, "- MINLAT=", minlat, "MAXLAT=", maxlat + print*, "- NORTH POLE SUPERGRID INDEX IS ", & + i_north_pole, j_north_pole + print*, "- SOUTH POLE SUPERGRID INDEX IS ", & + i_south_pole, j_south_pole + + end subroutine find_poles + +!> Find the point on the model grid tile closest to the +!! north and south pole. +!! +!! @param[in] i_north_pole 'i' index of north pole. '0' if +!! pole is outside of grid. +!! @param[in] j_north_pole 'j' index of north pole. '0' if +!! pole is outside of grid. +!! @param[in] i_south_pole 'i' index of south pole. '0' if +!! pole is outside of grid. +!! @param[in] j_south_pole 'j' index of south pole. '0' if +!! pole is outside of grid. +!! @param[in] im i-dimension of model tile +!! @param[in] jm j-dimension of model tile +!! @param[out] is_north_pole 'true' for points surrounding the north pole. +!! @param[out] is_south_pole 'true' for points surrounding the south pole. +!! @author GFDL Programmer + + subroutine find_nearest_pole_points(i_north_pole, j_north_pole, & + i_south_pole, j_south_pole, im, jm, is_north_pole, & + is_south_pole) + + implicit none + + integer, intent(in) :: im, jm + integer, intent(in) :: i_north_pole, j_north_pole + integer, intent(in) :: i_south_pole, j_south_pole + + logical, intent(out) :: is_north_pole(im,jm) + logical, intent(out) :: is_south_pole(im,jm) + + integer :: i, j + + print*,'- FIND NEAREST POLE POINTS.' + + is_north_pole=.false. + is_south_pole=.false. + + if(i_south_pole >0 .and. j_south_pole > 0) then + if(mod(i_south_pole,2)==0) then ! stretched grid + do j = 1, JM; do i = 1, IM + if(i==i_south_pole/2 .and. (j==j_south_pole/2 & + .or. j==j_south_pole/2+1) ) then + is_south_pole(i,j) = .true. + print*, "- SOUTH POLE AT I,J= ", i, j + endif + enddo; enddo + else + do j = 1, JM; do i = 1, IM + if((i==i_south_pole/2 .or. i==i_south_pole/2+1) & + .and. (j==j_south_pole/2 .or. & + j==j_south_pole/2+1) ) then + is_south_pole(i,j) = .true. + print*, "- SOUTH POLE AT I,J= ", i, j + endif + enddo; enddo + endif + endif + + if(i_north_pole >0 .and. j_north_pole > 0) then + if(mod(i_north_pole,2)==0) then ! stretched grid + do j = 1, JM; do i = 1, IM + if(i==i_north_pole/2 .and. (j==j_north_pole/2 .or. & + j==j_north_pole/2+1) ) then + is_north_pole(i,j) = .true. + print*, "- NORTH POLE AT I,J= ", i, j + endif + enddo; enddo + else + do j = 1, JM; do i = 1, IM + if((i==i_north_pole/2 .or. i==i_north_pole/2+1) & + .and. (j==j_north_pole/2 .or. & + j==j_north_pole/2+1) ) then + is_north_pole(i,j) = .true. + print*, "- NORTH POLE AT I,J= ", i, j + endif + enddo; enddo + endif + endif + + end subroutine find_nearest_pole_points !> Get the date/time from the system clock. !! !! @return timef From ddf02d972efa7a34de30b5dbcc71fa067df0f870 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 17 Sep 2024 07:09:07 -0500 Subject: [PATCH 39/54] Make routine 'latlon2xyz' public so it may be used by the unit tests. Fixes #970. --- sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 index ad15811fc..92d7f447a 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -18,13 +18,14 @@ module orog_utils public :: find_nearest_pole_points public :: find_poles - public :: minmax public :: get_lat_angle public :: get_lon_angle + public :: inside_a_polygon + public :: latlon2xyz + public :: minmax public :: timef public :: transpose_orog public :: transpose_mask - public :: inside_a_polygon contains From 653e704b5612104e5d54def8911545c3650e0e96 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 17 Sep 2024 08:30:09 -0500 Subject: [PATCH 40/54] Move routine 'remove_isolated_pts' to the orog_utils module. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 145 +---------------- .../orog_mask_tools.fd/orog.fd/orog_utils.F90 | 147 ++++++++++++++++++ 2 files changed, 148 insertions(+), 144 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 730f00a39..2a5d9e189 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -122,7 +122,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, & OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) - use orog_utils, only : minmax, timef + use orog_utils, only : minmax, timef, remove_isolated_pts implicit none include 'netcdf.inc' @@ -1907,146 +1907,3 @@ subroutine qc_orog_by_ramp(imn, jmn, zavg, zslm) deallocate (GICE) end subroutine qc_orog_by_ramp - -!> Remove isolated model points. -!! -!! @param[in] im 'i' dimension of a model grid tile. -!! @param[in] jm 'j' dimension of a model grid tile. -!! @param[inout] slm Land-mask on the model tile. -!! @param[inout] oro Orography on the model tile. -!! @param[inout] var Standard deviation of orography on the model tile. -!! @param[inout] var4 Convexity on the model tile. -!! @param[inout] oa Orographic asymmetry on the model tile. -!! @param[inout] ol Orographic length scale on the model tile. -!! @author Jordan Alpert NOAA/EMC - subroutine remove_isolated_pts(im,jm,slm,oro,var,var4,oa,ol) - - implicit none - - integer, intent(in) :: im, jm - - real, intent(inout) :: slm(im,jm) - real, intent(inout) :: oro(im,jm) - real, intent(inout) :: var(im,jm) - real, intent(inout) :: var4(im,jm) - real, intent(inout) :: oa(im,jm,4) - real, intent(inout) :: ol(im,jm,4) - - integer :: i, j, jn, js, k - integer :: iw, ie, wgta, is, ise - integer :: in, ine, inw, isw - - real :: slma, oroa, vara, var4a, xn, xs - real, allocatable :: oaa(:), ola(:) - -! REMOVE ISOLATED POINTS - - print*,"- REMOVE ISOLATED POINTS." - - allocate (oaa(4),ola(4)) - - iso_loop : DO J=2,JM-1 - JN=J-1 - JS=J+1 - DO I=1,IM - IW=MOD(I+IM-2,IM)+1 - IE=MOD(I,IM)+1 - SLMA=SLM(IW,J)+SLM(IE,J) - OROA=ORO(IW,J)+ORO(IE,J) - VARA=VAR(IW,J)+VAR(IE,J) - VAR4A=VAR4(IW,J)+VAR4(IE,J) - DO K=1,4 - OAA(K)=OA(IW,J,K)+OA(IE,J,K) -! --- (*j*) fix typo: - OLA(K)=OL(IW,J,K)+OL(IE,J,K) - ENDDO - WGTA=2 - XN=(I-1)+1 - IF(ABS(XN-NINT(XN)).LT.1.E-2) THEN - IN=MOD(NINT(XN)-1,IM)+1 - INW=MOD(IN+IM-2,IM)+1 - INE=MOD(IN,IM)+1 - SLMA=SLMA+SLM(INW,JN)+SLM(IN,JN)+SLM(INE,JN) - OROA=OROA+ORO(INW,JN)+ORO(IN,JN)+ORO(INE,JN) - VARA=VARA+VAR(INW,JN)+VAR(IN,JN)+VAR(INE,JN) - VAR4A=VAR4A+VAR4(INW,JN)+VAR4(IN,JN)+VAR4(INE,JN) - DO K=1,4 - OAA(K)=OAA(K)+OA(INW,JN,K)+OA(IN,JN,K)+OA(INE,JN,K) - OLA(K)=OLA(K)+OL(INW,JN,K)+OL(IN,JN,K)+OL(INE,JN,K) - ENDDO - WGTA=WGTA+3 - ELSE - INW=INT(XN) - INE=MOD(INW,IM)+1 - SLMA=SLMA+SLM(INW,JN)+SLM(INE,JN) - OROA=OROA+ORO(INW,JN)+ORO(INE,JN) - VARA=VARA+VAR(INW,JN)+VAR(INE,JN) - VAR4A=VAR4A+VAR4(INW,JN)+VAR4(INE,JN) - DO K=1,4 - OAA(K)=OAA(K)+OA(INW,JN,K)+OA(INE,JN,K) - OLA(K)=OLA(K)+OL(INW,JN,K)+OL(INE,JN,K) - ENDDO - WGTA=WGTA+2 - ENDIF - XS=(I-1)+1 - IF(ABS(XS-NINT(XS)).LT.1.E-2) THEN - IS=MOD(NINT(XS)-1,IM)+1 - ISW=MOD(IS+IM-2,IM)+1 - ISE=MOD(IS,IM)+1 - SLMA=SLMA+SLM(ISW,JS)+SLM(IS,JS)+SLM(ISE,JS) - OROA=OROA+ORO(ISW,JS)+ORO(IS,JS)+ORO(ISE,JS) - VARA=VARA+VAR(ISW,JS)+VAR(IS,JS)+VAR(ISE,JS) - VAR4A=VAR4A+VAR4(ISW,JS)+VAR4(IS,JS)+VAR4(ISE,JS) - DO K=1,4 - OAA(K)=OAA(K)+OA(ISW,JS,K)+OA(IS,JS,K)+OA(ISE,JS,K) - OLA(K)=OLA(K)+OL(ISW,JS,K)+OL(IS,JS,K)+OL(ISE,JS,K) - ENDDO - WGTA=WGTA+3 - ELSE - ISW=INT(XS) - ISE=MOD(ISW,IM)+1 - SLMA=SLMA+SLM(ISW,JS)+SLM(ISE,JS) - OROA=OROA+ORO(ISW,JS)+ORO(ISE,JS) - VARA=VARA+VAR(ISW,JS)+VAR(ISE,JS) - VAR4A=VAR4A+VAR4(ISW,JS)+VAR4(ISE,JS) - DO K=1,4 - OAA(K)=OAA(K)+OA(ISW,JS,K)+OA(ISE,JS,K) - OLA(K)=OLA(K)+OL(ISW,JS,K)+OL(ISE,JS,K) - ENDDO - WGTA=WGTA+2 - ENDIF - OROA=OROA/WGTA - VARA=VARA/WGTA - VAR4A=VAR4A/WGTA - DO K=1,4 - OAA(K)=OAA(K)/WGTA - OLA(K)=OLA(K)/WGTA - ENDDO - IF(SLM(I,J).EQ.0..AND.SLMA.EQ.WGTA) THEN - PRINT '(" - SEA ",2F8.0," MODIFIED TO LAND",2F8.0, - & " AT ",2I8)',ORO(I,J),VAR(I,J),OROA,VARA,I,J - SLM(I,J)=1. - ORO(I,J)=OROA - VAR(I,J)=VARA - VAR4(I,J)=VAR4A - DO K=1,4 - OA(I,J,K)=OAA(K) - OL(I,J,K)=OLA(K) - ENDDO - ELSEIF(SLM(I,J).EQ.1..AND.SLMA.EQ.0.) THEN - PRINT '(" - LAND",2F8.0," MODIFIED TO SEA ",2F8.0, - & " AT ",2I8)',ORO(I,J),VAR(I,J),OROA,VARA,I,J - SLM(I,J)=0. - ORO(I,J)=OROA - VAR(I,J)=VARA - VAR4(I,J)=VAR4A - DO K=1,4 - OA(I,J,K)=OAA(K) - OL(I,J,K)=OLA(K) - ENDDO - ENDIF - ENDDO - ENDDO iso_loop - - deallocate (oaa,ola) - end subroutine remove_isolated_pts diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 index 92d7f447a..1ee3ba2b1 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -23,6 +23,7 @@ module orog_utils public :: inside_a_polygon public :: latlon2xyz public :: minmax + public :: remove_isolated_pts public :: timef public :: transpose_orog public :: transpose_mask @@ -539,6 +540,152 @@ subroutine find_nearest_pole_points(i_north_pole, j_north_pole, & endif end subroutine find_nearest_pole_points + +!> Remove isolated model points. +!! +!! @param[in] im 'i' dimension of a model grid tile. +!! @param[in] jm 'j' dimension of a model grid tile. +!! @param[inout] slm Land-mask on the model tile. +!! @param[inout] oro Orography on the model tile. +!! @param[inout] var Standard deviation of orography on the model tile. +!! @param[inout] var4 Convexity on the model tile. +!! @param[inout] oa Orographic asymmetry on the model tile. +!! @param[inout] ol Orographic length scale on the model tile. +!! @author Jordan Alpert NOAA/EMC + + subroutine remove_isolated_pts(im,jm,slm,oro,var,var4,oa,ol) + + implicit none + + integer, intent(in) :: im, jm + + real, intent(inout) :: slm(im,jm) + real, intent(inout) :: oro(im,jm) + real, intent(inout) :: var(im,jm) + real, intent(inout) :: var4(im,jm) + real, intent(inout) :: oa(im,jm,4) + real, intent(inout) :: ol(im,jm,4) + + integer :: i, j, jn, js, k + integer :: iw, ie, wgta, is, ise + integer :: in, ine, inw, isw + + real :: slma, oroa, vara, var4a, xn, xs + real, allocatable :: oaa(:), ola(:) + +! REMOVE ISOLATED POINTS + + print*,"- REMOVE ISOLATED POINTS." + + allocate (oaa(4),ola(4)) + + iso_loop : DO J=2,JM-1 + JN=J-1 + JS=J+1 + i_loop : DO I=1,IM + IW=MOD(I+IM-2,IM)+1 + IE=MOD(I,IM)+1 + SLMA=SLM(IW,J)+SLM(IE,J) + OROA=ORO(IW,J)+ORO(IE,J) + VARA=VAR(IW,J)+VAR(IE,J) + VAR4A=VAR4(IW,J)+VAR4(IE,J) + DO K=1,4 + OAA(K)=OA(IW,J,K)+OA(IE,J,K) +! --- (*j*) fix typo: + OLA(K)=OL(IW,J,K)+OL(IE,J,K) + ENDDO + WGTA=2 + XN=(I-1)+1 + IF(ABS(XN-NINT(XN)).LT.1.E-2) THEN + IN=MOD(NINT(XN)-1,IM)+1 + INW=MOD(IN+IM-2,IM)+1 + INE=MOD(IN,IM)+1 + SLMA=SLMA+SLM(INW,JN)+SLM(IN,JN)+SLM(INE,JN) + OROA=OROA+ORO(INW,JN)+ORO(IN,JN)+ORO(INE,JN) + VARA=VARA+VAR(INW,JN)+VAR(IN,JN)+VAR(INE,JN) + VAR4A=VAR4A+VAR4(INW,JN)+VAR4(IN,JN)+VAR4(INE,JN) + DO K=1,4 + OAA(K)=OAA(K)+OA(INW,JN,K)+OA(IN,JN,K)+OA(INE,JN,K) + OLA(K)=OLA(K)+OL(INW,JN,K)+OL(IN,JN,K)+OL(INE,JN,K) + ENDDO + WGTA=WGTA+3 + ELSE + INW=INT(XN) + INE=MOD(INW,IM)+1 + SLMA=SLMA+SLM(INW,JN)+SLM(INE,JN) + OROA=OROA+ORO(INW,JN)+ORO(INE,JN) + VARA=VARA+VAR(INW,JN)+VAR(INE,JN) + VAR4A=VAR4A+VAR4(INW,JN)+VAR4(INE,JN) + DO K=1,4 + OAA(K)=OAA(K)+OA(INW,JN,K)+OA(INE,JN,K) + OLA(K)=OLA(K)+OL(INW,JN,K)+OL(INE,JN,K) + ENDDO + WGTA=WGTA+2 + ENDIF + XS=(I-1)+1 + IF(ABS(XS-NINT(XS)).LT.1.E-2) THEN + IS=MOD(NINT(XS)-1,IM)+1 + ISW=MOD(IS+IM-2,IM)+1 + ISE=MOD(IS,IM)+1 + SLMA=SLMA+SLM(ISW,JS)+SLM(IS,JS)+SLM(ISE,JS) + OROA=OROA+ORO(ISW,JS)+ORO(IS,JS)+ORO(ISE,JS) + VARA=VARA+VAR(ISW,JS)+VAR(IS,JS)+VAR(ISE,JS) + VAR4A=VAR4A+VAR4(ISW,JS)+VAR4(IS,JS)+VAR4(ISE,JS) + DO K=1,4 + OAA(K)=OAA(K)+OA(ISW,JS,K)+OA(IS,JS,K)+OA(ISE,JS,K) + OLA(K)=OLA(K)+OL(ISW,JS,K)+OL(IS,JS,K)+OL(ISE,JS,K) + ENDDO + WGTA=WGTA+3 + ELSE + ISW=INT(XS) + ISE=MOD(ISW,IM)+1 + SLMA=SLMA+SLM(ISW,JS)+SLM(ISE,JS) + OROA=OROA+ORO(ISW,JS)+ORO(ISE,JS) + VARA=VARA+VAR(ISW,JS)+VAR(ISE,JS) + VAR4A=VAR4A+VAR4(ISW,JS)+VAR4(ISE,JS) + DO K=1,4 + OAA(K)=OAA(K)+OA(ISW,JS,K)+OA(ISE,JS,K) + OLA(K)=OLA(K)+OL(ISW,JS,K)+OL(ISE,JS,K) + ENDDO + WGTA=WGTA+2 + ENDIF + OROA=OROA/WGTA + VARA=VARA/WGTA + VAR4A=VAR4A/WGTA + DO K=1,4 + OAA(K)=OAA(K)/WGTA + OLA(K)=OLA(K)/WGTA + ENDDO + IF(SLM(I,J).EQ.0..AND.SLMA.EQ.WGTA) THEN + PRINT '(" - SEA ",2F8.0," MODIFIED TO LAND",2F8.0, & + " AT ",2I8)',ORO(I,J),VAR(I,J),OROA,VARA,I,J + SLM(I,J)=1. + ORO(I,J)=OROA + VAR(I,J)=VARA + VAR4(I,J)=VAR4A + DO K=1,4 + OA(I,J,K)=OAA(K) + OL(I,J,K)=OLA(K) + ENDDO + ELSEIF(SLM(I,J).EQ.1..AND.SLMA.EQ.0.) THEN + PRINT '(" - LAND",2F8.0," MODIFIED TO SEA ",2F8.0, & + " AT ",2I8)',ORO(I,J),VAR(I,J),OROA,VARA,I,J + SLM(I,J)=0. + ORO(I,J)=OROA + VAR(I,J)=VARA + VAR4(I,J)=VAR4A + DO K=1,4 + OA(I,J,K)=OAA(K) + OL(I,J,K)=OLA(K) + ENDDO + ENDIF + ENDDO i_loop + ENDDO iso_loop + + deallocate (oaa,ola) + + end subroutine remove_isolated_pts + !> Get the date/time from the system clock. !! !! @return timef From 0171cc035d87a018fb1ebc3b6abfa4af6fa8c40c Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 17 Sep 2024 09:17:02 -0500 Subject: [PATCH 41/54] Move routines 'read_global_mask', 'read_global_orog' and 'qc_orog_by_ramp' to netcdf_io.F90. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 135 ------------------ sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 | 135 ++++++++++++++++++ 2 files changed, 135 insertions(+), 135 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 2a5d9e189..78f14ff11 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -1505,45 +1505,6 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, END SUBROUTINE MAKEOA2 -!> Read input global 30-arc second orography data. -!! -!! @param[in] imn i-dimension of orography data. -!! @param[in] jmn j-dimension of orography data. -!! @param[out] glob The orography data. -!! @author Jordan Alpert NOAA/EMC - subroutine read_global_orog(imn,jmn,glob) - - use orog_utils, only : transpose_orog - - implicit none - - include 'netcdf.inc' - - integer, intent(in) :: imn, jmn - integer*2, intent(out) :: glob(imn,jmn) - - integer :: ncid, error, id_var, fsize - - fsize=65536 - - print*,"- OPEN AND READ ./topography.gmted2010.30s.nc" - - error=NF__OPEN("./topography.gmted2010.30s.nc", - & NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Open file topography.gmted2010.30s.nc' ) - error=nf_inq_varid(ncid, 'topo', id_var) - call netcdf_err(error, 'Inquire varid of topo') - error=nf_get_var_int2(ncid, id_var, glob) - call netcdf_err(error, 'Read topo') - error = nf_close(ncid) - - print*,"- MAX/MIN OF OROGRAPHY DATA ",maxval(glob),minval(glob) - - call transpose_orog(imn,jmn,glob) - - return - end subroutine read_global_orog - !> Count the number of high-resolution orography points that !! are higher than the model grid box average orography height. !! @@ -1811,99 +1772,3 @@ subroutine get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN, enddo end subroutine get_xnsum3 - -!> Read input global 30-arc second land mask data. -!! -!! @param[in] imn i-dimension of orography data. -!! @param[in] jmn j-dimension of orography data. -!! @param[out] mask The land mask data. -!! @author G. Gayno NOAA/EMC - subroutine read_global_mask(imn, jmn, mask) - - use orog_utils, only : transpose_mask - - implicit none - - include 'netcdf.inc' - - integer, intent(in) :: imn, jmn - - integer(1), intent(out) :: mask(imn,jmn) - - integer :: ncid, fsize, id_var, error - - fsize = 65536 - - print*,"- OPEN AND READ ./landcover.umd.30s.nc" - - error=NF__OPEN("./landcover.umd.30s.nc",NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Open file landcover.umd.30s.nc' ) - error=nf_inq_varid(ncid, 'land_mask', id_var) - call netcdf_err(error, 'Inquire varid of land_mask') - error=nf_get_var_int1(ncid, id_var, mask) - call netcdf_err(error, 'Inquire data of land_mask') - error = nf_close(ncid) - - call transpose_mask(imn,jmn,mask) - - end subroutine read_global_mask - -!> Quality control the global orography and landmask -!! data over Antarctica using RAMP data. -!! -!! @param[in] imn i-dimension of the global data. -!! @param[in] jmn j-dimension of the global data. -!! @param[inout] zavg The global orography data. -!! @param[inout] zslm The global landmask data. -!! @author G. Gayno - subroutine qc_orog_by_ramp(imn, jmn, zavg, zslm) - - implicit none - - include 'netcdf.inc' - - integer, intent(in) :: imn, jmn - integer, intent(inout) :: zavg(imn,jmn) - integer, intent(inout) :: zslm(imn,jmn) - - integer :: i, j, error, ncid, id_var, fsize - - real(4), allocatable :: gice(:,:) - - fsize = 65536 - - allocate (GICE(IMN+1,3601)) - -! Read 30-sec Antarctica RAMP data. Points scan from South -! to North, and from Greenwich to Greenwich. - - print*,"- OPEN/READ RAMP DATA ./topography.antarctica.ramp.30s.nc" - - error=NF__OPEN("./topography.antarctica.ramp.30s.nc", - & NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Opening RAMP topo file' ) - error=nf_inq_varid(ncid, 'topo', id_var) - call netcdf_err(error, 'Inquire varid of RAMP topo') - error=nf_get_var_real(ncid, id_var, GICE) - call netcdf_err(error, 'Inquire data of RAMP topo') - error = nf_close(ncid) - - print*,"- QC GLOBAL OROGRAPHY DATA WITH RAMP." - -! If RAMP values are valid, replace the global value with the RAMP -! value. Invalid values are less than or equal to 0 (0, -1, or -99). - - do j = 1, 3601 - do i = 1, IMN - if( GICE(i,j) .ne. -99. .and. GICE(i,j) .ne. -1.0 ) then - if ( GICE(i,j) .gt. 0.) then - ZAVG(i,j) = int( GICE(i,j) + 0.5 ) - ZSLM(i,j) = 1 - endif - endif - enddo - enddo - - deallocate (GICE) - - end subroutine qc_orog_by_ramp diff --git a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 index 46a354e6d..fea230b27 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 @@ -519,3 +519,138 @@ subroutine read_mdl_grid_file(mdl_grid_file, im, jm, & deallocate(tmpvar) end subroutine read_mdl_grid_file + +!> Read input global 30-arc second orography data. +!! +!! @param[in] imn i-dimension of orography data. +!! @param[in] jmn j-dimension of orography data. +!! @param[out] glob The orography data. +!! @author Jordan Alpert NOAA/EMC + subroutine read_global_orog(imn,jmn,glob) + + use orog_utils, only : transpose_orog + + implicit none + + include 'netcdf.inc' + + integer, intent(in) :: imn, jmn + integer*2, intent(out) :: glob(imn,jmn) + + integer :: ncid, error, id_var, fsize + + fsize=65536 + + print*,"- OPEN AND READ ./topography.gmted2010.30s.nc" + + error=NF__OPEN("./topography.gmted2010.30s.nc", & + NF_NOWRITE,fsize,ncid) + call netcdf_err(error, 'Open file topography.gmted2010.30s.nc' ) + error=nf_inq_varid(ncid, 'topo', id_var) + call netcdf_err(error, 'Inquire varid of topo') + error=nf_get_var_int2(ncid, id_var, glob) + call netcdf_err(error, 'Read topo') + error = nf_close(ncid) + + print*,"- MAX/MIN OF OROGRAPHY DATA ",maxval(glob),minval(glob) + + call transpose_orog(imn,jmn,glob) + + return + end subroutine read_global_orog + +!> Read input global 30-arc second land mask data. +!! +!! @param[in] imn i-dimension of orography data. +!! @param[in] jmn j-dimension of orography data. +!! @param[out] mask The land mask data. +!! @author G. Gayno NOAA/EMC + subroutine read_global_mask(imn, jmn, mask) + + use orog_utils, only : transpose_mask + + implicit none + + include 'netcdf.inc' + + integer, intent(in) :: imn, jmn + + integer(1), intent(out) :: mask(imn,jmn) + + integer :: ncid, fsize, id_var, error + + fsize = 65536 + + print*,"- OPEN AND READ ./landcover.umd.30s.nc" + + error=NF__OPEN("./landcover.umd.30s.nc",NF_NOWRITE,fsize,ncid) + call netcdf_err(error, 'Open file landcover.umd.30s.nc' ) + error=nf_inq_varid(ncid, 'land_mask', id_var) + call netcdf_err(error, 'Inquire varid of land_mask') + error=nf_get_var_int1(ncid, id_var, mask) + call netcdf_err(error, 'Inquire data of land_mask') + error = nf_close(ncid) + + call transpose_mask(imn,jmn,mask) + + end subroutine read_global_mask + +!> Quality control the global orography and landmask +!! data over Antarctica using RAMP data. +!! +!! @param[in] imn i-dimension of the global data. +!! @param[in] jmn j-dimension of the global data. +!! @param[inout] zavg The global orography data. +!! @param[inout] zslm The global landmask data. +!! @author G. Gayno + subroutine qc_orog_by_ramp(imn, jmn, zavg, zslm) + + implicit none + + include 'netcdf.inc' + + integer, intent(in) :: imn, jmn + integer, intent(inout) :: zavg(imn,jmn) + integer, intent(inout) :: zslm(imn,jmn) + + integer :: i, j, error, ncid, id_var, fsize + + real(4), allocatable :: gice(:,:) + + fsize = 65536 + + allocate (GICE(IMN+1,3601)) + +! Read 30-sec Antarctica RAMP data. Points scan from South +! to North, and from Greenwich to Greenwich. + + print*,"- OPEN/READ RAMP DATA ./topography.antarctica.ramp.30s.nc" + + error=NF__OPEN("./topography.antarctica.ramp.30s.nc", & + NF_NOWRITE,fsize,ncid) + call netcdf_err(error, 'Opening RAMP topo file' ) + error=nf_inq_varid(ncid, 'topo', id_var) + call netcdf_err(error, 'Inquire varid of RAMP topo') + error=nf_get_var_real(ncid, id_var, GICE) + call netcdf_err(error, 'Inquire data of RAMP topo') + error = nf_close(ncid) + + print*,"- QC GLOBAL OROGRAPHY DATA WITH RAMP." + +! If RAMP values are valid, replace the global value with the RAMP +! value. Invalid values are less than or equal to 0 (0, -1, or -99). + + do j = 1, 3601 + do i = 1, IMN + if( GICE(i,j) .ne. -99. .and. GICE(i,j) .ne. -1.0 ) then + if ( GICE(i,j) .gt. 0.) then + ZAVG(i,j) = int( GICE(i,j) + 0.5 ) + ZSLM(i,j) = 1 + endif + endif + enddo + enddo + + deallocate (GICE) + + end subroutine qc_orog_by_ramp From 753a8d74453891054f6443bed7e49168e10d0e54 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 17 Sep 2024 09:52:41 -0500 Subject: [PATCH 42/54] Move routine 'get_index' to module orog_utils. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 103 +----------------- .../orog_mask_tools.fd/orog.fd/orog_utils.F90 | 98 +++++++++++++++++ 2 files changed, 102 insertions(+), 99 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 78f14ff11..69fe52c25 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -404,101 +404,6 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, return END SUBROUTINE TERSUB -!> Determine the location of a cubed-sphere point within -!! the high-resolution orography data. The location is -!! described by the range of i/j indices on the high-res grid. -!! -!! @param[in] imn 'i' dimension of the high-resolution orography -!! data set. -!! @param[in] jmn 'j' dimension of the high-resolution orography -!! data set. -!! @param[in] npts Number of vertices to describe the cubed-sphere point. -!! @param[in] lonO The longitudes of the cubed-sphere vertices. -!! @param[in] latO The latitudes of the cubed-sphere vertices. -!! @param[in] delxn Resolution of the high-resolution orography -!! data set. -!! @param[out] jst Starting 'j' index on the high-resolution grid. -!! @param[out] jen Ending 'j' index on the high-resolution grid. -!! @param[out] ilist List of 'i' indices on the high-resolution grid. -!! @param[out] numx The number of 'i' indices on the high-resolution -!! grid. -!! @author GFDL programmer - SUBROUTINE get_index(IMN,JMN,npts,lonO,latO,DELXN, - & jst,jen,ilist,numx) - implicit none - integer, intent(in) :: IMN,JMN - integer :: npts - real, intent(in) :: LONO(npts), LATO(npts) - real, intent(in) :: DELXN - integer, intent(out) :: jst,jen - integer, intent(out) :: ilist(IMN) - integer, intent(out) :: numx - real minlat,maxlat,minlon,maxlon - integer i2, ii, ist, ien - - minlat = minval(LATO) - maxlat = maxval(LATO) - minlon = minval(LONO) - maxlon = maxval(LONO) - ist = minlon/DELXN+1 - ien = maxlon/DELXN+1 - jst = (minlat+90)/DELXN+1 - jen = (maxlat+90)/DELXN - !--- add a few points to both ends of j-direction - jst = jst - 5 - if(jst<1) jst = 1 - jen = jen + 5 - if(jen>JMN) jen = JMN - - !--- when around the pole, just search through all the points. - if((jst == 1 .OR. jen == JMN) .and. - & (ien-ist+1 > IMN/2) )then - numx = IMN - do i2 = 1, IMN - ilist(i2) = i2 - enddo - else if( ien-ist+1 > IMN/2 ) then ! cross longitude = 0 - !--- find the minimum that greater than IMN/2 - !--- and maximum that less than IMN/2 - ist = 0 - ien = IMN+1 - do i2 = 1, npts - ii = LONO(i2)/DELXN+1 - if(ii <0 .or. ii>IMN) then - print*,"- II=",ii,IMN,LONO(i2),DELXN - endif - if( ii < IMN/2 ) then - ist = max(ist,ii) - else if( ii > IMN/2 ) then - ien = min(ien,ii) - endif - enddo - if(ist<1 .OR. ist>IMN) then - print*, "FATAL ERROR: ist<1 .or. ist>IMN" - call ABORT() - endif - if(ien<1 .OR. ien>IMN) then - print*, "FATAL ERROR: iend<1 .or. iend>IMN" - call ABORT() - endif - - numx = IMN - ien + 1 - do i2 = 1, numx - ilist(i2) = ien + (i2-1) - enddo - do i2 = 1, ist - ilist(numx+i2) = i2 - enddo - numx = numx+ist - else - numx = ien-ist+1 - do i2 = 1, numx - ilist(i2) = ist + (i2-1) - enddo - endif - - END SUBROUTINE get_index - !> Create the land-mask, land fraction. !! This routine is used for the FV3GFS model. !! @@ -514,7 +419,7 @@ END SUBROUTINE get_index !! @author GFDL Programmer SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, 1 IM,JM,IMN,JMN,lon_c,lat_c) - use orog_utils, only : inside_a_polygon + use orog_utils, only : inside_a_polygon, get_index implicit none real, parameter :: D2R = 3.14159265358979/180. integer, parameter :: MAXSUM=20000000 @@ -643,7 +548,7 @@ END SUBROUTINE MAKE_MASK !! @author GFDL Programmer SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, 1 IM,JM,IMN,JMN,lon_c,lat_c,lake_frac,land_frac) - use orog_utils, only : inside_a_polygon + use orog_utils, only : inside_a_polygon, get_index implicit none real, parameter :: D2R = 3.14159265358979/180. integer, parameter :: MAXSUM=20000000 @@ -864,7 +769,7 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, C C=== PC: principal coordinates of each Z avg orog box for L&M C - use orog_utils, only : inside_a_polygon + use orog_utils, only : get_index, inside_a_polygon implicit none real, parameter :: REARTH=6.3712E+6 real, parameter :: D2R = 3.14159265358979/180. @@ -1124,7 +1029,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, 2 IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t,dx,dy, 3 is_south_pole,is_north_pole ) use orog_utils, only : get_lat_angle, get_lon_angle, - & inside_a_polygon + & get_index, inside_a_polygon implicit none real, parameter :: MISSING_VALUE = -9999. real, parameter :: D2R = 3.14159265358979/180. diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 index 1ee3ba2b1..2d274d7b8 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -18,6 +18,7 @@ module orog_utils public :: find_nearest_pole_points public :: find_poles + public :: get_index public :: get_lat_angle public :: get_lon_angle public :: inside_a_polygon @@ -686,6 +687,103 @@ subroutine remove_isolated_pts(im,jm,slm,oro,var,var4,oa,ol) end subroutine remove_isolated_pts +!> Determine the location of a cubed-sphere point within +!! the high-resolution orography data. The location is +!! described by the range of i/j indices on the high-res grid. +!! +!! @param[in] imn 'i' dimension of the high-resolution orography +!! data set. +!! @param[in] jmn 'j' dimension of the high-resolution orography +!! data set. +!! @param[in] npts Number of vertices to describe the cubed-sphere point. +!! @param[in] lonO The longitudes of the cubed-sphere vertices. +!! @param[in] latO The latitudes of the cubed-sphere vertices. +!! @param[in] delxn Resolution of the high-resolution orography +!! data set. +!! @param[out] jst Starting 'j' index on the high-resolution grid. +!! @param[out] jen Ending 'j' index on the high-resolution grid. +!! @param[out] ilist List of 'i' indices on the high-resolution grid. +!! @param[out] numx The number of 'i' indices on the high-resolution +!! grid. +!! @author GFDL programmer + subroutine get_index(imn,jmn,npts,lonO,latO,delxn, & + jst,jen,ilist,numx) + + implicit none + integer, intent(in) :: IMN,JMN + integer, intent(in) :: npts + real, intent(in) :: LONO(npts), LATO(npts) + real, intent(in) :: DELXN + integer, intent(out) :: jst,jen + integer, intent(out) :: ilist(IMN) + integer, intent(out) :: numx + + integer :: i2, ii, ist, ien + real :: minlat,maxlat,minlon,maxlon + + minlat = minval(LATO) + maxlat = maxval(LATO) + minlon = minval(LONO) + maxlon = maxval(LONO) + ist = minlon/DELXN+1 + ien = maxlon/DELXN+1 + jst = (minlat+90)/DELXN+1 + jen = (maxlat+90)/DELXN +!--- add a few points to both ends of j-direction + jst = jst - 5 + if(jst<1) jst = 1 + jen = jen + 5 + if(jen>JMN) jen = JMN + +!--- when around the pole, just search through all the points. + if((jst == 1 .OR. jen == JMN) .and. & + (ien-ist+1 > IMN/2) )then + numx = IMN + do i2 = 1, IMN + ilist(i2) = i2 + enddo + else if( ien-ist+1 > IMN/2 ) then ! cross longitude = 0 +!--- find the minimum that greater than IMN/2 +!--- and maximum that less than IMN/2 + ist = 0 + ien = IMN+1 + do i2 = 1, npts + ii = LONO(i2)/DELXN+1 + if(ii <0 .or. ii>IMN) then + print*,"- II=",ii,IMN,LONO(i2),DELXN + endif + if( ii < IMN/2 ) then + ist = max(ist,ii) + else if( ii > IMN/2 ) then + ien = min(ien,ii) + endif + enddo + if(ist<1 .OR. ist>IMN) then + print*, "FATAL ERROR: ist<1 .or. ist>IMN" + call ABORT() + endif + if(ien<1 .OR. ien>IMN) then + print*, "FATAL ERROR: iend<1 .or. iend>IMN" + call ABORT() + endif + + numx = IMN - ien + 1 + do i2 = 1, numx + ilist(i2) = ien + (i2-1) + enddo + do i2 = 1, ist + ilist(numx+i2) = i2 + enddo + numx = numx+ist + else + numx = ien-ist+1 + do i2 = 1, numx + ilist(i2) = ist + (i2-1) + enddo + endif + + end subroutine get_index + !> Get the date/time from the system clock. !! !! @return timef From 5e0b350e9944a625d8bacd4ff09801c932cffa9a Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 17 Sep 2024 12:28:44 -0500 Subject: [PATCH 43/54] Move function get_xnsum to orog_utils module. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 103 +---------------- .../orog_mask_tools.fd/orog.fd/orog_utils.F90 | 108 ++++++++++++++++++ 2 files changed, 110 insertions(+), 101 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index 69fe52c25..ba4737158 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -1029,7 +1029,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, 2 IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t,dx,dy, 3 is_south_pole,is_north_pole ) use orog_utils, only : get_lat_angle, get_lon_angle, - & get_index, inside_a_polygon + & get_index, inside_a_polygon, + & get_xnsum implicit none real, parameter :: MISSING_VALUE = -9999. real, parameter :: D2R = 3.14159265358979/180. @@ -1058,7 +1059,6 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, real HC_11, HC_12, HC_21, HC_22 real xnsum1_11,xnsum1_12,xnsum1_21,xnsum1_22 real xnsum2_11,xnsum2_12,xnsum2_21,xnsum2_22 - real get_xnsum integer jst, jen print*,"- CREATE ASYMETRY AND LENGTH SCALE." @@ -1410,105 +1410,6 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, END SUBROUTINE MAKEOA2 -!> Count the number of high-resolution orography points that -!! are higher than the model grid box average orography height. -!! -!! @param[in] lon1 Longitude of corner point 1 of the model -!! grid box. -!! @param[in] lat1 Latitude of corner point 1 of the model -!! grid box. -!! @param[in] lon2 Longitude of corner point 2 of the model -!! grid box. -!! @param[in] lat2 Latitude of corner point 2 of the model -!! grid box. -!! @param[in] imn 'i' dimension of the high-resolution orography -!! data. -!! @param[in] jmn 'j' dimension of the high-resolution orography -!! data. -!! @param[in] glat Latitude of each row of the high-resolution -!! orography data. -!! @param[in] zavg The high-resolution orography. -!! @param[in] zslm The high-resolution land mask. -!! @param[in] delxn Resolution of the high-res orography data. -!! @return get_xnsum The number of high-res points above the -!! mean orography. -!! @author GFDL Programmer - function get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN, - & glat,zavg,zslm,delxn) - implicit none - - real get_xnsum - real, intent(in) :: lon1,lat1,lon2,lat2,delxn - integer, intent(in) :: IMN,JMN - real, intent(in) :: glat(JMN) - integer, intent(in) :: zavg(IMN,JMN),zslm(IMN,JMN) - integer i, j, ist, ien, jst, jen, i1 - real oro, HEIGHT - real xland,xwatr,xl1,xs1,slm,xnsum - !---figure out ist,ien,jst,jen - do j = 1, JMN - if( GLAT(J) .GT. lat1 ) then - jst = j - exit - endif - enddo - do j = 1, JMN - if( GLAT(J) .GT. lat2 ) then - jen = j - exit - endif - enddo - - - ist = lon1/delxn + 1 - ien = lon2/delxn - if(ist .le.0) ist = ist + IMN - if(ien < ist) ien = ien + IMN - - !--- compute average oro - oro = 0.0 - xnsum = 0 - xland = 0 - xwatr = 0 - xl1 = 0 - xs1 = 0 - do j = jst,jen - do i1 = 1, ien - ist + 1 - i = ist + i1 -1 - if( i .LE. 0) i = i + imn - if( i .GT. IMN) i = i - imn - XLAND = XLAND + FLOAT(ZSLM(I,J)) - XWATR = XWATR + FLOAT(1-ZSLM(I,J)) - XNSUM = XNSUM + 1. - HEIGHT = FLOAT(ZAVG(I,J)) - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - XL1 = XL1 + HEIGHT * FLOAT(ZSLM(I,J)) - XS1 = XS1 + HEIGHT * FLOAT(1-ZSLM(I,J)) - enddo - enddo - if( XNSUM > 1.) THEN - SLM = FLOAT(NINT(XLAND/XNSUM)) - IF(SLM.NE.0.) THEN - ORO= XL1 / XLAND - ELSE - ORO = XS1 / XWATR - ENDIF - ENDIF - - get_xnsum = 0 - do j = jst, jen - do i1= 1, ien-ist+1 - i = ist + i1 -1 - if( i .LE. 0) i = i + imn - if( i .GT. IMN) i = i - imn - HEIGHT = FLOAT(ZAVG(I,J)) - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - IF ( HEIGHT .gt. ORO ) get_xnsum = get_xnsum + 1 - enddo - enddo - - end function get_xnsum - !> Count the number of high-resolution orography points that !! are higher than a critical value inside a model grid box !! (or a portion of a model grid box). The critical value is a diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 index 2d274d7b8..691dc4544 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -21,6 +21,7 @@ module orog_utils public :: get_index public :: get_lat_angle public :: get_lon_angle + public :: get_xnsum public :: inside_a_polygon public :: latlon2xyz public :: minmax @@ -784,6 +785,113 @@ subroutine get_index(imn,jmn,npts,lonO,latO,delxn, & end subroutine get_index +!> Count the number of high-resolution orography points that +!! are higher than the model grid box average orography height. +!! +!! @param[in] lon1 Longitude of corner point 1 of the model +!! grid box. +!! @param[in] lat1 Latitude of corner point 1 of the model +!! grid box. +!! @param[in] lon2 Longitude of corner point 2 of the model +!! grid box. +!! @param[in] lat2 Latitude of corner point 2 of the model +!! grid box. +!! @param[in] imn 'i' dimension of the high-resolution orography +!! data. +!! @param[in] jmn 'j' dimension of the high-resolution orography +!! data. +!! @param[in] glat Latitude of each row of the high-resolution +!! orography data. +!! @param[in] zavg The high-resolution orography. +!! @param[in] zslm The high-resolution land mask. +!! @param[in] delxn Resolution of the high-res orography data. +!! @return get_xnsum The number of high-res points above the +!! mean orography. +!! @author GFDL Programmer + + function get_xnsum(lon1,lat1,lon2,lat2,imn,jmn, & + glat,zavg,zslm,delxn) + + implicit none + + real :: get_xnsum + + integer, intent(in) :: imn,jmn + integer, intent(in) :: zavg(imn,jmn),zslm(imn,jmn) + real, intent(in) :: lon1,lat1,lon2,lat2,delxn + real, intent(in) :: glat(jmn) + + integer :: i, j, ist, ien, jst, jen, i1 + real :: oro, height + real :: xland,xwatr,xl1,xs1,slm,xnsum + +!-- Figure out ist,ien,jst,jen + + do j = 1, jmn + if( glat(j) .gt. lat1 ) then + jst = j + exit + endif + enddo + + do j = 1, jmn + if( glat(j) .gt. lat2 ) then + jen = j + exit + endif + enddo + + ist = lon1/delxn + 1 + ien = lon2/delxn + if(ist .le.0) ist = ist + imn + if(ien < ist) ien = ien + imn + +!--- Compute average oro + + oro = 0.0 + xnsum = 0 + xland = 0 + xwatr = 0 + xl1 = 0 + xs1 = 0 + do j = jst,jen + do i1 = 1, ien - ist + 1 + i = ist + i1 -1 + if( i .le. 0) i = i + imn + if( i .gt. imn) i = i - imn + xland = xland + float(zslm(i,j)) + xwatr = xwatr + float(1-zslm(i,j)) + xnsum = xnsum + 1. + height = float(zavg(i,j)) + if(height.lt.-990.) height = 0.0 + xl1 = xl1 + height * float(zslm(i,j)) + xs1 = xs1 + height * float(1-zslm(i,j)) + enddo + enddo + + if( xnsum > 1.) then + slm = float(nint(xland/xnsum)) + if(slm.ne.0.) then + oro= xl1 / xland + else + oro = xs1 / xwatr + endif + endif + + get_xnsum = 0 + do j = jst, jen + do i1= 1, ien-ist+1 + i = ist + i1 -1 + if( i .le. 0) i = i + imn + if( i .gt. IMN) i = i - imn + height = float(zavg(i,j)) + if(height.lt.-990.) height = 0.0 + if ( height .gt. oro ) get_xnsum = get_xnsum + 1 + enddo + enddo + + end function get_xnsum + !> Get the date/time from the system clock. !! !! @return timef From 856a3c7f123f1cc69af6c6fc57fca1371cb1ee22 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 17 Sep 2024 14:00:20 -0500 Subject: [PATCH 44/54] Move 'get_xnsum2' and 'get_xnsum3' to orog_utils module. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 172 +--------------- .../orog_mask_tools.fd/orog.fd/orog_utils.F90 | 186 ++++++++++++++++++ 2 files changed, 188 insertions(+), 170 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index ba4737158..f1fbd9cb4 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -1030,7 +1030,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, 3 is_south_pole,is_north_pole ) use orog_utils, only : get_lat_angle, get_lon_angle, & get_index, inside_a_polygon, - & get_xnsum + & get_xnsum, get_xnsum2, + & get_xnsum3 implicit none real, parameter :: MISSING_VALUE = -9999. real, parameter :: D2R = 3.14159265358979/180. @@ -1409,172 +1410,3 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, RETURN END SUBROUTINE MAKEOA2 - -!> Count the number of high-resolution orography points that -!! are higher than a critical value inside a model grid box -!! (or a portion of a model grid box). The critical value is a -!! function of the standard deviation of orography. -!! -!! @param[in] lon1 Longitude of corner point 1 of the model -!! grid box. -!! @param[in] lat1 Latitude of corner point 1 of the model -!! grid box. -!! @param[in] lon2 Longitude of corner point 2 of the model -!! grid box. -!! @param[in] lat2 Latitude of corner point 2 of the model -!! grid box. -!! @param[in] imn 'i' dimension of the high-resolution orography -!! data. -!! @param[in] jmn 'j' dimension of the high-resolution orography -!! data. -!! @param[in] glat Latitude of each row of the high-resolution -!! orography data. -!! @param[in] zavg The high-resolution orography. -!! @param[in] delxn Resolution of the high-res orography data. -!! @param[out] xnsum1 The number of high-resolution orography -!! above the critical value inside a model grid box. -!! @param[out] xnsum2 The number of high-resolution orography -!! points inside a model grid box. -!! @param[out] hc Critical height. -!! @author GFDL Programmer - subroutine get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN, - & glat,zavg,delxn,xnsum1,xnsum2,HC) - implicit none - - real, intent(out) :: xnsum1,xnsum2,HC - real lon1,lat1,lon2,lat2,delxn - integer IMN,JMN - real glat(JMN) - integer zavg(IMN,JMN) - integer i, j, ist, ien, jst, jen, i1 - real HEIGHT, var - real XW1,XW2,xnsum - !---figure out ist,ien,jst,jen - do j = 1, JMN - if( GLAT(J) .GT. lat1 ) then - jst = j - exit - endif - enddo - do j = 1, JMN - if( GLAT(J) .GT. lat2 ) then - jen = j - exit - endif - enddo - - - ist = lon1/delxn + 1 - ien = lon2/delxn - if(ist .le.0) ist = ist + IMN - if(ien < ist) ien = ien + IMN - - !--- compute average oro - xnsum = 0 - XW1 = 0 - XW2 = 0 - do j = jst,jen - do i1 = 1, ien - ist + 1 - i = ist + i1 -1 - if( i .LE. 0) i = i + imn - if( i .GT. IMN) i = i - imn - XNSUM = XNSUM + 1. - HEIGHT = FLOAT(ZAVG(I,J)) - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - XW1 = XW1 + HEIGHT - XW2 = XW2 + HEIGHT ** 2 - enddo - enddo - var = SQRT(MAX(XW2/XNSUM-(XW1/XNSUM)**2,0.)) - HC = 1116.2 - 0.878 * VAR - xnsum1 = 0 - xnsum2 = 0 - do j = jst, jen - do i1= 1, ien-ist+1 - i = ist + i1 -1 - if( i .LE. 0) i = i + imn - if( i .GT. IMN) i = i - imn - HEIGHT = FLOAT(ZAVG(I,J)) - IF ( HEIGHT .gt. HC ) xnsum1 = xnsum1 + 1 - xnsum2 = xnsum2 + 1 - enddo - enddo - - end subroutine get_xnsum2 - -!> Count the number of high-resolution orography points that -!! are higher than a critical value inside a model grid box -!! (or a portion of a model grid box). Unlike routine -!! get_xnsum2(), this routine does not compute the critical -!! value. Rather, it is passed in. -!! -!! @param[in] lon1 Longitude of corner point 1 of the model -!! grid box. -!! @param[in] lat1 Latitude of corner point 1 of the model -!! grid box. -!! @param[in] lon2 Longitude of corner point 2 of the model -!! grid box. -!! @param[in] lat2 Latitude of corner point 2 of the model -!! grid box. -!! @param[in] imn 'i' dimension of the high-resolution orography -!! data. -!! @param[in] jmn 'j' dimension of the high-resolution orography -!! data. -!! @param[in] glat Latitude of each row of the high-resolution -!! orography data. -!! @param[in] zavg The high-resolution orography. -!! @param[in] delxn Resolution of the high-res orography data. -!! @param[out] xnsum1 The number of high-resolution orography -!! above the critical value inside a model grid box. -!! @param[out] xnsum2 The number of high-resolution orography -!! points inside a model grid box. -!! @param[in] hc Critical height. -!! @author GFDL Programmer - subroutine get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN, - & glat,zavg,delxn,xnsum1,xnsum2,HC) - implicit none - - real, intent(out) :: xnsum1,xnsum2 - real lon1,lat1,lon2,lat2,delxn - integer IMN,JMN - real glat(JMN) - integer zavg(IMN,JMN) - integer i, j, ist, ien, jst, jen, i1 - real HEIGHT, HC - !---figure out ist,ien,jst,jen - ! if lat1 or lat 2 is 90 degree. set jst = JMN - jst = JMN - jen = JMN - do j = 1, JMN - if( GLAT(J) .GT. lat1 ) then - jst = j - exit - endif - enddo - do j = 1, JMN - if( GLAT(J) .GT. lat2 ) then - jen = j - exit - endif - enddo - - - ist = lon1/delxn + 1 - ien = lon2/delxn - if(ist .le.0) ist = ist + IMN - if(ien < ist) ien = ien + IMN - - xnsum1 = 0 - xnsum2 = 0 - do j = jst, jen - do i1= 1, ien-ist+1 - i = ist + i1 -1 - if( i .LE. 0) i = i + imn - if( i .GT. IMN) i = i - imn - HEIGHT = FLOAT(ZAVG(I,J)) - IF ( HEIGHT .gt. HC ) xnsum1 = xnsum1 + 1 - xnsum2 = xnsum2 + 1 - enddo - enddo - - end subroutine get_xnsum3 diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 index 691dc4544..04939268f 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -22,6 +22,8 @@ module orog_utils public :: get_lat_angle public :: get_lon_angle public :: get_xnsum + public :: get_xnsum2 + public :: get_xnsum3 public :: inside_a_polygon public :: latlon2xyz public :: minmax @@ -892,6 +894,190 @@ function get_xnsum(lon1,lat1,lon2,lat2,imn,jmn, & end function get_xnsum +!> Count the number of high-resolution orography points that +!! are higher than a critical value inside a model grid box +!! (or a portion of a model grid box). The critical value is a +!! function of the standard deviation of orography. +!! +!! @param[in] lon1 Longitude of corner point 1 of the model +!! grid box. +!! @param[in] lat1 Latitude of corner point 1 of the model +!! grid box. +!! @param[in] lon2 Longitude of corner point 2 of the model +!! grid box. +!! @param[in] lat2 Latitude of corner point 2 of the model +!! grid box. +!! @param[in] imn 'i' dimension of the high-resolution orography +!! data. +!! @param[in] jmn 'j' dimension of the high-resolution orography +!! data. +!! @param[in] glat Latitude of each row of the high-resolution +!! orography data. +!! @param[in] zavg The high-resolution orography. +!! @param[in] delxn Resolution of the high-res orography data. +!! @param[out] xnsum1 The number of high-resolution orography +!! above the critical value inside a model grid box. +!! @param[out] xnsum2 The number of high-resolution orography +!! points inside a model grid box. +!! @param[out] hc Critical height. +!! @author GFDL Programmer + + subroutine get_xnsum2(lon1,lat1,lon2,lat2,imn,jmn, & + glat,zavg,delxn,xnsum1,xnsum2,hc) + + implicit none + + integer, intent(in) :: imn,jmn + integer, intent(in) :: zavg(imn,jmn) + + real, intent(in) :: lon1,lat1,lon2,lat2,delxn + real, intent(in) :: glat(jmn) + real, intent(out) :: xnsum1,xnsum2,hc + + integer :: i, j, ist, ien, jst, jen, i1 + + real :: height, var + real :: xw1,xw2,xnsum + +!-- Figure out ist,ien,jst,jen + + do j = 1, jmn + if( glat(j) .gt. lat1 ) then + jst = j + exit + endif + enddo + + do j = 1, jmn + if( glat(j) .gt. lat2 ) then + jen = j + exit + endif + enddo + + ist = lon1/delxn + 1 + ien = lon2/delxn + if(ist .le.0) ist = ist + imn + if(ien < ist) ien = ien + imn + +!--- Compute average oro + + xnsum = 0 + xw1 = 0 + xw2 = 0 + do j = jst,jen + do i1 = 1, ien - ist + 1 + i = ist + i1 -1 + if( i .le. 0) i = i + imn + if( i .gt. imn) i = i - imn + xnsum = xnsum + 1. + height = float(zavg(i,j)) + if(height.lt.-990.) height = 0.0 + xw1 = xw1 + height + xw2 = xw2 + height ** 2 + enddo + enddo + + var = sqrt(max(xw2/xnsum-(xw1/xnsum)**2,0.)) + hc = 1116.2 - 0.878 * var + xnsum1 = 0 + xnsum2 = 0 + do j = jst, jen + do i1= 1, ien-ist+1 + i = ist + i1 -1 + if( i .le. 0) i = i + imn + if( i .gt. imn) i = i - imn + height = float(zavg(i,j)) + if ( height .gt. hc ) xnsum1 = xnsum1 + 1 + xnsum2 = xnsum2 + 1 + enddo + enddo + + end subroutine get_xnsum2 + +!> Count the number of high-resolution orography points that +!! are higher than a critical value inside a model grid box +!! (or a portion of a model grid box). Unlike routine +!! get_xnsum2(), this routine does not compute the critical +!! value. Rather, it is passed in. +!! +!! @param[in] lon1 Longitude of corner point 1 of the model +!! grid box. +!! @param[in] lat1 Latitude of corner point 1 of the model +!! grid box. +!! @param[in] lon2 Longitude of corner point 2 of the model +!! grid box. +!! @param[in] lat2 Latitude of corner point 2 of the model +!! grid box. +!! @param[in] imn 'i' dimension of the high-resolution orography +!! data. +!! @param[in] jmn 'j' dimension of the high-resolution orography +!! data. +!! @param[in] glat Latitude of each row of the high-resolution +!! orography data. +!! @param[in] zavg The high-resolution orography. +!! @param[in] delxn Resolution of the high-res orography data. +!! @param[out] xnsum1 The number of high-resolution orography +!! above the critical value inside a model grid box. +!! @param[out] xnsum2 The number of high-resolution orography +!! points inside a model grid box. +!! @param[in] hc Critical height. +!! @author GFDL Programmer + + subroutine get_xnsum3(lon1,lat1,lon2,lat2,imn,jmn, & + glat,zavg,delxn,xnsum1,xnsum2,HC) + implicit none + + integer, intent(in) :: imn,jmn + integer, intent(in) :: zavg(imn,jmn) + + real, intent(in) :: glat(jmn) + real, intent(in) :: lon1,lat1,lon2,lat2,delxn + real, intent(out) :: xnsum1,xnsum2,hc + + integer :: i, j, ist, ien, jst, jen, i1 + + real :: height + +!-- Figure out ist,ien,jst,jen + +! if lat1 or lat 2 is 90 degree. set jst = JMN + + jst = jmn + jen = jmn + do j = 1, jmn + if( glat(j) .gt. lat1 ) then + jst = j + exit + endif + enddo + + do j = 1, jmn + if( glat(j) .gt. lat2 ) then + jen = j + exit + endif + enddo + + ist = lon1/delxn + 1 + ien = lon2/delxn + if(ist .le.0) ist = ist + imn + if(ien < ist) ien = ien + imn + + xnsum1 = 0 + xnsum2 = 0 + do j = jst, jen + do i1= 1, ien-ist+1 + i = ist + i1 -1 + if( i .le. 0) i = i + imn + if( i .gt. imn) i = i - imn + height = float(zavg(i,j)) + if ( height .gt. hc ) xnsum1 = xnsum1 + 1 + xnsum2 = xnsum2 + 1 + enddo + enddo + + end subroutine get_xnsum3 !> Get the date/time from the system clock. !! !! @return timef From d477f17ff284d45596b92112e11cb2c5af1b909f Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 17 Sep 2024 14:28:19 -0500 Subject: [PATCH 45/54] Rename netcdf_io.F90 to a more descriptive io_utils.F90. Fixes #970. --- sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt | 2 +- sorc/orog_mask_tools.fd/orog.fd/{netcdf_io.F90 => io_utils.F90} | 0 2 files changed, 1 insertion(+), 1 deletion(-) rename sorc/orog_mask_tools.fd/orog.fd/{netcdf_io.F90 => io_utils.F90} (100%) diff --git a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt index dda71f227..256f6a4fa 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt +++ b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt @@ -1,4 +1,4 @@ -set(lib_src netcdf_io.F90 orog_utils.F90) +set(lib_src io_utils.F90 orog_utils.F90) set(exe_src mtnlm7_oclsm.F) if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") diff --git a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 b/sorc/orog_mask_tools.fd/orog.fd/io_utils.F90 similarity index 100% rename from sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 rename to sorc/orog_mask_tools.fd/orog.fd/io_utils.F90 From a4b14346103df942fc2e28632ebce1ec6e5de715 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 18 Sep 2024 12:41:33 +0000 Subject: [PATCH 46/54] Update the doxygen. Fixes #970. --- sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 index 04939268f..92ac571a3 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -11,10 +11,10 @@ module orog_utils private - real, parameter :: earth_radius = 6371200. ! meters - real, parameter :: pi=3.1415926535897931 - real, parameter :: rad2deg = 180./3.14159265358979 - real, parameter :: deg2rad = 3.14159265358979/180. + real, parameter :: earth_radius = 6371200. !< earth radius in meters. + real, parameter :: pi=3.1415926535897931 !< pi. + real, parameter :: rad2deg = 180./3.14159265358979 !< radians per degrees. + real, parameter :: deg2rad = 3.14159265358979/180. !< degrees per radians. public :: find_nearest_pole_points public :: find_poles From 71b077913ace452a997935c19c9507fea24c098a Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 18 Sep 2024 07:50:45 -0500 Subject: [PATCH 47/54] Convert io_utils.F90 into a Fortran module. Fixes #970. --- sorc/orog_mask_tools.fd/orog.fd/io_utils.F90 | 27 +++++++++++++++++-- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 5 ++++ 2 files changed, 30 insertions(+), 2 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/io_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/io_utils.F90 index fea230b27..51a646779 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/io_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/io_utils.F90 @@ -1,6 +1,27 @@ !> @file -!! @brief Write out data in netcdf format -!! @author Jordan Alpert NOAA/EMC +!! @brief i/o utilities +!! @author George Gayno NOAA/EMC + +!> Module containing utilities that read and write data. +!! +!! @author George Gayno NOAA/EMC + + module io_utils + + implicit none + + private + + public :: qc_orog_by_ramp + public :: read_global_mask + public :: read_global_orog + public :: read_mask + public :: read_mdl_dims + public :: read_mdl_grid_file + public :: write_mask_netcdf + public :: write_netcdf + + contains !> Write out orography file in netcdf format. !! @@ -654,3 +675,5 @@ subroutine qc_orog_by_ramp(imn, jmn, zavg, zslm) deallocate (GICE) end subroutine qc_orog_by_ramp + + end module io_utils diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index f1fbd9cb4..de9499da5 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -68,6 +68,7 @@ C> - CONTAINS ONLY LAND MASK AND FRACTION. C> C> @return 0 for success, error code otherwise. + use io_utils, only : read_mdl_dims implicit none character(len=256) :: mdl_grid_file = "none" @@ -122,6 +123,10 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, & OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) + use io_utils, only : qc_orog_by_ramp, write_mask_netcdf, + & read_global_mask, read_global_orog, + & read_mask, write_netcdf, + & read_mdl_grid_file use orog_utils, only : minmax, timef, remove_isolated_pts implicit none From e54edb959d2a2ea149b9101aadefa2c91864f631 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 18 Sep 2024 08:04:39 -0500 Subject: [PATCH 48/54] Fix intent attribute hc in routine get_xnsum3. Fixes #970. --- sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 index 92ac571a3..cae1f2bec 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -1031,9 +1031,9 @@ subroutine get_xnsum3(lon1,lat1,lon2,lat2,imn,jmn, & integer, intent(in) :: imn,jmn integer, intent(in) :: zavg(imn,jmn) - real, intent(in) :: glat(jmn) + real, intent(in) :: hc, glat(jmn) real, intent(in) :: lon1,lat1,lon2,lat2,delxn - real, intent(out) :: xnsum1,xnsum2,hc + real, intent(out) :: xnsum1,xnsum2 integer :: i, j, ist, ien, jst, jen, i1 From a0eb44c0da137315a8b15e3d53735ce63dd62234 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 18 Sep 2024 09:01:19 -0500 Subject: [PATCH 49/54] Remove space from variable XMSUM_ALL. Regression tests all passed. Fixes #970. --- sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F index de9499da5..5ee5dc93e 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F @@ -521,7 +521,7 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, land_frac(i,j) = XLAND/XNSUM SLM(I,J) = FLOAT(NINT(XLAND/XNSUM)) ELSEIF(XNSUM_ALL.GT.1.) THEN - land_frac(i,j) = XLAND_ALL/XNSUM _ALL + land_frac(i,j) = XLAND_ALL/XNSUM_ALL SLM(I,J) = FLOAT(NINT(XLAND_ALL/XNSUM_ALL)) ELSE print*, "FATAL ERROR: no source points in MAKE_MASK." From 9b698ea630d10883908d3fce601ea0d724cdb171 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 18 Sep 2024 10:29:05 -0500 Subject: [PATCH 50/54] Update driver routine to be Fortran 90. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/CMakeLists.txt | 4 +- .../{mtnlm7_oclsm.F => mtnlm7_oclsm.F90} | 549 +++++++++--------- 2 files changed, 270 insertions(+), 283 deletions(-) rename sorc/orog_mask_tools.fd/orog.fd/{mtnlm7_oclsm.F => mtnlm7_oclsm.F90} (77%) diff --git a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt index 256f6a4fa..373d8c776 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt +++ b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt @@ -1,5 +1,5 @@ set(lib_src io_utils.F90 orog_utils.F90) -set(exe_src mtnlm7_oclsm.F) +set(exe_src mtnlm7_oclsm.F90) if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -warn unused -r8 -convert big_endian -assume byterecl") @@ -13,7 +13,7 @@ endif() set(exe_name orog) add_library(orog_lib STATIC ${lib_src}) -add_executable(${exe_name} mtnlm7_oclsm.F) +add_executable(${exe_name} mtnlm7_oclsm.F90) set(mod_dir "${CMAKE_CURRENT_BINARY_DIR}/mod") set_target_properties(orog_lib PROPERTIES Fortran_MODULE_DIRECTORY ${mod_dir}) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 similarity index 77% rename from sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F rename to sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 index 5ee5dc93e..4a5285842 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 @@ -1,73 +1,73 @@ -C> @file -C> Terrain maker for the ufs weather model. -C> @author Mark Iredell @date 92-04-16 +!> @file +!! Terrain maker for the ufs weather model. +!! @author Mark Iredell @date 92-04-16 -C> This program creates landmask, land fraction, terrain and -C> and fields required for the model's gravity wave drag -C> (GWD) scheme. -C> -C> Specifically: -C> -C> - Land mask (yes/no flag) -C> - Land fraction -C> - Terrain (orography) -C> - Maximum elevation -C> - Standard deviation of terrain -C> - Convexity -C> - Orographic Asymetry - W/S/SW/NW directional components. -C> - Orographic Length Scale - W/S/SW/NW directional components. -C> - Anisotropy -C> - Slope of terrain -C> - Angle of mountain range with respect to East. -C> -C> This program operates on a single cubed-sphere tile. -C> -C> Optionally, the program can compute and output only the -C> land mask and land fraction. Or, it can read in the mask -C> and fraction from an external file, then compute the -C> terrain and GWD fields using that mask. These options -C> are used to support coupled (atm/oceann) runs of the UFS. -C> The process is: -C> - Run this program and output the mask/fraction only. -C> - Adjust or merge the mask/fraction with the ocean -C> mask (using another program). -C> - Read in this 'merged' mask/fraction and compute the -C> terrain and GWD fields. -C> -C> PROGRAM HISTORY LOG: -C> - 92-04-16 IREDELL -C> - 98-02-02 IREDELL FILTER -C> - 98-05-31 HONG Modified for subgrid orography used in Kim's scheme -C> - 98-12-31 HONG Modified for high-resolution GTOPO orography -C> - 99-05-31 HONG Modified for getting OL4 (mountain fraction) -C> - 00-02-10 Moorthi's modifications -C> - 00-04-11 HONG Modified for reduced grids -C> - 00-04-12 Iredell Modified for reduced grids -C> - 02-01-07 (*j*) modified for principal axes of orography -C> There are now 14 files, 4 additional for lm mb -C> - 04-04-04 (*j*) re-Test on IST/ilen calc for sea-land mask(*j*) -C> - 04-09-04 minus sign here in MAKEOA IST and IEN as in MAKEMT! -C> - 05-09-05 if test on HK and HLPRIM for GAMMA SQRT -C> - 07-08-07 replace 8' with 30" incl GICE, conintue w/ S-Y. lake slm -C> - 08-08-07 All input 30", UMD option, and filter as described below -C> - 24-08-15 Remove old code used by spectral GFS. -C> -C> INPUT FILES: -C> - UNIT5 - PROGRAM CONTROL NAMELIST. -C> - NCID - MODEL 'GRID' FILE -C> - NCID - GMTED2010 USGS orography (NetCDF) -C> - NCID - 30" UMD land cover mask. (NetCDF) -C> - NCID - GICE Grumbine 30" RAMP Antarctica orog. (NetCDF) -C> - NCID - MERGE FILE. CONTAINS LAND MASK, FRACTION AND -C> LAKE FRACTION THAT HAS BEEN MERGED WITH AN -C> OCEAN GRID. (NetCDF) -C> -C> OUTPUT FILES (ALL ON A SINGLE CUBED-SPHERE TILE) : -C> - NCID - OROGRAPHY FILE (NetCDF) IF MASK_ONLY=FALSE -C> - NCID - MASK FILE (NetCDF) IF MASK_ONLY=TRUE -C> - CONTAINS ONLY LAND MASK AND FRACTION. -C> -C> @return 0 for success, error code otherwise. +!> This program creates landmask, land fraction, terrain and +!! and fields required for the model's gravity wave drag +!! (GWD) scheme. +!! +!! Specifically: +!! +!! - Land mask (yes/no flag) +!! - Land fraction +!! - Terrain (orography) +!! - Maximum elevation +!! - Standard deviation of terrain +!! - Convexity +!! - Orographic Asymetry - W/S/SW/NW directional components. +!! - Orographic Length Scale - W/S/SW/NW directional components. +!! - Anisotropy +!! - Slope of terrain +!! - Angle of mountain range with respect to East. +!! +!! This program operates on a single cubed-sphere tile. +!! +!! Optionally, the program can compute and output only the +!! land mask and land fraction. Or, it can read in the mask +!! and fraction from an external file, then compute the +!! terrain and GWD fields using that mask. These options +!! are used to support coupled (atm/oceann) runs of the UFS. +!! The process is: +!! - Run this program and output the mask/fraction only. +!! - Adjust or merge the mask/fraction with the ocean +!! mask (using another program). +!! - Read in this 'merged' mask/fraction and compute the +!! terrain and GWD fields. +!! +!! PROGRAM HISTORY LOG: +!! - 92-04-16 IREDELL +!! - 98-02-02 IREDELL FILTER +!! - 98-05-31 HONG Modified for subgrid orography used in Kim's scheme +!! - 98-12-31 HONG Modified for high-resolution GTOPO orography +!! - 99-05-31 HONG Modified for getting OL4 (mountain fraction) +!! - 00-02-10 Moorthi's modifications +!! - 00-04-11 HONG Modified for reduced grids +!! - 00-04-12 Iredell Modified for reduced grids +!! - 02-01-07 (*j*) modified for principal axes of orography +!! There are now 14 files, 4 additional for lm mb +!! - 04-04-04 (*j*) re-Test on IST/ilen calc for sea-land mask(*j*) +!! - 04-09-04 minus sign here in MAKEOA IST and IEN as in MAKEMT! +!! - 05-09-05 if test on HK and HLPRIM for GAMMA SQRT +!! - 07-08-07 replace 8' with 30" incl GICE, conintue w/ S-Y. lake slm +!! - 08-08-07 All input 30", UMD option, and filter as described below +!! - 24-08-15 Remove old code used by spectral GFS. +!! +!! INPUT FILES: +!! - UNIT5 - PROGRAM CONTROL NAMELIST. +!! - NCID - MODEL 'GRID' FILE +!! - NCID - GMTED2010 USGS orography (NetCDF) +!! - NCID - 30" UMD land cover mask. (NetCDF) +!! - NCID - GICE Grumbine 30" RAMP Antarctica orog. (NetCDF) +!! - NCID - MERGE FILE. CONTAINS LAND MASK, FRACTION AND +!! LAKE FRACTION THAT HAS BEEN MERGED WITH AN +!! OCEAN GRID. (NetCDF) +!! +!! OUTPUT FILES (ALL ON A SINGLE CUBED-SPHERE TILE) : +!! - NCID - OROGRAPHY FILE (NetCDF) IF MASK_ONLY=FALSE +!! - NCID - MASK FILE (NetCDF) IF MASK_ONLY=TRUE +!! - CONTAINS ONLY LAND MASK AND FRACTION. +!! +!! @return 0 for success, error code otherwise. use io_utils, only : read_mdl_dims implicit none @@ -91,14 +91,12 @@ endif if (trim(external_mask_file) /= "none") then - print*,"- WILL USE EXTERNAL LANDMASK FROM FILE: ", - & trim(external_mask_file) + print*,"- WILL USE EXTERNAL LANDMASK FROM FILE: ", trim(external_mask_file) endif call read_mdl_dims(mdl_grid_file, im, jm) - call tersub(imn,jmn,im,jm,efac, - & mdl_grid_file,mask_only,external_mask_file) + call tersub(imn,jmn,im,jm,efac,mdl_grid_file,mask_only,external_mask_file) print*,"- NORMAL TERMINATION." @@ -120,18 +118,18 @@ !! @param[in] EXTERNAL_MASK_FILE File containing an externally !! generated land mask/fraction. !! @author Jordan Alpert NOAA/EMC - SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, - & OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) + SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, & + OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) - use io_utils, only : qc_orog_by_ramp, write_mask_netcdf, - & read_global_mask, read_global_orog, - & read_mask, write_netcdf, - & read_mdl_grid_file + use io_utils, only : qc_orog_by_ramp, write_mask_netcdf, & + read_global_mask, read_global_orog, & + read_mask, write_netcdf, & + read_mdl_grid_file use orog_utils, only : minmax, timef, remove_isolated_pts implicit none include 'netcdf.inc' -C + integer :: IMN,JMN,IM,JM character(len=*), intent(in) :: OUTGRID character(len=*), intent(in) :: EXTERNAL_MASK_FILE @@ -214,8 +212,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, ! Reading grid file. - call read_mdl_grid_file(outgrid,im,jm,geolon,geolon_c, - & geolat,geolat_c,dx,dy,is_north_pole,is_south_pole) + call read_mdl_grid_file(outgrid,im,jm,geolon,geolon_c, & + geolat,geolat_c,dx,dy,is_north_pole,is_south_pole) tend=timef() print*,"- TIMING: READING INPUT DATA ",tend-tbeg @@ -223,18 +221,18 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, tbeg=timef() IF (EXTERNAL_MASK_FILE == 'none') then - CALL MAKE_MASK(ZSLM,SLM,land_frac, - & IM,JM,IMN,JMN,geolon_c,geolat_c) + CALL MAKE_MASK(ZSLM,SLM,land_frac, & + IM,JM,IMN,JMN,geolon_c,geolat_c) lake_frac=9999.9 ELSE - CALL READ_MASK(EXTERNAL_MASK_FILE,SLM,land_frac, - & lake_frac,im,jm) + CALL READ_MASK(EXTERNAL_MASK_FILE,SLM,land_frac, & + lake_frac,im,jm) ENDIF IF (MASK_ONLY) THEN print*,'- WILL COMPUTE LANDMASK ONLY.' - CALL WRITE_MASK_NETCDF(IM,JM,SLM,land_frac, - & 1,1,GEOLON,GEOLAT) + CALL WRITE_MASK_NETCDF(IM,JM,SLM,land_frac, & + 1,1,GEOLON,GEOLAT) DEALLOCATE(ZAVG, ZSLM, SLM, LAND_FRAC, LAKE_FRAC) DEALLOCATE(GEOLON, GEOLON_C, GEOLAT, GEOLAT_C) @@ -244,8 +242,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, allocate (VAR(IM,JM),VAR4(IM,JM),ORO(IM,JM)) - CALL MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, - & IM,JM,IMN,JMN,geolon_c,geolat_c,lake_frac,land_frac) + CALL MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, & + IM,JM,IMN,JMN,geolon_c,geolat_c,lake_frac,land_frac) tend=timef() print*,"- TIMING: MASK AND OROG CREATION ", tend-tbeg @@ -260,8 +258,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, allocate (THETA(IM,JM),GAMMA(IM,JM),SIGMA(IM,JM),ELVMAX(IM,JM)) tbeg=timef() - CALL MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, - 1 IM,JM,IMN,JMN,geolon_c,geolat_c,SLM) + CALL MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, & + IM,JM,IMN,JMN,geolon_c,geolat_c,SLM) tend=timef() print*,"- TIMING: CREATE PRINCIPLE COORDINATE ",tend-tbeg @@ -278,10 +276,10 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, allocate (WORK5(IM,JM),WORK6(IM,JM)) tbeg=timef() - CALL MAKEOA2(ZAVG,zslm,VAR,OA,OL,IWORK,ELVMAX,ORO, - 1 WORK1,WORK2,WORK3,WORK4,WORK5,WORK6, - 2 IM,JM,IMN,JMN,geolon_c,geolat_c, - 3 geolon,geolat,dx,dy,is_south_pole,is_north_pole) + CALL MAKEOA2(ZAVG,zslm,VAR,OA,OL,IWORK,ELVMAX,ORO, & + WORK1,WORK2,WORK3,WORK4,WORK5,WORK6, & + IM,JM,IMN,JMN,geolon_c,geolat_c, & + geolon,geolat,dx,dy,is_south_pole,is_north_pole) tend=timef() print*,"- TIMING: CREATE ASYMETRY AND LENGTH SCALE ",tend-tbeg @@ -322,7 +320,7 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, DO J = 1,JM DO I = 1,IM IF(SLM(I,J).EQ.0.) THEN -C VAR(I,J) = 0. +! VAR(I,J) = 0. VAR4(I,J) = 0. OA(I,J,1) = 0. OA(I,J,2) = 0. @@ -332,10 +330,10 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, OL(I,J,2) = 0. OL(I,J,3) = 0. OL(I,J,4) = 0. -C THETA(I,J) =0. -C GAMMA(I,J) =0. -C SIGMA(I,J) =0. -C ELVMAX(I,J)=0. +! THETA(I,J) =0. +! GAMMA(I,J) =0. +! SIGMA(I,J) =0. +! ELVMAX(I,J)=0. ! --- the sub-grid scale parameters for mtn blocking and gwd retain ! --- properties even if over ocean but there is elevation within the ! --- gaussian grid box. @@ -377,8 +375,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, call minmax(IM,JM,ELVMAX,'ELVMAX ',itest,jtest) call minmax(IM,JM,ORO,'ORO ') - print *,'- ORO(itest,jtest),itest,jtest:', - & ORO(itest,jtest),itest,jtest + print *,'- ORO(itest,jtest),itest,jtest:', & + ORO(itest,jtest),itest,jtest print *,'- ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) tend=timef() @@ -393,8 +391,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, enddo tbeg=timef() - CALL WRITE_NETCDF(IM,JM,SLM,land_frac,ORO,HPRIME,1,1, - 1 GEOLON(1:IM,1:JM),GEOLAT(1:IM,1:JM), XLON,XLAT) + CALL WRITE_NETCDF(IM,JM,SLM,land_frac,ORO,HPRIME,1,1, & + GEOLON(1:IM,1:JM),GEOLAT(1:IM,1:JM), XLON,XLAT) tend=timef() print*,"- TIMING: WRITE OUTPUT FILE ", tend-tbeg @@ -422,8 +420,8 @@ END SUBROUTINE TERSUB !! @param[in] lon_c Longitude of the model grid corner points. !! @param[in] lat_c Latitude on the model grid corner points. !! @author GFDL Programmer - SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, - 1 IM,JM,IMN,JMN,lon_c,lat_c) + SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, & + IM,JM,IMN,JMN,lon_c,lat_c) use orog_utils, only : inside_a_polygon, get_index implicit none real, parameter :: D2R = 3.14159265358979/180. @@ -440,13 +438,13 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, integer ilist(IMN) real DELXN,XNSUM,XLAND,XWATR,XL1,XS1,XW1 real XNSUM_ALL,XLAND_ALL,XWATR_ALL -C + print *,'- CREATE LANDMASK AND LAND FRACTION.' -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C +!---- GLOBAL XLAT AND XLON ( DEGREE ) + JM1 = JM - 1 DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C + DO J=1,JMN GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 ENDDO @@ -455,15 +453,15 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, ENDDO land_frac(:,:) = 0.0 -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C -C (*j*) for hard wired zero offset (lambda s =0) for terr05 -!$omp parallel do -!$omp* private (j,i,xnsum,xland,xwatr,nsum,xl1,xs1,xw1,lono, -!$omp* lato,lono_rad,lato_rad,jst,jen,ilist,numx,jj,i2,ii,loni,lati, -!$omp* xnsum_all,xland_all,xwatr_all,nsum_all) -!$omp* +! +!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX +! +! (*j*) for hard wired zero offset (lambda s =0) for terr05 +!$omp parallel do & +!$omp private (j,i,xnsum,xland,xwatr,nsum,xl1,xs1,xw1,lono, & +!$omp lato,lono_rad,lato_rad,jst,jen,ilist,numx,jj,i2,ii,loni,lati, & +!$omp xnsum_all,xland_all,xwatr_all,nsum_all) +! DO J=1,JM DO I=1,IM XNSUM = 0.0 @@ -501,8 +499,8 @@ SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, call ABORT() endif - if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO_RAD,LATO_RAD))then + if(inside_a_polygon(LONI*D2R,LATI*D2R,4, & + LONO_RAD,LATO_RAD))then XLAND = XLAND + FLOAT(ZSLM(ii,jj)) XWATR = XWATR + FLOAT(1-ZSLM(ii,jj)) @@ -551,8 +549,8 @@ END SUBROUTINE MAKE_MASK !! @param[in] lake_frac Fractional lake within the grid !! @param[in] land_frac Fractional land within the grid !! @author GFDL Programmer - SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, - 1 IM,JM,IMN,JMN,lon_c,lat_c,lake_frac,land_frac) + SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, & + IM,JM,IMN,JMN,lon_c,lat_c,lake_frac,land_frac) use orog_utils, only : inside_a_polygon, get_index implicit none real, parameter :: D2R = 3.14159265358979/180. @@ -573,15 +571,15 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, real DELXN,XNSUM,XLAND,XWATR,XL1,XS1,XW1,XW2,XW4 real XNSUM_ALL,XLAND_ALL,XWATR_ALL,HEIGHT_ALL real XL1_ALL,XS1_ALL,XW1_ALL,XW2_ALL,XW4_ALL -C + print*,'- CREATE OROGRAPHY AND CONVEXITY.' allocate(hgt_1d(MAXSUM)) allocate(hgt_1d_all(MAXSUM)) -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C +!---- GLOBAL XLAT AND XLON ( DEGREE ) +! JM1 = JM - 1 DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C + DO J=1,JMN GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 ENDDO @@ -590,17 +588,17 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, ENDDO ! land_frac(:,:) = 0.0 -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C -C (*j*) for hard wired zero offset (lambda s =0) for terr05 -!$omp parallel do -!$omp* private (j,i,xnsum,xland,xwatr,nsum,xl1,xs1,xw1,xw2,xw4,lono, -!$omp* lato,jst,jen,ilist,numx,jj,i2,ii,loni,lati,height, -!$omp* lato_rad,lono_rad,hgt_1d, -!$omp* xnsum_all,xland_all,xwatr_all,nsum_all, -!$omp* xl1_all,xs1_all,xw1_all,xw2_all,xw4_all, -!$omp* height_all,hgt_1d_all) +! +!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX +! +! (*j*) for hard wired zero offset (lambda s =0) for terr05 +!$omp parallel do & +!$omp private (j,i,xnsum,xland,xwatr,nsum,xl1,xs1,xw1,xw2,xw4,lono, & +!$omp lato,jst,jen,ilist,numx,jj,i2,ii,loni,lati,height, & +!$omp lato_rad,lono_rad,hgt_1d, & +!$omp xnsum_all,xland_all,xwatr_all,nsum_all, & +!$omp xl1_all,xs1_all,xw1_all,xw2_all,xw4_all, & +!$omp height_all,hgt_1d_all) DO J=1,JM DO I=1,IM ORO(I,J) = 0.0 @@ -658,8 +656,7 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, XW1_ALL = XW1_ALL + HEIGHT_ALL XW2_ALL = XW2_ALL + HEIGHT_ALL ** 2 - if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO_RAD,LATO_RAD))then + if(inside_a_polygon(LONI*D2R,LATI*D2R,4,LONO_RAD,LATO_RAD))then XLAND = XLAND + FLOAT(ZSLM(ii,jj)) XWATR = XWATR + FLOAT(1-ZSLM(ii,jj)) @@ -721,11 +718,9 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, ENDIF ENDIF - VAR(I,J)=SQRT(MAX(XW2_ALL/XNSUM_ALL- - & (XW1_ALL/XNSUM_ALL)**2,0.)) + VAR(I,J)=SQRT(MAX(XW2_ALL/XNSUM_ALL-(XW1_ALL/XNSUM_ALL)**2,0.)) do I1 = 1, NSUM_ALL - XW4_ALL = XW4_ALL + - & (hgt_1d_all(I1) - ORO(i,j)) ** 4 + XW4_ALL = XW4_ALL + (hgt_1d_all(I1) - ORO(i,j)) ** 4 enddo IF(VAR(I,J).GT.1.) THEN @@ -769,11 +764,11 @@ END SUBROUTINE MAKEMT2 !! @param[in] lat_c Latitude of the model grid corner points. !! @param[in] SLM mask !! @author GFDL Programmer - SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, - 1 IM,JM,IMN,JMN,lon_c,lat_c,SLM) -C -C=== PC: principal coordinates of each Z avg orog box for L&M -C + SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, & + IM,JM,IMN,JMN,lon_c,lat_c,SLM) +! +!=== PC: principal coordinates of each Z avg orog box for L&M +! use orog_utils, only : get_index, inside_a_polygon implicit none real, parameter :: REARTH=6.3712E+6 @@ -794,32 +789,32 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, integer i,j,i1,j1,i2,jst,jen,numx,i0,ip1,ijax integer ilist(IMN) LOGICAL DEBUG -C=== DATA DEBUG/.TRUE./ +!=== DATA DEBUG/.TRUE./ DATA DEBUG/.FALSE./ -C + print*,"- CREATE PRINCIPLE COORDINATES." PI = 4.0 * ATAN(1.0) CERTH = PI * REARTH -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C +!---- GLOBAL XLAT AND XLON ( DEGREE ) +! DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION DELTAY = CERTH / FLOAT(JMN) -C + DO J=1,JMN GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 DELTAX(J) = DELTAY * COS(GLAT(J)*D2R) ENDDO -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C - -C... DERIVITIVE TENSOR OF HEIGHT -C -!$omp parallel do -!$omp* private (j,i,xnsum,xland,xfp,yfp,xfpyfp, -!$omp* xfp2,yfp2,lono,lato,jst,jen,ilist,numx,j1,i2,i1, -!$omp* loni,lati,i0,ip1,hi0,hip1,hj0,hjp1,ijax, -!$omp* hijax,hi1j1,lono_rad,lato_rad) +! +!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX +! + +!... DERIVITIVE TENSOR OF HEIGHT +! +!$omp parallel do & +!$omp private (j,i,xnsum,xland,xfp,yfp,xfpyfp, & +!$omp xfp2,yfp2,lono,lato,jst,jen,ilist,numx,j1,i2,i1, & +!$omp loni,lati,i0,ip1,hi0,hip1,hj0,hjp1,ijax, & +!$omp hijax,hi1j1,lono_rad,lato_rad) JLOOP : DO J=1,JM ILOOP : DO I=1,IM HX2(I,J) = 0.0 @@ -856,31 +851,31 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, i1 = ilist(i2) LONI = i1*DELXN LATI = -90 + j1*DELXN - INSIDE : if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO_RAD,LATO_RAD))then + INSIDE : if(inside_a_polygon(LONI*D2R,LATI*D2R,4, & + LONO_RAD,LATO_RAD))then -C=== set the rest of the indexs for ave: 2pt staggered derivitive -C +!=== set the rest of the indexs for ave: 2pt staggered derivitive +! i0 = i1 - 1 if (i1 - 1 .le. 0 ) i0 = i0 + imn if (i1 - 1 .gt. imn) i0 = i0 - imn -C + ip1 = i1 + 1 if (i1 + 1 .le. 0 ) ip1 = ip1 + imn if (i1 + 1 .gt. imn) ip1 = ip1 - imn XLAND = XLAND + FLOAT(ZSLM(I1,J1)) XNSUM = XNSUM + 1. -C + hi0 = float(zavg(i0,j1)) hip1 = float(zavg(ip1,j1)) -C + if(hi0 .lt. -990.) hi0 = 0.0 if(hip1 .lt. -990.) hip1 = 0.0 -C........ xfp = xfp + 0.5 * ( hip1 - hi0 ) / DELTAX(J1) +!........ xfp = xfp + 0.5 * ( hip1 - hi0 ) / DELTAX(J1) xfp = 0.5 * ( hip1 - hi0 ) / DELTAX(J1) xfp2 = xfp2 + 0.25 * ( ( hip1 - hi0 )/DELTAX(J1) )** 2 -C + ! --- not at boundaries !RAB if ( J1 .ne. JST(1) .and. J1 .ne. JEN(JM) ) then if ( J1 .ne. 1 .and. J1 .ne. JMN ) then @@ -888,30 +883,29 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, hjp1 = float(zavg(i1,j1+1)) if(hj0 .lt. -990.) hj0 = 0.0 if(hjp1 .lt. -990.) hjp1 = 0.0 -C....... yfp = yfp + 0.5 * ( hjp1 - hj0 ) / DELTAY +!....... yfp = yfp + 0.5 * ( hjp1 - hj0 ) / DELTAY yfp = 0.5 * ( hjp1 - hj0 ) / DELTAY yfp2 = yfp2 + 0.25 * ( ( hjp1 - hj0 )/DELTAY )**2 -C -C..............elseif ( J1 .eq. JST(J) .or. J1 .eq. JEN(JM) ) then -C === the NH pole: NB J1 goes from High at NP to Low toward SP -C +! +!..............elseif ( J1 .eq. JST(J) .or. J1 .eq. JEN(JM) ) then +! === the NH pole: NB J1 goes from High at NP to Low toward SP +! !RAB elseif ( J1 .eq. JST(1) ) then elseif ( J1 .eq. 1 ) then ijax = i1 + imn/2 if (ijax .le. 0 ) ijax = ijax + imn if (ijax .gt. imn) ijax = ijax - imn -C..... at N pole we stay at the same latitude j1 but cross to opp side +!..... at N pole we stay at the same latitude j1 but cross to opp side hijax = float(zavg(ijax,j1)) hi1j1 = float(zavg(i1,j1)) if(hijax .lt. -990.) hijax = 0.0 if(hi1j1 .lt. -990.) hi1j1 = 0.0 -C....... yfp = yfp + 0.5 * ( ( 0.5 * ( hijax + hi1j1) ) - hi1j1 )/DELTAY +!....... yfp = yfp + 0.5 * ( ( 0.5 * ( hijax + hi1j1) ) - hi1j1 )/DELTAY yfp = 0.5 * ( ( 0.5 * ( hijax - hi1j1 ) ) )/DELTAY - yfp2 = yfp2 + 0.25 * ( ( 0.5 * ( hijax - hi1j1) ) - 1 / DELTAY )**2 -C -C === the SH pole: NB J1 goes from High at NP to Low toward SP -C + yfp2 = yfp2 + 0.25 * ( ( 0.5 * ( hijax - hi1j1) ) / DELTAY )**2 +! +! === the SH pole: NB J1 goes from High at NP to Low toward SP +! elseif ( J1 .eq. JMN ) then ijax = i1 + imn/2 if (ijax .le. 0 ) ijax = ijax + imn @@ -920,26 +914,24 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, hi1j1 = float(zavg(i1,j1)) if(hijax .lt. -990.) hijax = 0.0 if(hi1j1 .lt. -990.) hi1j1 = 0.0 -C..... yfp = yfp + 0.5 * (0.5 * ( hijax - hi1j1) )/DELTAY +!..... yfp = yfp + 0.5 * (0.5 * ( hijax - hi1j1) )/DELTAY yfp = 0.5 * (0.5 * ( hijax - hi1j1) )/DELTAY - yfp2 = yfp2 + 0.25 * ( (0.5 * (hijax - hi1j1) ) - 1 / DELTAY )**2 + yfp2 = yfp2 + 0.25 * ( (0.5 * (hijax - hi1j1) ) / DELTAY )**2 endif -C -C === The above does an average across the pole for the bndry in j. -C23456789012345678901234567890123456789012345678901234567890123456789012...... -C +! +! === The above does an average across the pole for the bndry in j. +! xfpyfp = xfpyfp + xfp * yfp ENDIF INSIDE -C -C === average the HX2, HY2 and HXY -C === This will be done over all land -C +! +! === average the HX2, HY2 and HXY +! === This will be done over all land +! ENDDO ENDDO -C -C === HTENSR -C +! +! === HTENSR +! XNSUM_GT_1 : IF(XNSUM.GT.1.) THEN IF(SLM(I,J).NE.0.) THEN IF (XLAND > 0) THEN @@ -952,39 +944,37 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, HXY(I,J) = xfpyfp / XNSUM ENDIF ENDIF -C=== degub testing +!=== degub testing if (debug) then - print *," I,J,i1,j1:", I,J,i1,j1, - 1 XLAND,SLM(i,j) + print *," I,J,i1,j1:", I,J,i1,j1,XLAND,SLM(i,j) print *," xfpyfp,xfp2,yfp2:",xfpyfp,xfp2,yfp2 print *," HX2,HY2,HXY:",HX2(I,J),HY2(I,J),HXY(I,J) ENDIF -C -C === make the principal axes, theta, and the degree of anisotropy, -C === and sigma2, the slope parameter -C +! +! === make the principal axes, theta, and the degree of anisotropy, +! === and sigma2, the slope parameter +! HK(I,J) = 0.5 * ( HX2(I,J) + HY2(I,J) ) HL(I,J) = 0.5 * ( HX2(I,J) - HY2(I,J) ) HLPRIM(I,J) = SQRT(HL(I,J)*HL(I,J) + HXY(I,J)*HXY(I,J)) IF( HL(I,J).NE. 0. .AND. SLM(I,J) .NE. 0. ) THEN -C + THETA(I,J) = 0.5 * ATAN2(HXY(I,J),HL(I,J)) / D2R -C === for testing print out in degrees -C THETA(I,J) = 0.5 * ATAN2(HXY(I,J),HL(I,J)) +! === for testing print out in degrees +! THETA(I,J) = 0.5 * ATAN2(HXY(I,J),HL(I,J)) ENDIF SIGMA2(I,J) = ( HK(I,J) + HLPRIM(I,J) ) if ( SIGMA2(I,J) .GE. 0. ) then SIGMA(I,J) = SQRT(SIGMA2(I,J) ) - if (sigma2(i,j) .ne. 0. .and. - & HK(I,J) .GE. HLPRIM(I,J) ) - 1 GAMMA(I,J) = sqrt( (HK(I,J) - HLPRIM(I,J)) / SIGMA2(I,J) ) + if (sigma2(i,j) .ne. 0. .and. & + HK(I,J) .GE. HLPRIM(I,J) ) & + GAMMA(I,J) = sqrt( (HK(I,J) - HLPRIM(I,J)) / SIGMA2(I,J) ) else SIGMA(I,J)=0. endif ENDIF XNSUM_GT_1 if (debug) then - print *," I,J,THETA,SIGMA,GAMMA,",I,J,THETA(I,J), - 1 SIGMA(I,J),GAMMA(I,J) + print *," I,J,THETA,SIGMA,GAMMA,",I,J,THETA(I,J),SIGMA(I,J),GAMMA(I,J) print *," HK,HL,HLPRIM:",HK(I,J),HL(I,J),HLPRIM(I,J) endif ENDDO ILOOP @@ -1029,14 +1019,14 @@ END SUBROUTINE MAKEPC2 !! @param[in] is_south_pole Is the model point at the south pole? !! @param[in] is_north_pole is the model point at the north pole? !! @author GFDL Programmer - SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, - 1 ORO,oro1,XNSUM,XNSUM1,XNSUM2,XNSUM3,XNSUM4, - 2 IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t,dx,dy, - 3 is_south_pole,is_north_pole ) - use orog_utils, only : get_lat_angle, get_lon_angle, - & get_index, inside_a_polygon, - & get_xnsum, get_xnsum2, - & get_xnsum3 + SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, & + ORO,oro1,XNSUM,XNSUM1,XNSUM2,XNSUM3,XNSUM4, & + IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t,dx,dy, & + is_south_pole,is_north_pole ) + use orog_utils, only : get_lat_angle, get_lon_angle, & + get_index, inside_a_polygon, & + get_xnsum, get_xnsum2, & + get_xnsum3 implicit none real, parameter :: MISSING_VALUE = -9999. real, parameter :: D2R = 3.14159265358979/180. @@ -1068,26 +1058,25 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, integer jst, jen print*,"- CREATE ASYMETRY AND LENGTH SCALE." -C -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C +! +!---- GLOBAL XLAT AND XLON ( DEGREE ) +! DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C + DO J=1,JMN GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 ENDDO print*,'- IM=',IM,' JM=',JM,' IMN=',IMN,' JMN=',JMN -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C -C +! +!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX +! DO J=1,JM DO I=1,IM XNSUM(I,J) = 0.0 ELVMAX(I,J) = ORO(I,J) ZMAX(I,J) = 0.0 -C---- COUNT NUMBER OF MODE. HIGHER THAN THE HC, CRITICAL HEIGHT -C IN A GRID BOX +!---- COUNT NUMBER OF MODE. HIGHER THAN THE HC, CRITICAL HEIGHT +! IN A GRID BOX XNSUM1(I,J) = 0.0 XNSUM2(I,J) = 0.0 XNSUM3(I,J) = 0.0 @@ -1099,9 +1088,9 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, ! --- # of peaks > ZAVG value and ZMAX(IM,JM) -- ORO is already avg. ! --- to JM or to JM1 -!$omp parallel do -!$omp* private (j,i,hc,lono,lato,jst,jen,ilist,numx,j1,ii1,i1,loni, -!$omp* lati,height,lono_rad,lato_rad) +!$omp parallel do & +!$omp private (j,i,hc,lono,lato,jst,jen,ilist,numx,j1,ii1,i1,loni, & +!$omp lati,height,lono_rad,lato_rad) DO J=1,JM DO I=1,IM HC = 1116.2 - 0.878 * VAR(I,J) @@ -1120,8 +1109,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, i1 = ilist(ii1) LONI = i1*DELXN LATI = -90 + j1*DELXN - if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO_RAD,LATO_RAD))then + if(inside_a_polygon(LONI*D2R,LATI*D2R,4, & + LONO_RAD,LATO_RAD))then HEIGHT = FLOAT(ZAVG(I1,J1)) IF(HEIGHT.LT.-990.) HEIGHT = 0.0 @@ -1133,12 +1122,11 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, ENDDO ENDDO !$omp end parallel do -C + ! --- this will make work1 array take on oro's values on return ! --- this will make work1 array take on oro's values on return DO J=1,JM DO I=1,IM - ORO1(I,J) = ORO(I,J) ELVMAX(I,J) = ZMAX(I,J) ENDDO @@ -1154,19 +1142,18 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, ENDDO ! ! --- # of peaks > ZAVG value and ZMAX(IM,JM) -- ORO is already avg. -C -C---- CALCULATE THE 3D OROGRAPHIC ASYMMETRY FOR 4 WIND DIRECTIONS -C---- AND THE 3D OROGRAPHIC SUBGRID OROGRAPHY FRACTION -C (KWD = 1 2 3 4) -C ( WD = W S SW NW) -C -C -!$omp parallel do -!$omp* private (j,i,lon,lat,kwd,dlon,dlat,lon1,lon2,lat1,lat2, -!$omp* xnsum11,xnsum12,xnsum21,xnsum22,xnpu,xnpd, -!$omp* xnsum1_11,xnsum2_11,hc_11, xnsum1_12,xnsum2_12, -!$omp* hc_12,xnsum1_21,xnsum2_21,hc_21, xnsum1_22, -!$omp* xnsum2_22,hc_22) +! +!---- CALCULATE THE 3D OROGRAPHIC ASYMMETRY FOR 4 WIND DIRECTIONS +!---- AND THE 3D OROGRAPHIC SUBGRID OROGRAPHY FRACTION +! (KWD = 1 2 3 4) +! ( WD = W S SW NW) + +!$omp parallel do & +!$omp private (j,i,lon,lat,kwd,dlon,dlat,lon1,lon2,lat1,lat2, & +!$omp xnsum11,xnsum12,xnsum21,xnsum22,xnpu,xnpd, & +!$omp xnsum1_11,xnsum2_11,hc_11, xnsum1_12,xnsum2_12, & +!$omp hc_12,xnsum1_21,xnsum2_21,hc_21, xnsum1_22, & +!$omp xnsum2_22,hc_22) DO J=1,JM DO I=1,IM lon = lon_t(i,j) @@ -1199,8 +1186,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, if( lat+dlat*2 > 90.) then dlat_old = dlat dlat = (90-lat)*0.5 - print*, "- AT I,J=",i,j," ADJUST DLAT FROM ", - & dlat_old, " TO ", dlat + print*, "- AT I,J=",i,j," ADJUST DLAT FROM ", & + dlat_old, " TO ", dlat endif !--- lower left lon1 = lon-dlon*1.5 @@ -1211,8 +1198,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, if(lat1<-90 .or. lat2>90) then print*, "- AT UPPER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 endif - xnsum11 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,zslm,delxn) + xnsum11 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,zslm,delxn) !--- upper left lon1 = lon-dlon*1.5 @@ -1222,8 +1209,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, if(lat1<-90 .or. lat2>90) then print*, "- AT LOWER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 endif - xnsum12 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,zslm,delxn) + xnsum12 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,zslm,delxn) !--- lower right lon1 = lon-dlon*0.5 @@ -1233,8 +1220,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, if(lat1<-90 .or. lat2>90) then print*, "- AT UPPER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 endif - xnsum21 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,zslm,delxn) + xnsum21 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,zslm,delxn) !--- upper right lon1 = lon-dlon*0.5 @@ -1245,8 +1232,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, print*, "- AT LOWER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 endif - xnsum22 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,zslm,delxn) + xnsum22 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,zslm,delxn) XNPU = xnsum11 + xnsum12 XNPD = xnsum21 + xnsum22 @@ -1274,8 +1261,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, if(lat1<-90 .or. lat2>90) then print*, "- AT UPPER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 endif - call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_11, xnsum2_11, HC_11) + call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_11, xnsum2_11, HC_11) !--- upper left lon1 = lon-dlon*1.5 @@ -1285,8 +1272,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, if(lat1<-90 .or. lat2>90) then print*, "- AT LOWER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 endif - call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_12, xnsum2_12, HC_12) + call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_12, xnsum2_12, HC_12) !--- lower right lon1 = lon-dlon*0.5 @@ -1296,8 +1283,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, if(lat1<-90 .or. lat2>90) then print*, "- AT UPPER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 endif - call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_21, xnsum2_21, HC_21) + call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_21, xnsum2_21, HC_21) !--- upper right lon1 = lon-dlon*0.5 @@ -1307,8 +1294,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, if(lat1<-90 .or. lat2>90) then print*, "- AT LOWER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 endif - call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_22, xnsum2_22, HC_22) + call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_22, xnsum2_22, HC_22) OL(i,j,3) = (XNSUM1_22+XNSUM1_11)/(XNSUM2_22+XNSUM2_11) OL(i,j,4) = (XNSUM1_12+XNSUM1_21)/(XNSUM2_12+XNSUM2_21) @@ -1322,8 +1309,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, if(lat1<-90 .or. lat2>90) then print*, "- AT UPPER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 endif - call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_11, xnsum2_11, HC_11) + call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_11, xnsum2_11, HC_11) !--- upper left lon1 = lon-dlon*2.0 @@ -1334,8 +1321,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, print*, "- AT LOWER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 endif - call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_12, xnsum2_12, HC_12) + call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_12, xnsum2_12, HC_12) !--- lower right lon1 = lon-dlon @@ -1345,8 +1332,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, if(lat1<-90 .or. lat2>90) then print*, "- AT UPPER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 endif - call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_21, xnsum2_21, HC_21) + call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_21, xnsum2_21, HC_21) !--- upper right lon1 = lon-dlon @@ -1357,8 +1344,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, print*, "- AT LOWER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 endif - call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_22, xnsum2_22, HC_22) + call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_22, xnsum2_22, HC_22) OL(i,j,1) = (XNSUM1_11+XNSUM1_21)/(XNSUM2_11+XNSUM2_21) OL(i,j,2) = (XNSUM1_21+XNSUM1_22)/(XNSUM2_21+XNSUM2_22) @@ -1374,7 +1361,7 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, ENDDO ENDDO ENDDO -C + NS0 = 0 NS1 = 0 NS2 = 0 From 39db5c5bf49d1a0719e8f14fe78162762d3fd935 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 18 Sep 2024 15:27:03 -0500 Subject: [PATCH 51/54] Add intent attributes to all routines in mtnlm7_oclsm.F90. Fixes #970. --- .../orog.fd/mtnlm7_oclsm.F90 | 179 +++++++++++------- 1 file changed, 106 insertions(+), 73 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 index 4a5285842..0bfd084f4 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 @@ -68,45 +68,42 @@ !! - CONTAINS ONLY LAND MASK AND FRACTION. !! !! @return 0 for success, error code otherwise. - use io_utils, only : read_mdl_dims - implicit none - character(len=256) :: mdl_grid_file = "none" - character(len=256) :: external_mask_file = "none" - integer :: imn, jmn, im, jm, efac - logical :: mask_only = .false. + use io_utils, only : read_mdl_dims + implicit none - print*,"- BEGIN OROGRAPHY PROGRAM." + character(len=256) :: mdl_grid_file = "none" + character(len=256) :: external_mask_file = "none" + integer :: im, jm, efac + logical :: mask_only = .false. - read(5,*) mdl_grid_file - read(5,*) mask_only - read(5,*) external_mask_file + print*,"- BEGIN OROGRAPHY PROGRAM." - efac = 0 - imn = 360*120 - jmn = 180*120 + read(5,*) mdl_grid_file + read(5,*) mask_only + read(5,*) external_mask_file - if (mask_only) then - print*,"- WILL COMPUTE LANDMASK ONLY." - endif + efac = 0 - if (trim(external_mask_file) /= "none") then - print*,"- WILL USE EXTERNAL LANDMASK FROM FILE: ", trim(external_mask_file) - endif + if (mask_only) then + print*,"- WILL COMPUTE LANDMASK ONLY." + endif - call read_mdl_dims(mdl_grid_file, im, jm) + if (trim(external_mask_file) /= "none") then + print*,"- WILL USE EXTERNAL LANDMASK FROM FILE: ", trim(external_mask_file) + endif + + call read_mdl_dims(mdl_grid_file, im, jm) - call tersub(imn,jmn,im,jm,efac,mdl_grid_file,mask_only,external_mask_file) + call tersub(im,jm,efac,mdl_grid_file,mask_only,external_mask_file) - print*,"- NORMAL TERMINATION." + print*,"- NORMAL TERMINATION." - stop - end + stop + end !> Driver routine to compute terrain. !! -!! @param[in] IMN "i" dimension of the input terrain dataset. -!! @param[in] JMN "j" dimension of the input terrain dataset. !! @param[in] IM "i" dimension of the model grid tile. !! @param[in] JM "j" dimension of the model grid tile. !! @param[in] EFAC Factor to adjust orography by its variance. @@ -118,8 +115,7 @@ !! @param[in] EXTERNAL_MASK_FILE File containing an externally !! generated land mask/fraction. !! @author Jordan Alpert NOAA/EMC - SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, & - OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) + SUBROUTINE TERSUB(IM,JM,EFAC,OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) use io_utils, only : qc_orog_by_ramp, write_mask_netcdf, & read_global_mask, read_global_orog, & @@ -128,15 +124,16 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,EFAC, & use orog_utils, only : minmax, timef, remove_isolated_pts implicit none - include 'netcdf.inc' - integer :: IMN,JMN,IM,JM + integer, parameter :: imn = 360*120 + integer, parameter :: jmn = 180*120 + + integer, intent(in) :: IM,JM,efac character(len=*), intent(in) :: OUTGRID character(len=*), intent(in) :: EXTERNAL_MASK_FILE - logical, intent(in) :: mask_only + logical, intent(in) :: mask_only - integer :: efac integer :: i,j integer :: itest,jtest @@ -420,18 +417,27 @@ END SUBROUTINE TERSUB !! @param[in] lon_c Longitude of the model grid corner points. !! @param[in] lat_c Latitude on the model grid corner points. !! @author GFDL Programmer - SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, & - IM,JM,IMN,JMN,lon_c,lat_c) + SUBROUTINE MAKE_MASK(zslm,slm,land_frac, & + im,jm,imn,jmn,lon_c,lat_c) + use orog_utils, only : inside_a_polygon, get_index + implicit none - real, parameter :: D2R = 3.14159265358979/180. - integer, parameter :: MAXSUM=20000000 - integer IM, JM, IMN, JMN, jst, jen + + integer, intent(in) :: zslm(imn,jmn) + integer, intent(in) :: im, jm, imn, jmn + + real, intent(in) :: lon_c(im+1,jm+1), lat_c(im+1,jm+1) + + real, intent(out) :: slm(im,jm) + real, intent(out) :: land_frac(im,jm) + + integer, parameter :: MAXSUM=20000000 + + real, parameter :: D2R = 3.14159265358979/180. + + integer jst, jen real GLAT(JMN), GLON(IMN) - INTEGER ZSLM(IMN,JMN) - real land_frac(IM,JM) - real SLM(IM,JM) - real lon_c(IM+1,JM+1), lat_c(IM+1,JM+1) real LONO(4),LATO(4),LONI,LATI real LONO_RAD(4), LATO_RAD(4) integer JM1,i,j,nsum,nsum_all,ii,jj,numx,i2 @@ -551,18 +557,28 @@ END SUBROUTINE MAKE_MASK !! @author GFDL Programmer SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, & IM,JM,IMN,JMN,lon_c,lat_c,lake_frac,land_frac) + use orog_utils, only : inside_a_polygon, get_index + implicit none - real, parameter :: D2R = 3.14159265358979/180. - integer, parameter :: MAXSUM=20000000 + + integer, intent(in) :: zavg(imn,jmn),zslm(imn,jmn) + integer, intent(in) :: im, jm, imn, jmn + + real, intent(in) :: slm(im,jm) + real, intent(in) :: lake_frac(im,jm),land_frac(im,jm) + real, intent(in) :: lon_c(im+1,jm+1), lat_c(im+1,jm+1) + + real, intent(out) :: oro(im,jm) + real, intent(out) :: var(im,jm),var4(im,jm) + + integer, parameter :: MAXSUM=20000000 + real, parameter :: D2R = 3.14159265358979/180. + real, dimension(:), allocatable :: hgt_1d, hgt_1d_all - integer IM, JM, IMN, JMN + real GLAT(JMN), GLON(IMN) - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - real ORO(IM,JM),VAR(IM,JM),VAR4(IM,JM) - real, intent(in) :: SLM(IM,JM), lake_frac(im,jm),land_frac(im,jm) integer JST, JEN - real lon_c(IM+1,JM+1), lat_c(IM+1,JM+1) real LONO(4),LATO(4),LONI,LATI real LONO_RAD(4), LATO_RAD(4) real HEIGHT @@ -770,17 +786,24 @@ SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, & !=== PC: principal coordinates of each Z avg orog box for L&M ! use orog_utils, only : get_index, inside_a_polygon + implicit none - real, parameter :: REARTH=6.3712E+6 - real, parameter :: D2R = 3.14159265358979/180. - integer :: IM,JM,IMN,JMN - real :: GLAT(JMN),DELTAX(JMN) - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - real lon_c(IM+1,JM+1), lat_c(IM+1,JM+1) - real, intent(in) :: SLM(IM,JM) + + integer, intent(in) :: zavg(imn,jmn),zslm(imn,jmn) + integer, intent(in) :: im,jm,imn,jmn + + real, intent(in) :: lon_c(im+1,jm+1), lat_c(im+1,jm+1) + real, intent(in) :: slm(im,jm) + + real, intent(out) :: theta(im,jm), gamma(im,jm), sigma(im,jm) + + real, parameter :: REARTH=6.3712E+6 + real, parameter :: D2R = 3.14159265358979/180. + + real GLAT(JMN),DELTAX(JMN) real HL(IM,JM),HK(IM,JM) real HX2(IM,JM),HY2(IM,JM),HXY(IM,JM),HLPRIM(IM,JM) - real THETA(IM,JM),GAMMA(IM,JM),SIGMA2(IM,JM),SIGMA(IM,JM) + real SIGMA2(IM,JM) real PI,CERTH,DELXN,DELTAY,XNSUM,XLAND real xfp,yfp,xfpyfp,xfp2,yfp2 real hi0,hip1,hj0,hjp1,hijax,hi1j1 @@ -1023,39 +1046,49 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, & ORO,oro1,XNSUM,XNSUM1,XNSUM2,XNSUM3,XNSUM4, & IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t,dx,dy, & is_south_pole,is_north_pole ) + use orog_utils, only : get_lat_angle, get_lon_angle, & get_index, inside_a_polygon, & get_xnsum, get_xnsum2, & get_xnsum3 + implicit none - real, parameter :: MISSING_VALUE = -9999. - real, parameter :: D2R = 3.14159265358979/180. - integer IM,JM,IMN,JMN - real GLAT(JMN) - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - real ORO(IM,JM),ORO1(IM,JM),ELVMAX(IM,JM),ZMAX(IM,JM) - real OA4(IM,JM,4) - integer IOA4(IM,JM,4) - real lon_c(IM+1,JM+1), lat_c(IM+1,JM+1) - real lon_t(IM,JM), lat_t(IM,JM) - real dx(IM,JM), dy(IM,JM) - logical is_south_pole(IM,JM), is_north_pole(IM,JM) - real XNSUM(IM,JM),XNSUM1(IM,JM),XNSUM2(IM,JM) - real XNSUM3(IM,JM),XNSUM4(IM,JM) - real VAR(IM,JM),OL(IM,JM,4) + + integer, intent(in) :: im,jm,imn,jmn + integer, intent(in) :: zavg(imn,jmn),zslm(imn,jmn) + + logical, intent(in) :: is_south_pole(im,jm), is_north_pole(im,jm) + + real, intent(in) :: dx(im,jm), dy(im,jm) + real, intent(in) :: lon_c(im+1,jm+1), lat_c(im+1,jm+1) + real, intent(in) :: lon_t(im,jm), lat_t(im,jm) + + integer, intent(out) :: ioa4(im,jm,4) + + real, intent(out) :: var(im,jm),ol(im,jm,4),oa4(im,jm,4) + real, intent(out) :: oro(im,jm),oro1(im,jm),elvmax(im,jm) + real, intent(out) :: xnsum(im,jm),xnsum1(im,jm),xnsum2(im,jm) + real, intent(out) :: xnsum3(im,jm),xnsum4(im,jm) + + real, parameter :: MISSING_VALUE = -9999. + real, parameter :: D2R = 3.14159265358979/180. + integer i,j,ilist(IMN),numx,i1,j1,ii1 integer KWD + integer jst, jen + integer NS0,NS1,NS2,NS3,NS4,NS5,NS6 + + real GLAT(JMN) + real ZMAX(IM,JM) real LONO(4),LATO(4),LONI,LATI real LONO_RAD(4), LATO_RAD(4) real DELXN,HC,HEIGHT,XNPU,XNPD,T - integer NS0,NS1,NS2,NS3,NS4,NS5,NS6 real lon,lat,dlon,dlat,dlat_old real lon1,lat1,lon2,lat2 real xnsum11,xnsum12,xnsum21,xnsum22 real HC_11, HC_12, HC_21, HC_22 real xnsum1_11,xnsum1_12,xnsum1_21,xnsum1_22 real xnsum2_11,xnsum2_12,xnsum2_21,xnsum2_22 - integer jst, jen print*,"- CREATE ASYMETRY AND LENGTH SCALE." ! From f8a5626b764e81125502eec0c006f4ffbcea7222 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Thu, 19 Sep 2024 12:25:19 -0500 Subject: [PATCH 52/54] Remove some unused variables. Fixes #970. --- .../orog.fd/mtnlm7_oclsm.F90 | 51 +++++-------------- 1 file changed, 12 insertions(+), 39 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 index 0bfd084f4..4b1653449 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 @@ -141,8 +141,6 @@ SUBROUTINE TERSUB(IM,JM,EFAC,OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) integer(1), allocatable :: UMD(:,:) integer(2), allocatable :: glob(:,:) - integer, allocatable :: IWORK(:,:,:) - real :: tbeg,tend,tbeg1 real, allocatable :: XLAT(:),XLON(:) @@ -152,8 +150,6 @@ SUBROUTINE TERSUB(IM,JM,EFAC,OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) real, allocatable :: land_frac(:,:),lake_frac(:,:) real, allocatable :: THETA(:,:),GAMMA(:,:),SIGMA(:,:),ELVMAX(:,:) real, allocatable :: VAR4(:,:) - real, allocatable :: WORK1(:,:),WORK2(:,:),WORK3(:,:),WORK4(:,:) - real, allocatable :: WORK5(:,:),WORK6(:,:) real, allocatable :: OA(:,:,:),OL(:,:,:),HPRIME(:,:,:) logical :: is_south_pole(IM,JM), is_north_pole(IM,JM) @@ -267,27 +263,19 @@ SUBROUTINE TERSUB(IM,JM,EFAC,OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) ! COMPUTE MOUNTAIN DATA : OA OL - allocate (IWORK(IM,JM,4)) allocate (OA(IM,JM,4),OL(IM,JM,4)) - allocate (WORK1(IM,JM),WORK2(IM,JM),WORK3(IM,JM),WORK4(IM,JM)) - allocate (WORK5(IM,JM),WORK6(IM,JM)) tbeg=timef() - CALL MAKEOA2(ZAVG,zslm,VAR,OA,OL,IWORK,ELVMAX,ORO, & - WORK1,WORK2,WORK3,WORK4,WORK5,WORK6, & + CALL MAKEOA2(ZAVG,zslm,VAR,OA,OL,ELVMAX,ORO, & IM,JM,IMN,JMN,geolon_c,geolat_c, & geolon,geolat,dx,dy,is_south_pole,is_north_pole) + tend=timef() print*,"- TIMING: CREATE ASYMETRY AND LENGTH SCALE ",tend-tbeg -! Deallocate 2d vars deallocate (ZSLM,ZAVG) deallocate (dx,dy) - deallocate (WORK2,WORK3,WORK4,WORK5,WORK6) - -! Deallocate 3d vars - deallocate(IWORK) tbeg=timef() call minmax(IM,JM,OA,'OA ') @@ -367,7 +355,6 @@ SUBROUTINE TERSUB(IM,JM,EFAC,OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) ENDDO deallocate(VAR4) - deallocate (WORK1) call minmax(IM,JM,ELVMAX,'ELVMAX ',itest,jtest) call minmax(IM,JM,ORO,'ORO ') @@ -1018,15 +1005,8 @@ END SUBROUTINE MAKEPC2 !! directional components - W/S/SW/NW !! @param[out] ol Orographic length scale on the model grid. Four !! directional components - W/S/SW/NW -!! @param[out] ioa4 Count of oa4 values between certain thresholds. !! @param[out] elvmax Maximum elevation within a model grid box. !! @param[in] oro Orography on the model grid. -!! @param[out] oro1 Save array for model grid orography. -!! @param[out] xnsum Not used. -!! @param[out] xnsum1 Not used. -!! @param[out] xnsum2 Not used. -!! @param[out] xnsum3 Not used. -!! @param[out] xnsum4 Not used. !! @param[in] im "i" dimension of the model grid tile. !! @param[in] jm "j" dimension of the model grid tile. !! @param[in] imn "i" dimension of the high-resolution orography and @@ -1042,8 +1022,7 @@ END SUBROUTINE MAKEPC2 !! @param[in] is_south_pole Is the model point at the south pole? !! @param[in] is_north_pole is the model point at the north pole? !! @author GFDL Programmer - SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, & - ORO,oro1,XNSUM,XNSUM1,XNSUM2,XNSUM3,XNSUM4, & + SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,ELVMAX,ORO,& IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t,dx,dy, & is_south_pole,is_north_pole ) @@ -1062,17 +1041,16 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, & real, intent(in) :: dx(im,jm), dy(im,jm) real, intent(in) :: lon_c(im+1,jm+1), lat_c(im+1,jm+1) real, intent(in) :: lon_t(im,jm), lat_t(im,jm) + real, intent(in) :: oro(im,jm), var(im,jm) - integer, intent(out) :: ioa4(im,jm,4) - - real, intent(out) :: var(im,jm),ol(im,jm,4),oa4(im,jm,4) - real, intent(out) :: oro(im,jm),oro1(im,jm),elvmax(im,jm) - real, intent(out) :: xnsum(im,jm),xnsum1(im,jm),xnsum2(im,jm) - real, intent(out) :: xnsum3(im,jm),xnsum4(im,jm) + real, intent(out) :: ol(im,jm,4),oa4(im,jm,4) + real, intent(out) :: elvmax(im,jm) real, parameter :: MISSING_VALUE = -9999. real, parameter :: D2R = 3.14159265358979/180. + integer, allocatable :: ioa4(:,:,:) + integer i,j,ilist(IMN),numx,i1,j1,ii1 integer KWD integer jst, jen @@ -1105,16 +1083,10 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, & ! DO J=1,JM DO I=1,IM - XNSUM(I,J) = 0.0 ELVMAX(I,J) = ORO(I,J) ZMAX(I,J) = 0.0 !---- COUNT NUMBER OF MODE. HIGHER THAN THE HC, CRITICAL HEIGHT ! IN A GRID BOX - XNSUM1(I,J) = 0.0 - XNSUM2(I,J) = 0.0 - XNSUM3(I,J) = 0.0 - XNSUM4(I,J) = 0.0 - ORO1(I,J) = ORO(I,J) ELVMAX(I,J) = ZMAX(I,J) ENDDO ENDDO @@ -1156,11 +1128,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, & ENDDO !$omp end parallel do -! --- this will make work1 array take on oro's values on return -! --- this will make work1 array take on oro's values on return DO J=1,JM DO I=1,IM - ORO1(I,J) = ORO(I,J) ELVMAX(I,J) = ZMAX(I,J) ENDDO ENDDO @@ -1395,6 +1364,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, & ENDDO ENDDO + ALLOCATE(IOA4(IM,JM,4)) + NS0 = 0 NS1 = 0 NS2 = 0 @@ -1431,6 +1402,8 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,IOA4,ELVMAX, & ENDDO ENDDO ENDDO + + DEALLOCATE(IOA4) RETURN From 2e841864aa13330680ae209f7b0460c6eb6322e3 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Thu, 19 Sep 2024 13:20:42 -0500 Subject: [PATCH 53/54] Remove unused logic. Fixes #970. --- .../orog.fd/mtnlm7_oclsm.F90 | 73 ++++--------------- 1 file changed, 14 insertions(+), 59 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 index 4b1653449..d8e55c96a 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 @@ -1049,24 +1049,20 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,ELVMAX,ORO,& real, parameter :: MISSING_VALUE = -9999. real, parameter :: D2R = 3.14159265358979/180. - integer, allocatable :: ioa4(:,:,:) - - integer i,j,ilist(IMN),numx,i1,j1,ii1 - integer KWD - integer jst, jen - integer NS0,NS1,NS2,NS3,NS4,NS5,NS6 - - real GLAT(JMN) - real ZMAX(IM,JM) - real LONO(4),LATO(4),LONI,LATI - real LONO_RAD(4), LATO_RAD(4) - real DELXN,HC,HEIGHT,XNPU,XNPD,T - real lon,lat,dlon,dlat,dlat_old - real lon1,lat1,lon2,lat2 - real xnsum11,xnsum12,xnsum21,xnsum22 - real HC_11, HC_12, HC_21, HC_22 - real xnsum1_11,xnsum1_12,xnsum1_21,xnsum1_22 - real xnsum2_11,xnsum2_12,xnsum2_21,xnsum2_22 + integer :: i,j,ilist(imn),numx,i1,j1,ii1 + integer :: jst, jen, kwd + + real :: glat(jmn) + real :: zmax(im,jm) + real :: lono(4),lato(4),loni,lati + real :: lono_rad(4), lato_rad(4) + real :: delxn,hc,height,xnpu,xnpd,t + real :: lon,lat,dlon,dlat,dlat_old + real :: lon1,lat1,lon2,lat2 + real :: xnsum11,xnsum12,xnsum21,xnsum22 + real :: hc_11, hc_12, hc_21, hc_22 + real :: xnsum1_11,xnsum1_12,xnsum1_21,xnsum1_22 + real :: xnsum2_11,xnsum2_12,xnsum2_21,xnsum2_22 print*,"- CREATE ASYMETRY AND LENGTH SCALE." ! @@ -1364,47 +1360,6 @@ SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,ELVMAX,ORO,& ENDDO ENDDO - ALLOCATE(IOA4(IM,JM,4)) - - NS0 = 0 - NS1 = 0 - NS2 = 0 - NS3 = 0 - NS4 = 0 - NS5 = 0 - NS6 = 0 - DO KWD=1,4 - DO J=1,JM - DO I=1,IM - T = ABS( OA4(I,J,KWD) ) - IF(T .EQ. 0.) THEN - IOA4(I,J,KWD) = 0 - NS0 = NS0 + 1 - ELSE IF(T .GT. 0. .AND. T .LE. 1.) THEN - IOA4(I,J,KWD) = 1 - NS1 = NS1 + 1 - ELSE IF(T .GT. 1. .AND. T .LE. 10.) THEN - IOA4(I,J,KWD) = 2 - NS2 = NS2 + 1 - ELSE IF(T .GT. 10. .AND. T .LE. 100.) THEN - IOA4(I,J,KWD) = 3 - NS3 = NS3 + 1 - ELSE IF(T .GT. 100. .AND. T .LE. 1000.) THEN - IOA4(I,J,KWD) = 4 - NS4 = NS4 + 1 - ELSE IF(T .GT. 1000. .AND. T .LE. 10000.) THEN - IOA4(I,J,KWD) = 5 - NS5 = NS5 + 1 - ELSE IF(T .GT. 10000.) THEN - IOA4(I,J,KWD) = 6 - NS6 = NS6 + 1 - ENDIF - ENDDO - ENDDO - ENDDO - - DEALLOCATE(IOA4) - RETURN END SUBROUTINE MAKEOA2 From 2de84bc7950eb531dfb93b2b9c2835b7a91feb12 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 24 Sep 2024 15:08:30 +0000 Subject: [PATCH 54/54] Remove a debugging compiler flag. Fixes #970. --- sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt index 373d8c776..955101450 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt +++ b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt @@ -2,7 +2,7 @@ set(lib_src io_utils.F90 orog_utils.F90) set(exe_src mtnlm7_oclsm.F90) if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -warn unused -r8 -convert big_endian -assume byterecl") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -r8 -convert big_endian -assume byterecl") elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8 -fconvert=big-endian -fno-range-check") if(CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 10)