diff --git a/sorc/checkout.sh b/sorc/checkout.sh index 57503a03f5..1e40fc9030 100755 --- a/sorc/checkout.sh +++ b/sorc/checkout.sh @@ -121,4 +121,15 @@ else echo 'Skip. Directory verif-global.fd already exist.' fi +echo global-workflow-utils checkout ... +if [[ ! -d global-workflow-utils.fd ]] ; then + rm -f ${topdir}/checkout-verif-global.log + git clone --recursive https://github.com/NOAA-EMC/global-workflow-utils.git global-workflow-utils.fd >> ${logdir}/checkout-global-workflow-utils.log 2>&1 + cd global-workflow-utils.fd + # git checkout verif_global_v2.8.0 + cd ${topdir} +else + echo 'Skip. Directory global-workflow-utils.fd already exist.' +fi + exit 0 diff --git a/sorc/enkf_chgres_recenter.fd/.gitignore b/sorc/enkf_chgres_recenter.fd/.gitignore deleted file mode 100644 index 544aec4c42..0000000000 --- a/sorc/enkf_chgres_recenter.fd/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -*.exe -*.o -*.mod diff --git a/sorc/enkf_chgres_recenter.fd/CMakeLists.txt b/sorc/enkf_chgres_recenter.fd/CMakeLists.txt deleted file mode 100644 index 36389b8d52..0000000000 --- a/sorc/enkf_chgres_recenter.fd/CMakeLists.txt +++ /dev/null @@ -1,29 +0,0 @@ -list(APPEND fortran_src -driver.f90 -input_data.f90 -interp.f90 -output_data.f90 -setup.f90 -utils.f90 -) - -if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -r8 -i4 -fp-model precise") -elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8") -endif() - -set(exe_name enkf_chgres_recenter.x) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - nemsio::nemsio - bacio::bacio_4 - ip::ip_d - sp::sp_d - w3nco::w3nco_d) -if(OpenMP_Fortran_FOUND) - target_link_libraries(${exe_name} OpenMP::OpenMP_Fortran) -endif() - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/enkf_chgres_recenter.fd/driver.f90 b/sorc/enkf_chgres_recenter.fd/driver.f90 deleted file mode 100644 index 02a138ae8f..0000000000 --- a/sorc/enkf_chgres_recenter.fd/driver.f90 +++ /dev/null @@ -1,65 +0,0 @@ - program recenter - - use setup, only : program_setup - use interp, only : gaus_to_gaus, adjust_for_terrain - use input_data, only : read_input_data, & - read_vcoord_info - use output_data, only : set_output_grid, write_output_data - - implicit none - - call w3tagb('CHGRES_RECENTER',2018,0179,0055,'NP20') - - print*,"STARTING PROGRAM" - -!-------------------------------------------------------- -! Read configuration namelist. -!-------------------------------------------------------- - - call program_setup - -!-------------------------------------------------------- -! Read input grid data -!-------------------------------------------------------- - - call read_input_data - -!-------------------------------------------------------- -! Read vertical coordinate info -!-------------------------------------------------------- - - call read_vcoord_info - -!-------------------------------------------------------- -! Get output grid specs -!-------------------------------------------------------- - - call set_output_grid - -!-------------------------------------------------------- -! Interpolate data to output grid -!-------------------------------------------------------- - - call gaus_to_gaus - -!-------------------------------------------------------- -! Adjust output fields for differences between -! interpolated and external terrain. -!-------------------------------------------------------- - - call adjust_for_terrain - -!-------------------------------------------------------- -! Write output data to file. -!-------------------------------------------------------- - - call write_output_data - - print* - print*,"PROGRAM FINISHED NORMALLY!" - - call w3tage('CHGRES_RECENTER') - - stop - - end program recenter diff --git a/sorc/enkf_chgres_recenter.fd/input_data.f90 b/sorc/enkf_chgres_recenter.fd/input_data.f90 deleted file mode 100644 index 704aa58c8d..0000000000 --- a/sorc/enkf_chgres_recenter.fd/input_data.f90 +++ /dev/null @@ -1,383 +0,0 @@ - module input_data - - use nemsio_module - use utils - use setup - - implicit none - - private - - integer, public :: idvc, idsl, idvm, nvcoord - integer, public :: ntrac, ncldt,icldamt - integer, public :: ij_input, kgds_input(200) - integer(nemsio_intkind), public :: i_input, j_input, lev - integer(nemsio_intkind), public :: idate(7) - - logical, public :: gfdl_mp - - real, allocatable, public :: vcoord(:,:) - real, allocatable, public :: clwmr_input(:,:) - real, allocatable, public :: dzdt_input(:,:) - real, allocatable, public :: grle_input(:,:) - real, allocatable, public :: cldamt_input(:,:) - real, allocatable, public :: hgt_input(:) - real, allocatable, public :: icmr_input(:,:) - real, allocatable, public :: o3mr_input(:,:) - real, allocatable, public :: rwmr_input(:,:) - real, allocatable, public :: sfcp_input(:) - real, allocatable, public :: snmr_input(:,:) - real, allocatable, public :: spfh_input(:,:) - real, allocatable, public :: tmp_input(:,:) - real, allocatable, public :: ugrd_input(:,:) - real, allocatable, public :: vgrd_input(:,:) - - public :: read_input_data - public :: read_vcoord_info - - contains - - subroutine read_input_data - -!------------------------------------------------------------------------------------- -! Read input grid data from a nemsio file. -!------------------------------------------------------------------------------------- - - implicit none - - character(len=20) :: vlevtyp, vname - character(len=50), allocatable :: recname(:) - - integer(nemsio_intkind) :: vlev, iret, idum, nrec - integer :: n - - real(nemsio_realkind), allocatable :: dummy(:) - - type(nemsio_gfile) :: gfile - - call nemsio_init(iret) - - print* - print*,"OPEN INPUT FILE: ",trim(input_file) - call nemsio_open(gfile, input_file, "read", iret=iret) - if (iret /= 0) then - print*,"FATAL ERROR OPENING FILE: ",trim(input_file) - print*,"IRET IS: ", iret - call errexit(2) - endif - - print*,"GET INPUT FILE HEADER" - call nemsio_getfilehead(gfile, iret=iret, nrec=nrec, idate=idate, & - dimx=i_input, dimy=j_input, dimz=lev) - if (iret /= 0) goto 67 - - print*,'DIMENSIONS OF DATA ARE: ', i_input, j_input, lev - print*,'DATE OF DATA IS: ', idate - - ij_input = i_input * j_input - - allocate(recname(nrec)) - - call nemsio_getfilehead(gfile, iret=iret, recname=recname) - if (iret /= 0) goto 67 - - gfdl_mp = .false. ! Zhao-Carr MP - do n = 1, nrec - if (trim(recname(n)) == "icmr") then - gfdl_mp = .true. ! GFDL MP - exit - endif - enddo - - icldamt = 0 - do n = 1, nrec - if (trim(recname(n)) == "cld_amt") then - icldamt = 1 ! 3D cloud amount present - exit - endif - enddo - - call nemsio_getfilehead(gfile, iret=iret, idvc=idum) - if (iret /= 0) goto 67 - idvc = idum - print*,'IDVC IS: ', idvc - - call nemsio_getfilehead(gfile, iret=iret, idsl=idum) - if (iret /= 0) goto 67 - idsl = idum - print*,'IDSL IS: ', idsl - - call nemsio_getfilehead(gfile, iret=iret, idvm=idum) - if (iret /= 0) goto 67 - idvm = idum - print*,'IDVM IS: ', idvm - - if (gfdl_mp) then - ntrac = 7 + icldamt - ncldt = 5 - else - ntrac = 3 - ncldt = 1 - endif - - allocate(dummy(ij_input)) - - ! figure out the sign of delz - print*,"READ DELZ FOR SIGN CHECK" - vlev = 1 - vlevtyp = "mid layer" - vname = "delz" - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - if ( sum(dummy) > 0 ) then - flipdelz = .false. - print*,"DELZ IS POSITIVE" - else - flipdelz = .true. - print*,"DELZ IS NEGATIVE" - end if - - print* - print*,"READ SURFACE PRESSURE" - vlev = 1 - vlevtyp = "sfc" - vname = "pres" - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - - allocate(sfcp_input(ij_input)) - sfcp_input = dummy - print*,'MAX/MIN SURFACE PRESSURE: ',maxval(sfcp_input), minval(sfcp_input) - - print* - print*,"READ SURFACE HEIGHT" - vlev = 1 - vlevtyp = "sfc" - vname = "hgt" - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - - allocate(hgt_input(ij_input)) - hgt_input = dummy - print*,'MAX/MIN SURFACE HEIGHT: ',maxval(hgt_input), minval(hgt_input) - - print* - print*,"READ U WIND" - vname = "ugrd" - vlevtyp = "mid layer" - allocate(ugrd_input(ij_input,lev)) - do vlev = 1, lev - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - ugrd_input(:,vlev) = dummy - print*,'MAX/MIN U WIND AT LEVEL ',vlev, "IS: ", maxval(ugrd_input(:,vlev)), minval(ugrd_input(:,vlev)) - enddo - - print* - print*,"READ V WIND" - vname = "vgrd" - vlevtyp = "mid layer" - allocate(vgrd_input(ij_input,lev)) - do vlev = 1, lev - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - vgrd_input(:,vlev) = dummy - print*,'MAX/MIN V WIND AT LEVEL ', vlev, "IS: ", maxval(vgrd_input(:,vlev)), minval(vgrd_input(:,vlev)) - enddo - - print* - print*,"READ TEMPERATURE" - vname = "tmp" - vlevtyp = "mid layer" - allocate(tmp_input(ij_input,lev)) - do vlev = 1, lev - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - tmp_input(:,vlev) = dummy(:) - print*,'MAX/MIN TEMPERATURE AT LEVEL ', vlev, 'IS: ', maxval(tmp_input(:,vlev)), minval(tmp_input(:,vlev)) - enddo - - print* - print*,"READ SPECIFIC HUMIDITY" - vname = "spfh" - vlevtyp = "mid layer" - allocate(spfh_input(ij_input,lev)) - do vlev = 1, lev - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - spfh_input(:,vlev) = dummy - print*,'MAX/MIN SPECIFIC HUMIDITY AT LEVEL ', vlev, 'IS: ', maxval(spfh_input(:,vlev)), minval(spfh_input(:,vlev)) - enddo - - print* - print*,"READ CLOUD LIQUID WATER" - vname = "clwmr" - vlevtyp = "mid layer" - allocate(clwmr_input(ij_input,lev)) - do vlev = 1, lev - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - clwmr_input(:,vlev) = dummy - print*,'MAX/MIN CLOUD LIQUID WATER AT LEVEL ', vlev, 'IS: ', maxval(clwmr_input(:,vlev)), minval(clwmr_input(:,vlev)) - enddo - - print* - print*,"READ OZONE" - vname = "o3mr" - vlevtyp = "mid layer" - allocate(o3mr_input(ij_input,lev)) - do vlev = 1, lev - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - o3mr_input(:,vlev) = dummy - print*,'MAX/MIN OZONE AT LEVEL ', vlev, 'IS: ', maxval(o3mr_input(:,vlev)), minval(o3mr_input(:,vlev)) - enddo - - print* - print*,"READ DZDT" - vname = "dzdt" - vlevtyp = "mid layer" - allocate(dzdt_input(ij_input,lev)) - do vlev = 1, lev - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - dzdt_input(:,vlev) = dummy - print*,'MAX/MIN DZDT AT LEVEL ', vlev, 'IS: ', maxval(dzdt_input(:,vlev)), minval(dzdt_input(:,vlev)) - enddo - - if (gfdl_mp) then - - print* - print*,"READ RWMR" - vname = "rwmr" - vlevtyp = "mid layer" - allocate(rwmr_input(ij_input,lev)) - do vlev = 1, lev - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - rwmr_input(:,vlev) = dummy - print*,'MAX/MIN RWMR AT LEVEL ', vlev, 'IS: ', maxval(rwmr_input(:,vlev)), minval(rwmr_input(:,vlev)) - enddo - - print* - print*,"READ ICMR" - vname = "icmr" - vlevtyp = "mid layer" - allocate(icmr_input(ij_input,lev)) - do vlev = 1, lev - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - icmr_input(:,vlev) = dummy - print*,'MAX/MIN ICMR AT LEVEL ', vlev, 'IS: ', maxval(icmr_input(:,vlev)), minval(icmr_input(:,vlev)) - enddo - - print* - print*,"READ SNMR" - vname = "snmr" - vlevtyp = "mid layer" - allocate(snmr_input(ij_input,lev)) - do vlev = 1, lev - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - snmr_input(:,vlev) = dummy - print*,'MAX/MIN SNMR AT LEVEL ', vlev, 'IS: ', maxval(snmr_input(:,vlev)), minval(snmr_input(:,vlev)) - enddo - - print* - print*,"READ GRLE" - vname = "grle" - vlevtyp = "mid layer" - allocate(grle_input(ij_input,lev)) - do vlev = 1, lev - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - grle_input(:,vlev) = dummy - print*,'MAX/MIN GRLE AT LEVEL ', vlev, 'IS: ', maxval(grle_input(:,vlev)), minval(grle_input(:,vlev)) - enddo - - if (icldamt == 1) then - print* - print*,"READ CLD_AMT" - vname = "cld_amt" - vlevtyp = "mid layer" - allocate(cldamt_input(ij_input,lev)) - do vlev = 1, lev - write(6,*) 'read ',vname,' on ',vlev - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) goto 67 - cldamt_input(:,vlev) = dummy - print*,'MAX/MIN CLD_AMT AT LEVEL ', vlev, 'IS: ', maxval(cldamt_input(:,vlev)), minval(cldamt_input(:,vlev)) - enddo - endif - - endif - - deallocate(dummy) - - print*,"CLOSE FILE" - call nemsio_close(gfile, iret=iret) - - call nemsio_finalize() - -!--------------------------------------------------------------------------------------- -! Set the grib 1 grid description array need by the NCEP IPOLATES library. -!--------------------------------------------------------------------------------------- - - call calc_kgds(i_input, j_input, kgds_input) - - return - - 67 continue - - print*,"FATAL ERROR READING FILE: ", trim(input_file) - print*,"IRET IS: ", iret - call errexit(3) - - end subroutine read_input_data - - subroutine read_vcoord_info - -!--------------------------------------------------------------------------------- -! Read vertical coordinate information. -!--------------------------------------------------------------------------------- - - implicit none - - integer :: istat, levs_vcoord, n, k - - print* - print*,"OPEN VERTICAL COORD FILE: ", trim(vcoord_file) - open(14, file=trim(vcoord_file), form='formatted', iostat=istat) - if (istat /= 0) then - print*,"FATAL ERROR OPENING FILE. ISTAT IS: ", istat - call errexit(4) - endif - - read(14, *, iostat=istat) nvcoord, levs_vcoord - if (istat /= 0) then - print*,"FATAL ERROR READING FILE HEADER. ISTAT IS: ",istat - call errexit(5) - endif - -!--------------------------------------------------------------------------------- -! The last value in the file is not used for the fv3 core. Only read the first -! (lev + 1) values. -!--------------------------------------------------------------------------------- - - allocate(vcoord(lev+1, nvcoord)) - read(14, *, iostat=istat) ((vcoord(n,k), k=1,nvcoord), n=1,lev+1) - if (istat /= 0) then - print*,"FATAL ERROR READING FILE. ISTAT IS: ",istat - call errexit(6) - endif - - print* - do k = 1, (lev+1) - print*,'VCOORD FOR LEV ', k, 'IS: ', vcoord(k,:) - enddo - - close(14) - - end subroutine read_vcoord_info - - end module input_data diff --git a/sorc/enkf_chgres_recenter.fd/interp.f90 b/sorc/enkf_chgres_recenter.fd/interp.f90 deleted file mode 100644 index bb2afedbc3..0000000000 --- a/sorc/enkf_chgres_recenter.fd/interp.f90 +++ /dev/null @@ -1,552 +0,0 @@ - module interp - - use nemsio_module - - implicit none - - private - - real, allocatable :: sfcp_b4_adj_output(:) - real, allocatable :: clwmr_b4_adj_output(:,:) - real, allocatable :: dzdt_b4_adj_output(:,:) - real, allocatable :: grle_b4_adj_output(:,:) - real, allocatable :: cldamt_b4_adj_output(:,:) - real, allocatable :: icmr_b4_adj_output(:,:) - real, allocatable :: o3mr_b4_adj_output(:,:) - real, allocatable :: rwmr_b4_adj_output(:,:) - real, allocatable :: snmr_b4_adj_output(:,:) - real, allocatable :: spfh_b4_adj_output(:,:) - real, allocatable :: tmp_b4_adj_output(:,:) - real, allocatable :: ugrd_b4_adj_output(:,:) - real, allocatable :: vgrd_b4_adj_output(:,:) - - public :: adjust_for_terrain - public :: gaus_to_gaus - - contains - - subroutine adjust_for_terrain - -!--------------------------------------------------------------------------------- -! Adjust fields based on differences between the interpolated and external -! terrain. -!--------------------------------------------------------------------------------- - - use input_data - use output_data - use utils - use setup - - implicit none - - integer :: k - - real, allocatable :: pres_b4_adj_output(:,:) - real, allocatable :: pres_output(:,:) - real, allocatable :: q_b4_adj_output(:,:,:), q_output(:,:,:) - -!--------------------------------------------------------------------------------- -! First, compute the mid-layer pressure using the interpolated surface pressure. -!--------------------------------------------------------------------------------- - - allocate(pres_b4_adj_output(ij_output,lev)) - pres_b4_adj_output = 0.0 - - print* - print*,"COMPUTE MID-LAYER PRESSURE FROM INTERPOLATED SURFACE PRESSURE." - call newpr1(ij_output, lev, idvc, idsl, nvcoord, vcoord, & - sfcp_b4_adj_output, pres_b4_adj_output) - -!print*,'after newpr1, pres b4 adj: ', pres_b4_adj_output(ij_output/2,:) - -!--------------------------------------------------------------------------------- -! Adjust surface pressure based on differences between interpolated and -! grid terrain. -!--------------------------------------------------------------------------------- - - allocate(sfcp_output(ij_output)) - sfcp_output = 0.0 - - print*,"ADJUST SURFACE PRESSURE BASED ON TERRAIN DIFFERENCES" - call newps(hgt_output, sfcp_b4_adj_output, ij_output, & - lev, pres_b4_adj_output, tmp_b4_adj_output, & - spfh_b4_adj_output, hgt_external_output, sfcp_output) - -!print*,'after newps ',sfcp_b4_adj_output(ij_output/2),sfcp_output(ij_output/2) - - deallocate(sfcp_b4_adj_output) - -!--------------------------------------------------------------------------------- -! Recompute mid-layer pressure based on the adjusted surface pressure. -!--------------------------------------------------------------------------------- - - allocate(pres_output(ij_output, lev)) - pres_output = 0.0 - - allocate(dpres_output(ij_output, lev)) - dpres_output = 0.0 - - print*,"RECOMPUTE MID-LAYER PRESSURE." - call newpr1(ij_output, lev, idvc, idsl, nvcoord, vcoord, & - sfcp_output, pres_output, dpres_output) - -!do k = 1, lev -! print*,'after newpr1 ',pres_b4_adj_output(ij_output/2,k),pres_output(ij_output/2,k), dpres_output(ij_output/2,k) -!enddo - -!--------------------------------------------------------------------------------- -! Vertically interpolate from the pre-adjusted to the adjusted mid-layer -! pressures. -!--------------------------------------------------------------------------------- - - allocate(q_b4_adj_output(ij_output,lev,ntrac)) - q_b4_adj_output(:,:,1) = spfh_b4_adj_output(:,:) - q_b4_adj_output(:,:,2) = o3mr_b4_adj_output(:,:) - q_b4_adj_output(:,:,3) = clwmr_b4_adj_output(:,:) - if (gfdl_mp) then - q_b4_adj_output(:,:,4) = rwmr_b4_adj_output(:,:) - q_b4_adj_output(:,:,5) = icmr_b4_adj_output(:,:) - q_b4_adj_output(:,:,6) = snmr_b4_adj_output(:,:) - q_b4_adj_output(:,:,7) = grle_b4_adj_output(:,:) - if (icldamt == 1) q_b4_adj_output(:,:,8) = cldamt_b4_adj_output(:,:) - endif - - allocate(q_output(ij_output,lev,ntrac)) - q_output = 0.0 - - allocate(dzdt_output(ij_output,lev)) - dzdt_output = 0.0 - - allocate(ugrd_output(ij_output,lev)) - ugrd_output=0.0 - - allocate(vgrd_output(ij_output,lev)) - vgrd_output=0.0 - - allocate(tmp_output(ij_output,lev)) - tmp_output=0.0 - - print*,"VERTICALLY INTERPOLATE TO NEW PRESSURE LEVELS" - call vintg(ij_output, lev, lev, ntrac, pres_b4_adj_output, & - ugrd_b4_adj_output, vgrd_b4_adj_output, tmp_b4_adj_output, q_b4_adj_output, & - dzdt_b4_adj_output, pres_output, ugrd_output, vgrd_output, tmp_output, & - q_output, dzdt_output) - - deallocate (dzdt_b4_adj_output, q_b4_adj_output) - deallocate (pres_b4_adj_output, pres_output) - - allocate(spfh_output(ij_output,lev)) - spfh_output = q_output(:,:,1) - allocate(o3mr_output(ij_output,lev)) - o3mr_output = q_output(:,:,2) - allocate(clwmr_output(ij_output,lev)) - clwmr_output = q_output(:,:,3) - if (gfdl_mp) then - allocate(rwmr_output(ij_output,lev)) - rwmr_output = q_output(:,:,4) - allocate(icmr_output(ij_output,lev)) - icmr_output = q_output(:,:,5) - allocate(snmr_output(ij_output,lev)) - snmr_output = q_output(:,:,6) - allocate(grle_output(ij_output,lev)) - grle_output = q_output(:,:,7) - if (icldamt == 1) then - allocate(cldamt_output(ij_output,lev)) - cldamt_output = q_output(:,:,8) - endif - endif - - deallocate(q_output) - -!do k = 1, lev -!print*,'after vintg tmp ',tmp_b4_adj_output(ij_output/2,k),tmp_output(ij_output/2,k) -!enddo - - deallocate(tmp_b4_adj_output) - -!do k = 1, lev -!print*,'after vintg u ',ugrd_b4_adj_output(ij_output/2,k),ugrd_output(ij_output/2,k) -!enddo - - deallocate(ugrd_b4_adj_output) - -!do k = 1, lev -!print*,'after vintg v ',vgrd_b4_adj_output(ij_output/2,k),vgrd_output(ij_output/2,k) -!enddo - - deallocate(vgrd_b4_adj_output) - -!do k = 1, lev -!print*,'after vintg spfh ',spfh_b4_adj_output(ij_output/2,k),spfh_output(ij_output/2,k) -!enddo - - deallocate(spfh_b4_adj_output) - -!do k = 1, lev -!print*,'after vintg o3 ',o3mr_b4_adj_output(ij_output/2,k),o3mr_output(ij_output/2,k) -!enddo - - deallocate(o3mr_b4_adj_output) - -!do k = 1, lev -!print*,'after vintg clw ',clwmr_b4_adj_output(ij_output/2,k),clwmr_output(ij_output/2,k) -!enddo - - deallocate(clwmr_b4_adj_output) - - if (gfdl_mp) then - -! do k = 1, lev -! print*,'after vintg rw ',rwmr_b4_adj_output(ij_output/2,k),rwmr_output(ij_output/2,k) -! enddo - - deallocate(rwmr_b4_adj_output) - -! do k = 1, lev -! print*,'after vintg ic ',icmr_b4_adj_output(ij_output/2,k),icmr_output(ij_output/2,k) -! enddo - - deallocate(icmr_b4_adj_output) - -! do k = 1, lev -! print*,'after vintg sn ',snmr_b4_adj_output(ij_output/2,k),snmr_output(ij_output/2,k) -! enddo - - deallocate(snmr_b4_adj_output) - -! do k = 1, lev -! print*,'after vintg grle ',grle_b4_adj_output(ij_output/2,k),grle_output(ij_output/2,k) -! enddo - - deallocate(grle_b4_adj_output) - - if (icldamt == 1) then -! do k = 1, lev -! print*,'after vintg cld_amt ',cldamt_b4_adj_output(ij_output/2,k),cldamt_output(ij_output/2,k) -! enddo - - deallocate(cldamt_b4_adj_output) - endif - - - endif - - allocate(delz_output(ij_output, lev)) - delz_output = 0.0 - - call compute_delz(ij_output, lev, vcoord(:,1), vcoord(:,2), sfcp_output, hgt_output, & - tmp_output, spfh_output, delz_output, flipdelz) - - deallocate(hgt_output) - - end subroutine adjust_for_terrain - - subroutine gaus_to_gaus - -!---------------------------------------------------------------------------------- -! Interpolate data from the input to output grid using IPOLATES library. -!---------------------------------------------------------------------------------- - - use output_data - use input_data - use setup - - implicit none - - integer :: ip, ipopt(20) - integer :: num_fields - integer :: iret, numpts - integer, allocatable :: ibi(:), ibo(:) - - logical*1, allocatable :: bitmap_input(:,:), bitmap_output(:,:) - - real, allocatable :: data_input(:,:) - real, allocatable :: data_output(:,:), crot(:), srot(:) - - print* - print*,'INTERPOLATE DATA TO OUTPUT GRID' - - ip = 0 ! bilinear - ipopt = 0 - -!---------------------------------------------------------------------------------- -! Do 2-D fields first -!---------------------------------------------------------------------------------- - - num_fields = 1 - - allocate(ibi(num_fields)) - ibi = 0 ! no bitmap - allocate(ibo(num_fields)) - ibo = 0 ! no bitmap - - allocate(bitmap_input(ij_input,num_fields)) - bitmap_input = .true. - allocate(bitmap_output(ij_output,num_fields)) - bitmap_output = .true. - - allocate(rlat_output(ij_output)) - rlat_output = 0.0 - allocate(rlon_output(ij_output)) - rlon_output = 0.0 - -!---------------- -! Surface height -!---------------- - - allocate(data_input(ij_input,num_fields)) - data_input(:,num_fields) = hgt_input(:) - deallocate(hgt_input) - - allocate(data_output(ij_output,num_fields)) - data_output = 0 - - print*,"INTERPOLATE SURFACE HEIGHT" - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, data_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - data_output, iret) - if (iret /= 0) goto 89 - - allocate(hgt_output(ij_output)) - hgt_output = data_output(:,num_fields) - -!------------------ -! surface pressure -!------------------ - - data_input(:,num_fields) = sfcp_input(:) - deallocate(sfcp_input) - - print*,"INTERPOLATE SURFACE PRESSURE" - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, data_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - data_output, iret) - if (iret /= 0) goto 89 - - allocate(sfcp_b4_adj_output(ij_output)) - sfcp_b4_adj_output = data_output(:,num_fields) - - deallocate(ibi, ibo, bitmap_input, bitmap_output, data_input, data_output) - -!---------------------------------------------------------------------------------- -! 3d scalars -!---------------------------------------------------------------------------------- - - num_fields = lev - - allocate(ibi(num_fields)) - ibi = 0 ! no bitmap - allocate(ibo(num_fields)) - ibo = 0 ! no bitmap - - allocate(bitmap_input(ij_input,num_fields)) - bitmap_input = .true. - allocate(bitmap_output(ij_output,num_fields)) - bitmap_output = .true. - -!------------- -! Temperature -!------------- - - allocate(tmp_b4_adj_output(ij_output,num_fields)) - tmp_b4_adj_output = 0 - - print*,'INTERPOLATE TEMPERATURE' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, tmp_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - tmp_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(tmp_input) - -!-------------------- -! Cloud liquid water -!-------------------- - - allocate(clwmr_b4_adj_output(ij_output,num_fields)) - clwmr_b4_adj_output = 0 - - print*,'INTERPOLATE CLOUD LIQUID WATER' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, clwmr_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - clwmr_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(clwmr_input) - -!-------------------- -! Specific humidity -!-------------------- - - allocate(spfh_b4_adj_output(ij_output,num_fields)) - spfh_b4_adj_output = 0 - - print*,'INTERPOLATE SPECIFIC HUMIDITY' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, spfh_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - spfh_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(spfh_input) - -!----------- -! Ozone -!----------- - - allocate(o3mr_b4_adj_output(ij_output,num_fields)) - o3mr_b4_adj_output = 0 - - print*,'INTERPOLATE OZONE' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, o3mr_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - o3mr_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(o3mr_input) - -!----------- -! DZDT -!----------- - - allocate(dzdt_b4_adj_output(ij_output,num_fields)) - dzdt_b4_adj_output = 0 - - print*,'INTERPOLATE DZDT' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, dzdt_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - dzdt_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(dzdt_input) - -!---------------------------------------------------------------------------------- -! Interpolate additional 3-d scalars for GFDL microphysics. -!---------------------------------------------------------------------------------- - - if (gfdl_mp) then - -!------------- -! Rain water -!------------- - - allocate(rwmr_b4_adj_output(ij_output,num_fields)) - rwmr_b4_adj_output = 0 - - print*,'INTERPOLATE RWMR' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, rwmr_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - rwmr_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(rwmr_input) - -!------------- -! Snow water -!------------- - - allocate(snmr_b4_adj_output(ij_output,num_fields)) - snmr_b4_adj_output = 0 - - print*,'INTERPOLATE SNMR' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, snmr_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - snmr_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(snmr_input) - -!------------- -! Ice water -!------------- - - allocate(icmr_b4_adj_output(ij_output,num_fields)) - icmr_b4_adj_output = 0 - - print*,'INTERPOLATE ICMR' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, icmr_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - icmr_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(icmr_input) - -!------------- -! Graupel -!------------- - - allocate(grle_b4_adj_output(ij_output,num_fields)) - grle_b4_adj_output = 0 - - print*,'INTERPOLATE GRLE' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, grle_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - grle_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(grle_input) - -!--------------------------- -! Cloud amount (if present) -!--------------------------- - - if (icldamt == 1) then - allocate(cldamt_b4_adj_output(ij_output,num_fields)) - cldamt_b4_adj_output = 0 - - print*,'INTERPOLATE CLD_AMT' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, cldamt_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - cldamt_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(cldamt_input) - endif - - - endif - -!---------------------------------------------------------------------------------- -! 3d u/v winds -!---------------------------------------------------------------------------------- - - allocate(crot(ij_output), srot(ij_output)) - crot = 0. - srot = 0. - - allocate(ugrd_b4_adj_output(ij_output,num_fields)) - ugrd_b4_adj_output = 0 - allocate(vgrd_b4_adj_output(ij_output,num_fields)) - vgrd_b4_adj_output = 0 - - print*,'INTERPOLATE WINDS' - call ipolatev(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, ugrd_input, vgrd_input, & - numpts, rlat_output, rlon_output, crot, srot, ibo, bitmap_output, & - ugrd_b4_adj_output, vgrd_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate (ugrd_input, vgrd_input) - deallocate (crot, srot) - deallocate (ibi, ibo, bitmap_input, bitmap_output) - - return - - 89 continue - print*,"FATAL ERROR IN IPOLATES. IRET IS: ", iret - call errexit(23) - - end subroutine gaus_to_gaus - - end module interp diff --git a/sorc/enkf_chgres_recenter.fd/makefile b/sorc/enkf_chgres_recenter.fd/makefile deleted file mode 100755 index 2a5f36b369..0000000000 --- a/sorc/enkf_chgres_recenter.fd/makefile +++ /dev/null @@ -1,27 +0,0 @@ -SHELL= /bin/sh - -LIBS= $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIBd) $(IP_LIBd) $(SP_LIBd) - -CMD= enkf_chgres_recenter.x - -OBJS = driver.o input_data.o interp.o output_data.o utils.o setup.o - -$(CMD): $(OBJS) - $(FC) $(FFLAGS) -o $(CMD) $(OBJS) $(LIBS) - -driver.o: setup.o output_data.o interp.o input_data.o driver.f90 - $(FC) $(FFLAGS) -I$(NEMSIO_INC) -c driver.f90 -interp.o: setup.o utils.o output_data.o input_data.o interp.f90 - $(FC) $(FFLAGS) -I$(NEMSIO_INC) -c interp.f90 -input_data.o: setup.o utils.o input_data.f90 - $(FC) $(FFLAGS) -I$(NEMSIO_INC) -c input_data.f90 -output_data.o: setup.o utils.o input_data.o output_data.f90 - $(FC) $(FFLAGS) -I$(NEMSIO_INC) -c output_data.f90 -setup.o: setup.f90 - $(FC) $(FFLAGS) -I$(NEMSIO_INC) -c setup.f90 -utils.o: utils.f90 - $(FC) $(FFLAGS) -I$(NEMSIO_INC) -c utils.f90 -clean: - rm -f *.o *.mod ${CMD} -install: - -cp $(CMD) ../../exec/. diff --git a/sorc/enkf_chgres_recenter.fd/output_data.f90 b/sorc/enkf_chgres_recenter.fd/output_data.f90 deleted file mode 100644 index 36063d3a06..0000000000 --- a/sorc/enkf_chgres_recenter.fd/output_data.f90 +++ /dev/null @@ -1,396 +0,0 @@ - module output_data - - use nemsio_module - - implicit none - - private - - integer, public :: kgds_output(200) - -! data on the output grid. - real, allocatable, public :: hgt_output(:) ! interpolated from input grid - real, allocatable, public :: hgt_external_output(:) - real, allocatable, public :: sfcp_output(:) - real, allocatable, public :: tmp_output(:,:) - real, allocatable, public :: clwmr_output(:,:) - real, allocatable, public :: delz_output(:,:) - real, allocatable, public :: dpres_output(:,:) - real, allocatable, public :: dzdt_output(:,:) - real, allocatable, public :: o3mr_output(:,:) - real, allocatable, public :: spfh_output(:,:) - real, allocatable, public :: ugrd_output(:,:) - real, allocatable, public :: vgrd_output(:,:) - real, allocatable, public :: rwmr_output(:,:) - real, allocatable, public :: icmr_output(:,:) - real, allocatable, public :: snmr_output(:,:) - real, allocatable, public :: grle_output(:,:) - real, allocatable, public :: cldamt_output(:,:) - real, allocatable, public :: rlat_output(:) - real, allocatable, public :: rlon_output(:) - - public :: set_output_grid - public :: write_output_data - - character(len=50), allocatable :: recname(:) - character(len=50), allocatable :: reclevtyp(:) - - integer(nemsio_intkind) :: nrec - integer(nemsio_intkind), allocatable :: reclev(:) - - real(nemsio_realkind), allocatable :: vcoord_header(:,:,:) - real(nemsio_realkind), allocatable :: lat(:), lon(:) - - contains - - subroutine set_output_grid - -!------------------------------------------------------------------- -! Set grid specs on the output grid. -!------------------------------------------------------------------- - - use setup - use input_data - use utils - - implicit none - - character(len=20) :: vlevtyp, vname - - integer(nemsio_intkind) :: vlev - integer :: iret - - real(nemsio_realkind), allocatable :: dummy(:) - - type(nemsio_gfile) :: gfile - - print* - print*,"OUTPUT GRID I/J DIMENSIONS: ", i_output, j_output - -!------------------------------------------------------------------- -! Set the grib 1 grid description section, which is needed -! by the IPOLATES library. -!------------------------------------------------------------------- - - kgds_output = 0 - - call calc_kgds(i_output, j_output, kgds_output) - -!------------------------------------------------------------------- -! Read the terrain on the output grid. To ensure exact match, -! read it from an existing enkf nemsio restart file. -!------------------------------------------------------------------- - - call nemsio_init(iret) - - print* - print*,"OPEN OUTPUT GRID TERRAIN FILE: ", trim(terrain_file) - call nemsio_open(gfile, terrain_file, "read", iret=iret) - if (iret /= 0) then - print*,"FATAL ERROR OPENING FILE: ",trim(terrain_file) - print*,"IRET IS: ", iret - call errexit(50) - endif - - allocate(dummy(ij_output)) - allocate(hgt_external_output(ij_output)) - - print* - print*,"READ SURFACE HEIGHT" - vlev = 1 - vlevtyp = "sfc" - vname = "hgt" - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) then - print*,"FATAL ERROR READING FILE: ",trim(terrain_file) - print*,"IRET IS: ", iret - call errexit(51) - endif - - hgt_external_output = dummy - - deallocate(dummy) - - call nemsio_close(gfile, iret=iret) - - call nemsio_finalize() - - end subroutine set_output_grid - - subroutine write_output_data - -!------------------------------------------------------------------- -! Write output grid data to a nemsio file. -!------------------------------------------------------------------- - - use input_data - use setup - - implicit none - - character(len=5) :: gaction - - integer :: n, iret - - real(nemsio_realkind), allocatable :: dummy(:) - - type(nemsio_gfile) :: gfile - -!------------------------------------------------------------------- -! Set up some header info. -!------------------------------------------------------------------- - - call header_set - -!------------------------------------------------------------------- -! Open and write file. -!------------------------------------------------------------------- - - call nemsio_init(iret) - - gaction="write" - - print* - print*,'OPEN OUTPUT FILE: ',trim(output_file) - call nemsio_open(gfile, output_file, gaction, iret=iret, gdatatype="bin4", & - nmeta=8, modelname="FV3GFS", nrec=nrec, & - idate=idate, dimx=i_output, & - dimy=j_output, dimz=lev, ntrac=ntrac, & - ncldt=ncldt, idvc=idvc, idsl=idsl, idvm=idvm, & - idrt=4, recname=recname, reclevtyp=reclevtyp, & - reclev=reclev,vcoord=vcoord_header, & - lat=lat, lon=lon) - if (iret/=0) then - print*,"FATAL ERROR OPENING FILE. IRET IS: ", iret - call errexit(9) - endif - - deallocate(lon, lat, recname, reclevtyp, reclev, vcoord_header) - - allocate(dummy(i_output*j_output)) - - print*,"WRITE SURFACE HEIGHT" - dummy = hgt_external_output - call nemsio_writerecv(gfile, "hgt", "sfc", 1, dummy, iret=iret) - if (iret/=0) goto 88 - deallocate(hgt_external_output) - - print*,"WRITE SURFACE PRESSURE" - dummy = sfcp_output - call nemsio_writerecv(gfile, "pres", "sfc", 1, dummy, iret=iret) - if (iret/=0) goto 88 - deallocate(sfcp_output) - - print*,"WRITE TEMPERATURE" - do n = 1, lev - dummy = tmp_output(:,n) - call nemsio_writerecv(gfile, "tmp", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(tmp_output) - - print*,"WRITE CLOUD LIQUID WATER" - do n = 1, lev - dummy = clwmr_output(:,n) - call nemsio_writerecv(gfile, "clwmr", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(clwmr_output) - - print*,"WRITE SPECIFIC HUMIDITY" - do n = 1, lev - dummy = spfh_output(:,n) - call nemsio_writerecv(gfile, "spfh", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(spfh_output) - - print*,"WRITE OZONE" - do n = 1, lev - dummy = o3mr_output(:,n) - call nemsio_writerecv(gfile, "o3mr", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(o3mr_output) - - print*,"WRITE U-WINDS" - do n = 1, lev - dummy = ugrd_output(:,n) - call nemsio_writerecv(gfile, "ugrd", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(ugrd_output) - - print*,"WRITE V-WINDS" - do n = 1, lev - dummy = vgrd_output(:,n) - call nemsio_writerecv(gfile, "vgrd", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(vgrd_output) - - print*,"WRITE DZDT" - do n = 1, lev - dummy = dzdt_output(:,n) - call nemsio_writerecv(gfile, "dzdt", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(dzdt_output) - - print*,"WRITE DPRES" - do n = 1, lev - dummy = dpres_output(:,n) - call nemsio_writerecv(gfile, "dpres", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(dpres_output) - - print*,"WRITE DELZ" - do n = 1, lev - dummy = delz_output(:,n) - call nemsio_writerecv(gfile, "delz", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(delz_output) - - if (gfdl_mp) then - - print*,"WRITE RAIN WATER" - do n = 1, lev - dummy = rwmr_output(:,n) - call nemsio_writerecv(gfile, "rwmr", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(rwmr_output) - - print*,"WRITE SNOW WATER" - do n = 1, lev - dummy = snmr_output(:,n) - call nemsio_writerecv(gfile, "snmr", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(snmr_output) - - print*,"WRITE ICE WATER" - do n = 1, lev - dummy = icmr_output(:,n) - call nemsio_writerecv(gfile, "icmr", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(icmr_output) - - print*,"WRITE GRAUPEL" - do n = 1, lev - dummy = grle_output(:,n) - call nemsio_writerecv(gfile, "grle", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(grle_output) - - if (icldamt == 1) then - print*,"WRITE CLD_AMT" - do n = 1, lev - dummy = cldamt_output(:,n) - call nemsio_writerecv(gfile, "cld_amt", "mid layer", n, dummy, iret=iret) - if (iret/=0) goto 88 - enddo - deallocate(cldamt_output) - endif - - - endif - - deallocate(dummy) - - call nemsio_close(gfile, iret=iret) - - call nemsio_finalize() - - return - - 88 continue - print*,"FATAL ERROR WRITING FILE. IRET IS: ", iret - call errexit(10) - - end subroutine write_output_data - - subroutine header_set - -!------------------------------------------------------------------- -! Set header information for the output nemsio file. -!------------------------------------------------------------------- - - use input_data - use setup - - implicit none - - character(len=8) :: fields(9) - character(len=8) :: fields_gfdl_mp(5) - - integer :: count, l, n - -! Fields common to Zhao-Carr and GFDL microphysics - data fields /'ugrd', 'vgrd', 'dzdt', 'dpres', 'delz', & - 'tmp', 'spfh', 'clwmr', 'o3mr'/ - -! Fields for GFDL microphysics - data fields_gfdl_mp /'rwmr', 'icmr', 'snmr', 'grle', 'cld_amt'/ - - print* - print*,"SET HEADER INFO FOR OUTPUT FILE." - - if (gfdl_mp) then - nrec = ((13+icldamt) * lev) + 2 - else - nrec = (9 * lev) + 2 - endif - - allocate(recname(nrec)) - allocate(reclev(nrec)) - allocate(reclevtyp(nrec)) - - count = 0 - do n = 1, 9 - do l = 1, lev - count = count + 1 - recname(count) = fields(n) - reclev(count) = l - reclevtyp(count) = "mid layer" - enddo - enddo - - if (gfdl_mp) then - do n = 1, 4 + icldamt - do l = 1, lev - count = count + 1 - recname(count) = fields_gfdl_mp(n) - reclev(count) = l - reclevtyp(count) = "mid layer" - enddo - enddo - endif - - recname(nrec-1) = "pres" - reclev(nrec-1) = 1 - reclevtyp(nrec-1) = "sfc" - - recname(nrec) = "hgt" - reclev(nrec) = 1 - reclevtyp(nrec) = "sfc" - - allocate(vcoord_header(lev+1,3,2)) - vcoord_header = 0.0 - vcoord_header(:,1,1) = vcoord(:,1) - vcoord_header(:,2,1) = vcoord(:,2) - - allocate(lat(ij_output), lon(ij_output)) - - lat = rlat_output - lon = rlon_output - - deallocate(rlat_output, rlon_output) - - end subroutine header_set - - end module output_data diff --git a/sorc/enkf_chgres_recenter.fd/setup.f90 b/sorc/enkf_chgres_recenter.fd/setup.f90 deleted file mode 100644 index c2c2dc450e..0000000000 --- a/sorc/enkf_chgres_recenter.fd/setup.f90 +++ /dev/null @@ -1,53 +0,0 @@ - module setup - - use nemsio_module - - implicit none - - private - - character(len=300), public :: input_file - character(len=300), public :: output_file - character(len=300), public :: terrain_file - character(len=300), public :: vcoord_file - - integer(nemsio_intkind), public :: i_output - integer(nemsio_intkind), public :: j_output - integer , public :: ij_output - logical, public :: flipdelz - - public :: program_setup - - contains - - subroutine program_setup - - implicit none - - integer :: istat - - namelist /nam_setup/ i_output, j_output, input_file, output_file, & - terrain_file, vcoord_file - - print* - print*,"OPEN SETUP NAMELIST." - open(43, file="./fort.43", iostat=istat) - if (istat /= 0) then - print*,"FATAL ERROR OPENING NAMELIST FILE. ISTAT IS: ",istat - call errexit(30) - endif - - print*,"READ SETUP NAMELIST." - read(43, nml=nam_setup, iostat=istat) - if (istat /= 0) then - print*,"FATAL ERROR READING NAMELIST FILE. ISTAT IS: ",istat - call errexit(31) - endif - - ij_output = i_output * j_output - - close(43) - - end subroutine program_setup - - end module setup diff --git a/sorc/enkf_chgres_recenter.fd/utils.f90 b/sorc/enkf_chgres_recenter.fd/utils.f90 deleted file mode 100644 index e09c75b018..0000000000 --- a/sorc/enkf_chgres_recenter.fd/utils.f90 +++ /dev/null @@ -1,783 +0,0 @@ - module utils - - private - - public :: calc_kgds - public :: newps - public :: newpr1 - public :: vintg - public :: compute_delz - - contains - - subroutine compute_delz(ijm, levp, ak_in, bk_in, ps, zs, t, sphum, delz, flipsign) - - implicit none - integer, intent(in):: levp, ijm - real, intent(in), dimension(levp+1):: ak_in, bk_in - real, intent(in), dimension(ijm):: ps, zs - real, intent(in), dimension(ijm,levp):: t - real, intent(in), dimension(ijm,levp):: sphum - real, intent(out), dimension(ijm,levp):: delz - logical, intent(in) :: flipsign -! Local: - real, dimension(ijm,levp+1):: zh - real, dimension(ijm,levp+1):: pe0, pn0 - real, dimension(levp+1) :: ak, bk - integer i,k - real, parameter :: GRAV = 9.80665 - real, parameter :: RDGAS = 287.05 - real, parameter :: RVGAS = 461.50 - real :: zvir - real:: grd - - print*,"COMPUTE LAYER THICKNESS." - - grd = grav/rdgas - zvir = rvgas/rdgas - 1. - ak = ak_in - bk = bk_in - ak(levp+1) = max(1.e-9, ak(levp+1)) - - do i=1, ijm - pe0(i,levp+1) = ak(levp+1) - pn0(i,levp+1) = log(pe0(i,levp+1)) - enddo - - do k=levp,1, -1 - do i=1,ijm - pe0(i,k) = ak(k) + bk(k)*ps(i) - pn0(i,k) = log(pe0(i,k)) - enddo - enddo - - do i = 1, ijm - zh(i,1) = zs(i) - enddo - - do k = 2, levp+1 - do i = 1, ijm - zh(i,k) = zh(i,k-1)+t(i,k-1)*(1.+zvir*sphum(i,k-1))* & - (pn0(i,k-1)-pn0(i,k))/grd - enddo - enddo - - do k = 1, levp - do i = 1, ijm - if (flipsign) then - delz(i,k) = zh(i,k) - zh(i,k+1) - else - delz(i,k) = zh(i,k+1) - zh(i,k) - end if - enddo - enddo - - end subroutine compute_delz - - subroutine calc_kgds(idim, jdim, kgds) - - use nemsio_module - - implicit none - - integer(nemsio_intkind), intent(in) :: idim, jdim - - integer, intent(out) :: kgds(200) - - kgds = 0 - kgds(1) = 4 ! OCT 6 - TYPE OF GRID (GAUSSIAN) - kgds(2) = idim ! OCT 7-8 - # PTS ON LATITUDE CIRCLE - kgds(3) = jdim ! OCT 9-10 - # PTS ON LONGITUDE CIRCLE - kgds(4) = 90000 ! OCT 11-13 - LAT OF ORIGIN - kgds(5) = 0 ! OCT 14-16 - LON OF ORIGIN - kgds(6) = 128 ! OCT 17 - RESOLUTION FLAG - kgds(7) = -90000 ! OCT 18-20 - LAT OF EXTREME POINT - kgds(8) = nint(-360000./idim) ! OCT 21-23 - LON OF EXTREME POINT - kgds(9) = nint((360.0 / float(idim))*1000.0) - ! OCT 24-25 - LONGITUDE DIRECTION INCR. - kgds(10) = jdim/2 ! OCT 26-27 - NUMBER OF CIRCLES POLE TO EQUATOR - kgds(12) = 255 ! OCT 29 - RESERVED - kgds(20) = 255 ! OCT 5 - NOT USED, SET TO 255 - - end subroutine calc_kgds - - SUBROUTINE NEWPS(ZS,PS,IM,KM,P,T,Q,ZSNEW,PSNEW) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: NEWPS COMPUTE NEW SURFACE PRESSURE -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -! -! ABSTRACT: COMPUTES A NEW SURFACE PRESSURE GIVEN A NEW OROGRAPHY. -! THE NEW PRESSURE IS COMPUTED ASSUMING A HYDROSTATIC BALANCE -! AND A CONSTANT TEMPERATURE LAPSE RATE. BELOW GROUND, THE -! LAPSE RATE IS ASSUMED TO BE -6.5 K/KM. -! -! PROGRAM HISTORY LOG: -! 91-10-31 MARK IREDELL -! -! USAGE: CALL NEWPS(ZS,PS,IM,KM,P,T,Q,ZSNEW,PSNEW) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF POINTS TO COMPUTE -! ZS REAL (IM) OLD OROGRAPHY (M) -! PS REAL (IM) OLD SURFACE PRESSURE (PA) -! KM INTEGER NUMBER OF LEVELS -! P REAL (IM,KM) PRESSURES (PA) -! T REAL (IM,KM) TEMPERATURES (K) -! Q REAL (IM,KM) SPECIFIC HUMIDITIES (KG/KG) -! ZSNEW REAL (IM) NEW OROGRAPHY (M) -! OUTPUT ARGUMENT LIST: -! PSNEW REAL (IM) NEW SURFACE PRESSURE (PA) -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - REAL ZS(IM),PS(IM),P(IM,KM),T(IM,KM),Q(IM,KM) - REAL ZSNEW(IM),PSNEW(IM) - PARAMETER(BETA=-6.5E-3,EPSILON=1.E-9) - PARAMETER(G=9.80665,RD=287.05,RV=461.50) - PARAMETER(GOR=G/RD,FV=RV/RD-1.) - REAL ZU(IM) - FTV(AT,AQ)=AT*(1+FV*AQ) - FGAM(APU,ATVU,APD,ATVD)=-GOR*LOG(ATVD/ATVU)/LOG(APD/APU) - FZ0(AP,ATV,AZD,APD)=AZD+ATV/GOR*LOG(APD/AP) - FZ1(AP,ATV,AZD,APD,AGAM)=AZD-ATV/AGAM*((APD/AP)**(-AGAM/GOR)-1) - FP0(AZ,AZU,APU,ATVU)=APU*EXP(-GOR/ATVU*(AZ-AZU)) - FP1(AZ,AZU,APU,ATVU,AGAM)=APU*(1+AGAM/ATVU*(AZ-AZU))**(-GOR/AGAM) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE SURFACE PRESSURE BELOW THE ORIGINAL GROUND - LS=0 - K=1 - GAMMA=BETA - DO I=1,IM - PU=P(I,K) - TVU=FTV(T(I,K),Q(I,K)) - ZU(I)=FZ1(PU,TVU,ZS(I),PS(I),GAMMA) - IF(ZSNEW(I).LE.ZU(I)) THEN - PU=P(I,K) - TVU=FTV(T(I,K),Q(I,K)) - IF(ABS(GAMMA).GT.EPSILON) THEN - PSNEW(I)=FP1(ZSNEW(I),ZU(I),PU,TVU,GAMMA) - ELSE - PSNEW(I)=FP0(ZSNEW(I),ZU(I),PU,TVU) - ENDIF - ELSE - PSNEW(I)=0 - LS=LS+1 - ENDIF -! endif - ENDDO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE SURFACE PRESSURE ABOVE THE ORIGINAL GROUND - DO K=2,KM - IF(LS.GT.0) THEN - DO I=1,IM - IF(PSNEW(I).EQ.0) THEN - PU=P(I,K) - TVU=FTV(T(I,K),Q(I,K)) - PD=P(I,K-1) - TVD=FTV(T(I,K-1),Q(I,K-1)) - GAMMA=FGAM(PU,TVU,PD,TVD) - IF(ABS(GAMMA).GT.EPSILON) THEN - ZU(I)=FZ1(PU,TVU,ZU(I),PD,GAMMA) - ELSE - ZU(I)=FZ0(PU,TVU,ZU(I),PD) - ENDIF - IF(ZSNEW(I).LE.ZU(I)) THEN - IF(ABS(GAMMA).GT.EPSILON) THEN - PSNEW(I)=FP1(ZSNEW(I),ZU(I),PU,TVU,GAMMA) - ELSE - PSNEW(I)=FP0(ZSNEW(I),ZU(I),PU,TVU) - ENDIF - LS=LS-1 - ENDIF - ENDIF - ENDDO - ENDIF - ENDDO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE SURFACE PRESSURE OVER THE TOP - IF(LS.GT.0) THEN - K=KM - GAMMA=0 - DO I=1,IM - IF(PSNEW(I).EQ.0) THEN - PU=P(I,K) - TVU=FTV(T(I,K),Q(I,K)) - PSNEW(I)=FP0(ZSNEW(I),ZU(I),PU,TVU) - ENDIF - ENDDO - ENDIF - END SUBROUTINE NEWPS - - SUBROUTINE NEWPR1(IM,KM,IDVC,IDSL,NVCOORD,VCOORD, & - PS,PM,DP) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: NEWPR1 COMPUTE MODEL PRESSURES -! PRGMMR: JUANG ORG: W/NMC23 DATE: 2005-04-11 -! PRGMMR: Fanglin Yang ORG: W/NMC23 DATE: 2006-11-28 -! PRGMMR: S. Moorthi ORG: NCEP/EMC DATE: 2006-12-12 -! PRGMMR: S. Moorthi ORG: NCEP/EMC DATE: 2007-01-02 -! -! ABSTRACT: COMPUTE MODEL PRESSURES. -! -! PROGRAM HISTORY LOG: -! 2005-04-11 HANN_MING HENRY JUANG hybrid sigma, sigma-p, and sigma- -! -! USAGE: CALL NEWPR1(IM,IX,KM,KMP,IDVC,IDSL,NVCOORD,VCOORD,PP,TP,QP,P -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF POINTS TO COMPUTE -! KM INTEGER NUMBER OF LEVELS -! IDVC INTEGER VERTICAL COORDINATE ID -! (1 FOR SIGMA AND 2 FOR HYBRID) -! IDSL INTEGER TYPE OF SIGMA STRUCTURE -! (1 FOR PHILLIPS OR 2 FOR MEAN) -! NVCOORD INTEGER NUMBER OF VERTICAL COORDINATES -! VCOORD REAL (KM+1,NVCOORD) VERTICAL COORDINATE VALUES -! FOR IDVC=1, NVCOORD=1: SIGMA INTERFACE -! FOR IDVC=2, NVCOORD=2: HYBRID INTERFACE A AND B -! FOR IDVC=3, NVCOORD=3: JUANG GENERAL HYBRID INTERFACE -! AK REAL (KM+1) HYBRID INTERFACE A -! BK REAL (KM+1) HYBRID INTERFACE B -! PS REAL (IX) SURFACE PRESSURE (PA) -! OUTPUT ARGUMENT LIST: -! PM REAL (IX,KM) MID-LAYER PRESSURE (PA) -! DP REAL (IX,KM) LAYER DELTA PRESSURE (PA) -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IM, KM, NVCOORD, IDVC, IDSL - - REAL, INTENT(IN) :: VCOORD(KM+1,NVCOORD) - REAL, INTENT(IN) :: PS(IM) - - REAL, INTENT(OUT) :: PM(IM,KM) - REAL, OPTIONAL, INTENT(OUT) :: DP(IM,KM) - - REAL, PARAMETER :: RD=287.05, RV=461.50, CP=1004.6, & - ROCP=RD/CP, ROCP1=ROCP+1, ROCPR=1/ROCP, & - FV=RV/RD-1. - - INTEGER :: I, K - - REAL :: AK(KM+1), BK(KM+1), PI(IM,KM+1) - - IF(IDVC.EQ.2) THEN - DO K=1,KM+1 - AK(K) = VCOORD(K,1) - BK(K) = VCOORD(K,2) - PI(1:IM,K) = AK(K) + BK(K)*PS(1:IM) - ENDDO - ELSE - print*,'routine only works for idvc 2' - stop - ENDIF - - IF(IDSL.EQ.2) THEN - DO K=1,KM - PM(1:IM,K) = (PI(1:IM,K)+PI(1:IM,K+1))/2 - ENDDO - ELSE - DO K=1,KM - PM(1:IM,K) = ((PI(1:IM,K)**ROCP1-PI(1:IM,K+1)**ROCP1)/ & - (ROCP1*(PI(1:IM,K)-PI(1:IM,K+1))))**ROCPR - ENDDO - ENDIF - - IF(PRESENT(DP))THEN - DO K=1,KM - DO I=1,IM - DP(I,K) = PI(I,K) - PI(I,K+1) - ENDDO - ENDDO - ENDIF - - END SUBROUTINE NEWPR1 - - SUBROUTINE TERP3(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, & - KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2,KXQ2,Z2,Q2,J2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: TERP3 CUBICALLY INTERPOLATE IN ONE DIMENSION -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-05-01 -! -! ABSTRACT: INTERPOLATE FIELD(S) IN ONE DIMENSION ALONG THE COLUMN(S). -! THE INTERPOLATION IS CUBIC LAGRANGIAN WITH A MONOTONIC CONSTRAINT -! IN THE CENTER OF THE DOMAIN. IN THE OUTER INTERVALS IT IS LINEAR. -! OUTSIDE THE DOMAIN, FIELDS ARE HELD CONSTANT. -! -! PROGRAM HISTORY LOG: -! 98-05-01 MARK IREDELL -! 1999-01-04 IREDELL USE ESSL SEARCH -! -! USAGE: CALL TERP3(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, -! & KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2,KXQ2,Z2,Q2,J2) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF COLUMNS -! IXZ1 INTEGER COLUMN SKIP NUMBER FOR Z1 -! IXQ1 INTEGER COLUMN SKIP NUMBER FOR Q1 -! IXZ2 INTEGER COLUMN SKIP NUMBER FOR Z2 -! IXQ2 INTEGER COLUMN SKIP NUMBER FOR Q2 -! NM INTEGER NUMBER OF FIELDS PER COLUMN -! NXQ1 INTEGER FIELD SKIP NUMBER FOR Q1 -! NXQ2 INTEGER FIELD SKIP NUMBER FOR Q2 -! KM1 INTEGER NUMBER OF INPUT POINTS -! KXZ1 INTEGER POINT SKIP NUMBER FOR Z1 -! KXQ1 INTEGER POINT SKIP NUMBER FOR Q1 -! Z1 REAL (1+(IM-1)*IXZ1+(KM1-1)*KXZ1) -! INPUT COORDINATE VALUES IN WHICH TO INTERPOLATE -! (Z1 MUST BE STRICTLY MONOTONIC IN EITHER DIRECTION) -! Q1 REAL (1+(IM-1)*IXQ1+(KM1-1)*KXQ1+(NM-1)*NXQ1) -! INPUT FIELDS TO INTERPOLATE -! KM2 INTEGER NUMBER OF OUTPUT POINTS -! KXZ2 INTEGER POINT SKIP NUMBER FOR Z2 -! KXQ2 INTEGER POINT SKIP NUMBER FOR Q2 -! Z2 REAL (1+(IM-1)*IXZ2+(KM2-1)*KXZ2) -! OUTPUT COORDINATE VALUES TO WHICH TO INTERPOLATE -! (Z2 NEED NOT BE MONOTONIC) -! -! OUTPUT ARGUMENT LIST: -! Q2 REAL (1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) -! OUTPUT INTERPOLATED FIELDS -! J2 REAL (1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) -! OUTPUT INTERPOLATED FIELDS CHANGE WRT Z2 -! -! SUBPROGRAMS CALLED: -! RSEARCH SEARCH FOR A SURROUNDING REAL INTERVAL -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE - INTEGER IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2 - INTEGER KM1,KXZ1,KXQ1,KM2,KXZ2,KXQ2 - INTEGER I,K1,K2,N - REAL Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) - REAL Q1(1+(IM-1)*IXQ1+(KM1-1)*KXQ1+(NM-1)*NXQ1) - REAL Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) - REAL Q2(1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) - REAL J2(1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) - REAL FFA(IM),FFB(IM),FFC(IM),FFD(IM) - REAL GGA(IM),GGB(IM),GGC(IM),GGD(IM) - INTEGER K1S(IM,KM2) - REAL Z1A,Z1B,Z1C,Z1D,Q1A,Q1B,Q1C,Q1D,Z2S,Q2S,J2S -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. - CALL RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,1,IM,K1S) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! GENERALLY INTERPOLATE CUBICALLY WITH MONOTONIC CONSTRAINT -! FROM TWO NEAREST INPUT POINTS ON EITHER SIDE OF THE OUTPUT POINT, -! BUT WITHIN THE TWO EDGE INTERVALS INTERPOLATE LINEARLY. -! KEEP THE OUTPUT FIELDS CONSTANT OUTSIDE THE INPUT DOMAIN. - -!!$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(IM,IXZ1,IXQ1,IXZ2), & -!!$OMP& SHARED(IXQ2,NM,NXQ1,NXQ2,KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2), & -!!$OMP& SHARED(KXQ2,Z2,Q2,J2,K1S) - - DO K2=1,KM2 - DO I=1,IM - K1=K1S(I,K2) - IF(K1.EQ.1.OR.K1.EQ.KM1-1) THEN - Z2S=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - Z1A=Z1(1+(I-1)*IXZ1+(K1-1)*KXZ1) - Z1B=Z1(1+(I-1)*IXZ1+(K1+0)*KXZ1) - FFA(I)=(Z2S-Z1B)/(Z1A-Z1B) - FFB(I)=(Z2S-Z1A)/(Z1B-Z1A) - GGA(I)=1/(Z1A-Z1B) - GGB(I)=1/(Z1B-Z1A) - ELSEIF(K1.GT.1.AND.K1.LT.KM1-1) THEN - Z2S=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - Z1A=Z1(1+(I-1)*IXZ1+(K1-2)*KXZ1) - Z1B=Z1(1+(I-1)*IXZ1+(K1-1)*KXZ1) - Z1C=Z1(1+(I-1)*IXZ1+(K1+0)*KXZ1) - Z1D=Z1(1+(I-1)*IXZ1+(K1+1)*KXZ1) - FFA(I)=(Z2S-Z1B)/(Z1A-Z1B)* & - (Z2S-Z1C)/(Z1A-Z1C)* & - (Z2S-Z1D)/(Z1A-Z1D) - FFB(I)=(Z2S-Z1A)/(Z1B-Z1A)* & - (Z2S-Z1C)/(Z1B-Z1C)* & - (Z2S-Z1D)/(Z1B-Z1D) - FFC(I)=(Z2S-Z1A)/(Z1C-Z1A)* & - (Z2S-Z1B)/(Z1C-Z1B)* & - (Z2S-Z1D)/(Z1C-Z1D) - FFD(I)=(Z2S-Z1A)/(Z1D-Z1A)* & - (Z2S-Z1B)/(Z1D-Z1B)* & - (Z2S-Z1C)/(Z1D-Z1C) - GGA(I)= 1/(Z1A-Z1B)* & - (Z2S-Z1C)/(Z1A-Z1C)* & - (Z2S-Z1D)/(Z1A-Z1D)+ & - (Z2S-Z1B)/(Z1A-Z1B)* & - 1/(Z1A-Z1C)* & - (Z2S-Z1D)/(Z1A-Z1D)+ & - (Z2S-Z1B)/(Z1A-Z1B)* & - (Z2S-Z1C)/(Z1A-Z1C)* & - 1/(Z1A-Z1D) - GGB(I)= 1/(Z1B-Z1A)* & - (Z2S-Z1C)/(Z1B-Z1C)* & - (Z2S-Z1D)/(Z1B-Z1D)+ & - (Z2S-Z1A)/(Z1B-Z1A)* & - 1/(Z1B-Z1C)* & - (Z2S-Z1D)/(Z1B-Z1D)+ & - (Z2S-Z1A)/(Z1B-Z1A)* & - (Z2S-Z1C)/(Z1B-Z1C)* & - 1/(Z1B-Z1D) - GGC(I)= 1/(Z1C-Z1A)* & - (Z2S-Z1B)/(Z1C-Z1B)* & - (Z2S-Z1D)/(Z1C-Z1D)+ & - (Z2S-Z1A)/(Z1C-Z1A)* & - 1/(Z1C-Z1B)* & - (Z2S-Z1D)/(Z1C-Z1D)+ & - (Z2S-Z1A)/(Z1C-Z1A)* & - (Z2S-Z1B)/(Z1C-Z1B)* & - 1/(Z1C-Z1D) - GGD(I)= 1/(Z1D-Z1A)* & - (Z2S-Z1B)/(Z1D-Z1B)* & - (Z2S-Z1C)/(Z1D-Z1C)+ & - (Z2S-Z1A)/(Z1D-Z1A)* & - 1/(Z1D-Z1B)* & - (Z2S-Z1C)/(Z1D-Z1C)+ & - (Z2S-Z1A)/(Z1D-Z1A)* & - (Z2S-Z1B)/(Z1D-Z1B)* & - 1/(Z1D-Z1C) - ENDIF - ENDDO -! INTERPOLATE. - DO N=1,NM - DO I=1,IM - K1=K1S(I,K2) - IF(K1.EQ.0) THEN - Q2S=Q1(1+(I-1)*IXQ1+(N-1)*NXQ1) - J2S=0 - ELSEIF(K1.EQ.KM1) THEN - Q2S=Q1(1+(I-1)*IXQ1+(KM1-1)*KXQ1+(N-1)*NXQ1) - J2S=0 - ELSEIF(K1.EQ.1.OR.K1.EQ.KM1-1) THEN - Q1A=Q1(1+(I-1)*IXQ1+(K1-1)*KXQ1+(N-1)*NXQ1) - Q1B=Q1(1+(I-1)*IXQ1+(K1+0)*KXQ1+(N-1)*NXQ1) - Q2S=FFA(I)*Q1A+FFB(I)*Q1B - J2S=GGA(I)*Q1A+GGB(I)*Q1B - ELSE - Q1A=Q1(1+(I-1)*IXQ1+(K1-2)*KXQ1+(N-1)*NXQ1) - Q1B=Q1(1+(I-1)*IXQ1+(K1-1)*KXQ1+(N-1)*NXQ1) - Q1C=Q1(1+(I-1)*IXQ1+(K1+0)*KXQ1+(N-1)*NXQ1) - Q1D=Q1(1+(I-1)*IXQ1+(K1+1)*KXQ1+(N-1)*NXQ1) - Q2S=FFA(I)*Q1A+FFB(I)*Q1B+FFC(I)*Q1C+FFD(I)*Q1D - J2S=GGA(I)*Q1A+GGB(I)*Q1B+GGC(I)*Q1C+GGD(I)*Q1D - IF(Q2S.LT.MIN(Q1B,Q1C)) THEN - Q2S=MIN(Q1B,Q1C) - J2S=0 - ELSEIF(Q2S.GT.MAX(Q1B,Q1C)) THEN - Q2S=MAX(Q1B,Q1C) - J2S=0 - ENDIF - ENDIF - Q2(1+(I-1)*IXQ2+(K2-1)*KXQ2+(N-1)*NXQ2)=Q2S - J2(1+(I-1)*IXQ2+(K2-1)*KXQ2+(N-1)*NXQ2)=J2S - ENDDO - ENDDO - ENDDO -!!$OMP END PARALLEL DO - - END SUBROUTINE TERP3 - - SUBROUTINE RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2,& - L2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: RSEARCH SEARCH FOR A SURROUNDING REAL INTERVAL -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-05-01 -! -! ABSTRACT: THIS SUBPROGRAM SEARCHES MONOTONIC SEQUENCES OF REAL NUMBERS -! FOR INTERVALS THAT SURROUND A GIVEN SEARCH SET OF REAL NUMBERS. -! THE SEQUENCES MAY BE MONOTONIC IN EITHER DIRECTION; THE REAL NUMBERS -! MAY BE SINGLE OR DOUBLE PRECISION; THE INPUT SEQUENCES AND SETS -! AND THE OUTPUT LOCATIONS MAY BE ARBITRARILY DIMENSIONED. -! -! PROGRAM HISTORY LOG: -! 1999-01-05 MARK IREDELL -! -! USAGE: CALL RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2, -! & L2) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF SEQUENCES TO SEARCH -! KM1 INTEGER NUMBER OF POINTS IN EACH SEQUENCE -! IXZ1 INTEGER SEQUENCE SKIP NUMBER FOR Z1 -! KXZ1 INTEGER POINT SKIP NUMBER FOR Z1 -! Z1 REAL (1+(IM-1)*IXZ1+(KM1-1)*KXZ1) -! SEQUENCE VALUES TO SEARCH -! (Z1 MUST BE MONOTONIC IN EITHER DIRECTION) -! KM2 INTEGER NUMBER OF POINTS TO SEARCH FOR -! IN EACH RESPECTIVE SEQUENCE -! IXZ2 INTEGER SEQUENCE SKIP NUMBER FOR Z2 -! KXZ2 INTEGER POINT SKIP NUMBER FOR Z2 -! Z2 REAL (1+(IM-1)*IXZ2+(KM2-1)*KXZ2) -! SET OF VALUES TO SEARCH FOR -! (Z2 NEED NOT BE MONOTONIC) -! IXL2 INTEGER SEQUENCE SKIP NUMBER FOR L2 -! KXL2 INTEGER POINT SKIP NUMBER FOR L2 -! -! OUTPUT ARGUMENT LIST: -! L2 INTEGER (1+(IM-1)*IXL2+(KM2-1)*KXL2) -! INTERVAL LOCATIONS HAVING VALUES FROM 0 TO KM1 -! (Z2 WILL BE BETWEEN Z1(L2) AND Z1(L2+1)) -! -! SUBPROGRAMS CALLED: -! SBSRCH ESSL BINARY SEARCH -! DBSRCH ESSL BINARY SEARCH -! -! REMARKS: -! IF THE ARRAY Z1 IS DIMENSIONED (IM,KM1), THEN THE SKIP NUMBERS ARE -! IXZ1=1 AND KXZ1=IM; IF IT IS DIMENSIONED (KM1,IM), THEN THE SKIP -! NUMBERS ARE IXZ1=KM1 AND KXZ1=1; IF IT IS DIMENSIONED (IM,JM,KM1), -! THEN THE SKIP NUMBERS ARE IXZ1=1 AND KXZ1=IM*JM; ETCETERA. -! SIMILAR EXAMPLES APPLY TO THE SKIP NUMBERS FOR Z2 AND L2. -! -! RETURNED VALUES OF 0 OR KM1 INDICATE THAT THE GIVEN SEARCH VALUE -! IS OUTSIDE THE RANGE OF THE SEQUENCE. -! -! IF A SEARCH VALUE IS IDENTICAL TO ONE OF THE SEQUENCE VALUES -! THEN THE LOCATION RETURNED POINTS TO THE IDENTICAL VALUE. -! IF THE SEQUENCE IS NOT STRICTLY MONOTONIC AND A SEARCH VALUE IS -! IDENTICAL TO MORE THAN ONE OF THE SEQUENCE VALUES, THEN THE -! LOCATION RETURNED MAY POINT TO ANY OF THE IDENTICAL VALUES. -! -! TO BE EXACT, FOR EACH I FROM 1 TO IM AND FOR EACH K FROM 1 TO KM2, -! Z=Z2(1+(I-1)*IXZ2+(K-1)*KXZ2) IS THE SEARCH VALUE AND -! L=L2(1+(I-1)*IXL2+(K-1)*KXL2) IS THE LOCATION RETURNED. -! IF L=0, THEN Z IS LESS THAN THE START POINT Z1(1+(I-1)*IXZ1) -! FOR ASCENDING SEQUENCES (OR GREATER THAN FOR DESCENDING SEQUENCES). -! IF L=KM1, THEN Z IS GREATER THAN OR EQUAL TO THE END POINT -! Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1) FOR ASCENDING SEQUENCES -! (OR LESS THAN OR EQUAL TO FOR DESCENDING SEQUENCES). -! OTHERWISE Z IS BETWEEN THE VALUES Z1(1+(I-1)*IXZ1+(L-1)*KXZ1) AND -! Z1(1+(I-1)*IXZ1+(L-0)*KXZ1) AND MAY EQUAL THE FORMER. -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ -! IMPLICIT NONE -! INTEGER,INTENT(IN):: IM,KM1,IXZ1,KXZ1,KM2,IXZ2,KXZ2,IXL2,KXL2 -! REAL,INTENT(IN):: Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) -! REAL,INTENT(IN):: Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) -! INTEGER,INTENT(OUT):: L2(1+(IM-1)*IXL2+(KM2-1)*KXL2) -! INTEGER(4) INCX,N,INCY,M,INDX(KM2),RC(KM2),IOPT -! INTEGER I,K2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. -! DO I=1,IM -! IF(Z1(1+(I-1)*IXZ1).LE.Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1)) THEN -! INPUT COORDINATE IS MONOTONICALLY ASCENDING. -! INCX=KXZ2 -! N=KM2 -! INCY=KXZ1 -! M=KM1 -! IOPT=1 -! IF(DIGITS(1.).LT.DIGITS(1._8)) THEN -! CALL SBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ELSE -! CALL DBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ENDIF -! DO K2=1,KM2 -! L2(1+(I-1)*IXL2+(K2-1)*KXL2)=INDX(K2)-RC(K2) -! ENDDO -! ELSE -! INPUT COORDINATE IS MONOTONICALLY DESCENDING. -! INCX=KXZ2 -! N=KM2 -! INCY=-KXZ1 -! M=KM1 -! IOPT=0 -! IF(DIGITS(1.).LT.DIGITS(1._8)) THEN -! CALL SBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ELSE -! CALL DBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ENDIF -! DO K2=1,KM2 -! L2(1+(I-1)*IXL2+(K2-1)*KXL2)=KM1+1-INDX(K2) -! ENDDO -! ENDIF -! ENDDO -! - IMPLICIT NONE - INTEGER,INTENT(IN):: IM,KM1,IXZ1,KXZ1,KM2,IXZ2,KXZ2,IXL2,KXL2 - REAL,INTENT(IN):: Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) - REAL,INTENT(IN):: Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) - INTEGER,INTENT(OUT):: L2(1+(IM-1)*IXL2+(KM2-1)*KXL2) - INTEGER I,K2,L - REAL Z -!C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!C FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. - DO I=1,IM - IF(Z1(1+(I-1)*IXZ1).LE.Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1)) THEN -!C INPUT COORDINATE IS MONOTONICALLY ASCENDING. - DO K2=1,KM2 - Z=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - L=0 - DO - IF(Z.LT.Z1(1+(I-1)*IXZ1+L*KXZ1)) EXIT - L=L+1 - IF(L.EQ.KM1) EXIT - ENDDO - L2(1+(I-1)*IXL2+(K2-1)*KXL2)=L - ENDDO - ELSE -!C INPUT COORDINATE IS MONOTONICALLY DESCENDING. - DO K2=1,KM2 - Z=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - L=0 - DO - IF(Z.GT.Z1(1+(I-1)*IXZ1+L*KXZ1)) EXIT - L=L+1 - IF(L.EQ.KM1) EXIT - ENDDO - L2(1+(I-1)*IXL2+(K2-1)*KXL2)=L - ENDDO - ENDIF - ENDDO - - END SUBROUTINE RSEARCH - - SUBROUTINE VINTG(IM,KM1,KM2,NT,P1,U1,V1,T1,Q1,W1,P2, & - U2,V2,T2,Q2,W2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: VINTG VERTICALLY INTERPOLATE UPPER-AIR FIELDS -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -! -! ABSTRACT: VERTICALLY INTERPOLATE UPPER-AIR FIELDS. -! WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS ARE INTERPOLATED. -! THE INTERPOLATION IS CUBIC LAGRANGIAN IN LOG PRESSURE -! WITH A MONOTONIC CONSTRAINT IN THE CENTER OF THE DOMAIN. -! IN THE OUTER INTERVALS IT IS LINEAR IN LOG PRESSURE. -! OUTSIDE THE DOMAIN, FIELDS ARE GENERALLY HELD CONSTANT, -! EXCEPT FOR TEMPERATURE AND HUMIDITY BELOW THE INPUT DOMAIN, -! WHERE THE TEMPERATURE LAPSE RATE IS HELD FIXED AT -6.5 K/KM AND -! THE RELATIVE HUMIDITY IS HELD CONSTANT. -! -! PROGRAM HISTORY LOG: -! 91-10-31 MARK IREDELL -! -! USAGE: CALL VINTG(IM,KM1,KM2,NT,P1,U1,V1,T1,Q1,P2, -! & U2,V2,T2,Q2) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF POINTS TO COMPUTE -! KM1 INTEGER NUMBER OF INPUT LEVELS -! KM2 INTEGER NUMBER OF OUTPUT LEVELS -! NT INTEGER NUMBER OF TRACERS -! P1 REAL (IM,KM1) INPUT PRESSURES -! ORDERED FROM BOTTOM TO TOP OF ATMOSPHERE -! U1 REAL (IM,KM1) INPUT ZONAL WIND -! V1 REAL (IM,KM1) INPUT MERIDIONAL WIND -! T1 REAL (IM,KM1) INPUT TEMPERATURE (K) -! Q1 REAL (IM,KM1,NT) INPUT TRACERS (HUMIDITY FIRST) -! P2 REAL (IM,KM2) OUTPUT PRESSURES -! OUTPUT ARGUMENT LIST: -! U2 REAL (IM,KM2) OUTPUT ZONAL WIND -! V2 REAL (IM,KM2) OUTPUT MERIDIONAL WIND -! T2 REAL (IM,KM2) OUTPUT TEMPERATURE (K) -! Q2 REAL (IM,KM2,NT) OUTPUT TRACERS (HUMIDITY FIRST) -! -! SUBPROGRAMS CALLED: -! TERP3 CUBICALLY INTERPOLATE IN ONE DIMENSION -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IM, KM1, KM2, NT - - REAL, INTENT(IN) :: P1(IM,KM1),U1(IM,KM1),V1(IM,KM1) - REAL, INTENT(IN) :: T1(IM,KM1),Q1(IM,KM1,NT) - REAL, INTENT(IN) :: W1(IM,KM1),P2(IM,KM2) - REAL, INTENT(OUT) :: U2(IM,KM2),V2(IM,KM2) - REAL, INTENT(OUT) :: T2(IM,KM2),Q2(IM,KM2,NT) - REAL, INTENT(OUT) :: W2(IM,KM2) - - REAL, PARAMETER :: DLTDZ=-6.5E-3*287.05/9.80665 - REAL, PARAMETER :: DLPVDRT=-2.5E6/461.50 - - INTEGER :: I, K, N - - REAL :: DZ - REAL,ALLOCATABLE :: Z1(:,:),Z2(:,:) - REAL,ALLOCATABLE :: C1(:,:,:),C2(:,:,:),J2(:,:,:) - - ALLOCATE (Z1(IM+1,KM1),Z2(IM+1,KM2)) - ALLOCATE (C1(IM+1,KM1,4+NT),C2(IM+1,KM2,4+NT),J2(IM+1,KM2,4+NT)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE LOG PRESSURE INTERPOLATING COORDINATE -! AND COPY INPUT WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS -!$OMP PARALLEL DO PRIVATE(K,I) - DO K=1,KM1 - DO I=1,IM - Z1(I,K) = -LOG(P1(I,K)) - C1(I,K,1) = U1(I,K) - C1(I,K,2) = V1(I,K) - C1(I,K,3) = W1(I,K) - C1(I,K,4) = T1(I,K) - C1(I,K,5) = Q1(I,K,1) - ENDDO - ENDDO -!$OMP END PARALLEL DO - DO N=2,NT - DO K=1,KM1 - DO I=1,IM - C1(I,K,4+N) = Q1(I,K,N) - ENDDO - ENDDO - ENDDO -!$OMP PARALLEL DO PRIVATE(K,I) - DO K=1,KM2 - DO I=1,IM - Z2(I,K) = -LOG(P2(I,K)) - ENDDO - ENDDO -!$OMP END PARALLEL DO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! PERFORM LAGRANGIAN ONE-DIMENSIONAL INTERPOLATION -! THAT IS 4TH-ORDER IN INTERIOR, 2ND-ORDER IN OUTSIDE INTERVALS -! AND 1ST-ORDER FOR EXTRAPOLATION. - CALL TERP3(IM,1,1,1,1,4+NT,(IM+1)*KM1,(IM+1)*KM2, & - KM1,IM+1,IM+1,Z1,C1,KM2,IM+1,IM+1,Z2,C2,J2) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COPY OUTPUT WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS -! EXCEPT BELOW THE INPUT DOMAIN, LET TEMPERATURE INCREASE WITH A FIXED -! LAPSE RATE AND LET THE RELATIVE HUMIDITY REMAIN CONSTANT. - DO K=1,KM2 - DO I=1,IM - U2(I,K)=C2(I,K,1) - V2(I,K)=C2(I,K,2) - W2(I,K)=C2(I,K,3) - DZ=Z2(I,K)-Z1(I,1) - IF(DZ.GE.0) THEN - T2(I,K)=C2(I,K,4) - Q2(I,K,1)=C2(I,K,5) - ELSE - T2(I,K)=T1(I,1)*EXP(DLTDZ*DZ) - Q2(I,K,1)=Q1(I,1,1)*EXP(DLPVDRT*(1/T2(I,K)-1/T1(I,1))-DZ) - ENDIF - ENDDO - ENDDO - DO N=2,NT - DO K=1,KM2 - DO I=1,IM - Q2(I,K,N)=C2(I,K,4+N) - ENDDO - ENDDO - ENDDO - DEALLOCATE (Z1,Z2,C1,C2,J2) - END SUBROUTINE VINTG - end module utils diff --git a/sorc/enkf_chgres_recenter_nc.fd/CMakeLists.txt b/sorc/enkf_chgres_recenter_nc.fd/CMakeLists.txt deleted file mode 100644 index 79375e345f..0000000000 --- a/sorc/enkf_chgres_recenter_nc.fd/CMakeLists.txt +++ /dev/null @@ -1,28 +0,0 @@ -list(APPEND fortran_src -driver.f90 -input_data.f90 -interp.f90 -output_data.f90 -setup.f90 -utils.f90 -) - -if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fp-model precise") -endif() - -set(exe_name enkf_chgres_recenter_nc.x) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - bacio::bacio_4 - ip::ip_4 - sp::sp_4 - w3nco::w3nco_4 - ncio::ncio - NetCDF::NetCDF_Fortran) -if(OpenMP_Fortran_FOUND) - target_link_libraries(${exe_name} OpenMP::OpenMP_Fortran) -endif() - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/enkf_chgres_recenter_nc.fd/driver.f90 b/sorc/enkf_chgres_recenter_nc.fd/driver.f90 deleted file mode 100644 index 1ec7c70f03..0000000000 --- a/sorc/enkf_chgres_recenter_nc.fd/driver.f90 +++ /dev/null @@ -1,67 +0,0 @@ -!!! based on chgres_recenter -!!! cory.r.martin@noaa.gov 2019-09-27 - program regrid - - use setup, only : program_setup - use interp, only : gaus_to_gaus, adjust_for_terrain - use input_data, only : read_input_data, & - read_vcoord_info - use output_data, only : set_output_grid, write_output_data - - implicit none - - call w3tagb('ENKF_CHGRES_RECENTER_NCIO',2019,0270,0085,'NP20') - - print*,"STARTING PROGRAM" - -!-------------------------------------------------------- -! Read configuration namelist. -!-------------------------------------------------------- - - call program_setup - -!-------------------------------------------------------- -! Read input grid data -!-------------------------------------------------------- - - call read_input_data - -!-------------------------------------------------------- -! Read vertical coordinate info -!-------------------------------------------------------- - - call read_vcoord_info - -!-------------------------------------------------------- -! Get output grid specs -!-------------------------------------------------------- - - call set_output_grid - -!-------------------------------------------------------- -! Interpolate data to output grid -!-------------------------------------------------------- - - call gaus_to_gaus - -!-------------------------------------------------------- -! Adjust output fields for differences between -! interpolated and external terrain. -!-------------------------------------------------------- - - call adjust_for_terrain - -!-------------------------------------------------------- -! Write output data to file. -!-------------------------------------------------------- - - call write_output_data - - print* - print*,"PROGRAM FINISHED NORMALLY!" - - call w3tage('ENKF_CHGRES_RECENTER_NCIO') - - stop - - end program regrid diff --git a/sorc/enkf_chgres_recenter_nc.fd/input_data.f90 b/sorc/enkf_chgres_recenter_nc.fd/input_data.f90 deleted file mode 100644 index b77fe26b3e..0000000000 --- a/sorc/enkf_chgres_recenter_nc.fd/input_data.f90 +++ /dev/null @@ -1,345 +0,0 @@ - module input_data - - use utils - use setup - use module_ncio - - implicit none - - private - - integer, public :: idvc, idsl, idvm, nvcoord - integer, public :: nvcoord_input, ntrac, ncldt - integer, public :: ij_input, kgds_input(200) - integer, public :: i_input, j_input, lev, lev_output - integer, public :: idate(6) - integer, public :: icldamt, iicmr, & - idelz,idpres,idzdt, & - irwmr,isnmr,igrle - - - real, allocatable, public :: vcoord(:,:) - real, allocatable, public :: vcoord_input(:,:) - real, allocatable, public :: clwmr_input(:,:) - real, allocatable, public :: dzdt_input(:,:) - real, allocatable, public :: grle_input(:,:) - real, allocatable, public :: cldamt_input(:,:) - real, allocatable, public :: hgt_input(:) - real, allocatable, public :: icmr_input(:,:) - real, allocatable, public :: o3mr_input(:,:) - real, allocatable, public :: rwmr_input(:,:) - real, allocatable, public :: sfcp_input(:) - real, allocatable, public :: snmr_input(:,:) - real, allocatable, public :: spfh_input(:,:) - real, allocatable, public :: tmp_input(:,:) - real, allocatable, public :: ugrd_input(:,:) - real, allocatable, public :: vgrd_input(:,:) - real :: missing_value=1.e30 - - public :: read_input_data - public :: read_vcoord_info - - contains - - subroutine read_input_data - -!------------------------------------------------------------------------------------- -! Read input grid data from a netcdf file. -!------------------------------------------------------------------------------------- - - implicit none - - integer :: vlev,rvlev - type(Dataset) :: indset - type(Dimension) :: ncdim - real, allocatable :: work2d(:,:),work3d(:,:,:) - integer iret, k, kk - real, allocatable :: ak(:), bk(:) - - ! hard code these values that are the same for GFS - idvc=2 - idsl=1 - idvm=1 - ntrac = 8 - ncldt = 5 - - print* - print*,"OPEN INPUT FILE: ",trim(input_file) - indset = open_dataset(input_file) - - print*,"GET INPUT FILE HEADER" - ncdim = get_dim(indset, 'grid_xt'); i_input = ncdim%len - ncdim = get_dim(indset, 'grid_yt'); j_input = ncdim%len - ncdim = get_dim(indset, 'pfull'); lev = ncdim%len - idate = get_idate_from_time_units(indset) - - print*,'DIMENSIONS OF DATA ARE: ', i_input, j_input, lev - print*,'DATE OF DATA IS: ', idate - - ij_input = i_input * j_input - - call read_attribute(indset, 'ak', ak) - call read_attribute(indset, 'bk', bk) - - nvcoord_input = 2 - allocate(vcoord_input(lev+1,nvcoord_input)) - do k = 1, lev+1 - kk = lev+2-k - vcoord_input(k,1) = ak(kk) - vcoord_input(k,2) = bk(kk) - print*,'VCOORD OF INPUT DATA ',k,vcoord_input(k,:) - enddo - - deallocate(ak, bk) - - print* - print*,"READ SURFACE PRESSURE" - call read_vardata(indset, 'pressfc', work2d) - - allocate(sfcp_input(ij_input)) - sfcp_input = reshape(work2d,(/ij_input/)) - print*,'MAX/MIN SURFACE PRESSURE: ',maxval(sfcp_input), minval(sfcp_input) - - print* - print*,"READ SURFACE HEIGHT" - call read_vardata(indset, 'hgtsfc', work2d) - - allocate(hgt_input(ij_input)) - hgt_input = reshape(work2d,(/ij_input/)) - print*,'MAX/MIN SURFACE HEIGHT: ',maxval(hgt_input), minval(hgt_input) - - print* - print*,"READ U WIND" - allocate(ugrd_input(ij_input,lev)) - call read_vardata(indset, 'ugrd', work3d) - do vlev = 1, lev - rvlev = lev+1-vlev - ugrd_input(:,vlev) = reshape(work3d(:,:,rvlev),(/ij_input/)) - print*,'MAX/MIN U WIND AT LEVEL ',vlev, "IS: ", maxval(ugrd_input(:,vlev)), minval(ugrd_input(:,vlev)) - enddo - - print* - print*,"READ V WIND" - allocate(vgrd_input(ij_input,lev)) - call read_vardata(indset, 'vgrd', work3d) - do vlev = 1, lev - rvlev = lev+1-vlev - vgrd_input(:,vlev) = reshape(work3d(:,:,rvlev),(/ij_input/)) - print*,'MAX/MIN V WIND AT LEVEL ', vlev, "IS: ", maxval(vgrd_input(:,vlev)), minval(vgrd_input(:,vlev)) - enddo - - print* - print*,"READ TEMPERATURE" - allocate(tmp_input(ij_input,lev)) - call read_vardata(indset, 'tmp', work3d) - do vlev = 1, lev - rvlev = lev+1-vlev - tmp_input(:,vlev) = reshape(work3d(:,:,rvlev),(/ij_input/)) - print*,'MAX/MIN TEMPERATURE AT LEVEL ', vlev, 'IS: ', maxval(tmp_input(:,vlev)), minval(tmp_input(:,vlev)) - enddo - - print* - print*,"READ SPECIFIC HUMIDITY" - allocate(spfh_input(ij_input,lev)) - call read_vardata(indset, 'spfh', work3d) - do vlev = 1, lev - rvlev = lev+1-vlev - spfh_input(:,vlev) = reshape(work3d(:,:,rvlev),(/ij_input/)) - print*,'MAX/MIN SPECIFIC HUMIDITY AT LEVEL ', vlev, 'IS: ', maxval(spfh_input(:,vlev)), minval(spfh_input(:,vlev)) - enddo - - print* - print*,"READ CLOUD LIQUID WATER" - allocate(clwmr_input(ij_input,lev)) - call read_vardata(indset, 'clwmr', work3d) - do vlev = 1, lev - rvlev = lev+1-vlev - clwmr_input(:,vlev) = reshape(work3d(:,:,rvlev),(/ij_input/)) - print*,'MAX/MIN CLOUD LIQUID WATER AT LEVEL ', vlev, 'IS: ', maxval(clwmr_input(:,vlev)), minval(clwmr_input(:,vlev)) - enddo - - print* - print*,"READ OZONE" - allocate(o3mr_input(ij_input,lev)) - call read_vardata(indset, 'o3mr', work3d) - do vlev = 1, lev - rvlev = lev+1-vlev - o3mr_input(:,vlev) = reshape(work3d(:,:,rvlev),(/ij_input/)) - print*,'MAX/MIN OZONE AT LEVEL ', vlev, 'IS: ', maxval(o3mr_input(:,vlev)), minval(o3mr_input(:,vlev)) - enddo - - print* - print*,"READ DZDT" - allocate(dzdt_input(ij_input,lev)) - call read_vardata(indset, 'dzdt', work3d, errcode=iret) - if (iret == 0) then - do vlev = 1, lev - rvlev = lev+1-vlev - dzdt_input(:,vlev) = reshape(work3d(:,:,rvlev),(/ij_input/)) - print*,'MAX/MIN DZDT AT LEVEL ', vlev, 'IS: ', maxval(dzdt_input(:,vlev)), minval(dzdt_input(:,vlev)) - enddo - idzdt = 1 - else - dzdt_input = missing_value - print*,'DZDT NOT IN INPUT FILE' - idzdt = 0 - endif - - - print* - print*,"READ RWMR" - allocate(rwmr_input(ij_input,lev)) - call read_vardata(indset, 'rwmr', work3d, errcode=iret) - if (iret == 0) then - do vlev = 1, lev - rvlev = lev+1-vlev - rwmr_input(:,vlev) = reshape(work3d(:,:,rvlev),(/ij_input/)) - print*,'MAX/MIN RWMR AT LEVEL ', vlev, 'IS: ', maxval(rwmr_input(:,vlev)), minval(rwmr_input(:,vlev)) - enddo - irwmr = 1 - else - rwmr_input = missing_value - print*,'RWMR NOT IN INPUT FILE' - irwmr = 0 - endif - - print* - print*,"READ ICMR" - allocate(icmr_input(ij_input,lev)) - call read_vardata(indset, 'icmr', work3d, errcode=iret) - if (iret == 0) then - do vlev = 1, lev - rvlev = lev+1-vlev - icmr_input(:,vlev) = reshape(work3d(:,:,rvlev),(/ij_input/)) - print*,'MAX/MIN ICMR AT LEVEL ', vlev, 'IS: ', maxval(icmr_input(:,vlev)), minval(icmr_input(:,vlev)) - enddo - iicmr = 1 - else - icmr_input = missing_value - print*,'ICMR NOT IN INPUT FILE' - iicmr = 0 - endif - - print* - print*,"READ SNMR" - allocate(snmr_input(ij_input,lev)) - call read_vardata(indset, 'snmr', work3d, errcode=iret) - if (iret == 0) then - do vlev = 1, lev - rvlev = lev+1-vlev - snmr_input(:,vlev) = reshape(work3d(:,:,rvlev),(/ij_input/)) - print*,'MAX/MIN SNMR AT LEVEL ', vlev, 'IS: ', maxval(snmr_input(:,vlev)), minval(snmr_input(:,vlev)) - enddo - isnmr = 1 - else - snmr_input = missing_value - print*,'SNMR NOT IN INPUT FILE' - isnmr = 0 - endif - - print* - print*,"READ GRLE" - allocate(grle_input(ij_input,lev)) - call read_vardata(indset, 'grle', work3d, errcode=iret) - if (iret == 0) then - do vlev = 1, lev - rvlev = lev+1-vlev - grle_input(:,vlev) = reshape(work3d(:,:,rvlev),(/ij_input/)) - print*,'MAX/MIN GRLE AT LEVEL ', vlev, 'IS: ', maxval(grle_input(:,vlev)), minval(grle_input(:,vlev)) - enddo - igrle = 1 - else - grle_input = missing_value - print*,'GRLE NOT IN INPUT FILE' - igrle = 0 - endif - - print* - print*,"READ CLD_AMT" - allocate(cldamt_input(ij_input,lev)) - if (cld_amt) then - call read_vardata(indset, 'cld_amt', work3d, errcode=iret) - if (iret == 0) then - do vlev = 1, lev - rvlev = lev+1-vlev - cldamt_input(:,vlev) = reshape(work3d(:,:,rvlev),(/ij_input/)) - print*,'MAX/MIN CLD_AMT AT LEVEL ', vlev, 'IS: ', maxval(cldamt_input(:,vlev)), minval(cldamt_input(:,vlev)) - enddo - icldamt = 1 - else - cldamt_input = missing_value - print*,'CLDAMT NOT IN INPUT FILE' - icldamt = 0 - endif - else - cldamt_input = missing_value - print*,'CLDAMT NOT READ - CLD_AMT NAMELIST OPTION NOT SET TO TRUE' - icldamt = 0 - end if - - call read_vardata(indset, 'dpres', work3d, errcode=iret) - if (iret == 0) then - idpres = 1 - else - idpres = 0 - endif - call read_vardata(indset, 'delz', work3d, errcode=iret) - if (iret == 0) then - idelz = 1 - else - idelz = 0 - endif - - print*,"CLOSE FILE" - call close_dataset(indset) - deallocate(work2d,work3d) - -!--------------------------------------------------------------------------------------- -! Set the grib 1 grid description array need by the NCEP IPOLATES library. -!--------------------------------------------------------------------------------------- - - call calc_kgds(i_input, j_input, kgds_input) - - return - - end subroutine read_input_data - - subroutine read_vcoord_info - -!--------------------------------------------------------------------------------- -! Read vertical coordinate information. -!--------------------------------------------------------------------------------- - - implicit none - - integer :: istat, n, k, k2 - - real, allocatable :: ak(:), bk(:) - - type(Dataset) :: refdset - - print* - print*,"READ OUTPUT VERT COORDINATE INFO FROM REFERENCE FILE: ",trim(ref_file) - - refdset = open_dataset(ref_file) - call read_attribute(refdset, 'ak', ak) - call read_attribute(refdset, 'bk', bk) - call close_dataset(refdset) - - lev_output = size(bk) - 1 - - nvcoord=2 - allocate(vcoord(lev_output+1, nvcoord)) - - do k = 1, (lev_output+1) - k2 = lev_output+2 - k - vcoord(k,1) = ak(k2) - vcoord(k,2) = bk(k2) - print*,'VCOORD OF OUTPUT GRID ',k,vcoord(k,:) - enddo - - deallocate (ak, bk) - - end subroutine read_vcoord_info - - end module input_data diff --git a/sorc/enkf_chgres_recenter_nc.fd/interp.f90 b/sorc/enkf_chgres_recenter_nc.fd/interp.f90 deleted file mode 100644 index 291e8ef0d3..0000000000 --- a/sorc/enkf_chgres_recenter_nc.fd/interp.f90 +++ /dev/null @@ -1,582 +0,0 @@ - module interp - - implicit none - - private - - real, allocatable :: sfcp_b4_adj_output(:) - real, allocatable :: clwmr_b4_adj_output(:,:) - real, allocatable :: dzdt_b4_adj_output(:,:) - real, allocatable :: grle_b4_adj_output(:,:) - real, allocatable :: cldamt_b4_adj_output(:,:) - real, allocatable :: icmr_b4_adj_output(:,:) - real, allocatable :: o3mr_b4_adj_output(:,:) - real, allocatable :: rwmr_b4_adj_output(:,:) - real, allocatable :: snmr_b4_adj_output(:,:) - real, allocatable :: spfh_b4_adj_output(:,:) - real, allocatable :: tmp_b4_adj_output(:,:) - real, allocatable :: ugrd_b4_adj_output(:,:) - real, allocatable :: vgrd_b4_adj_output(:,:) - - public :: adjust_for_terrain - public :: gaus_to_gaus - - contains - - subroutine adjust_for_terrain - -!--------------------------------------------------------------------------------- -! Adjust fields based on differences between the interpolated and external -! terrain. -!--------------------------------------------------------------------------------- - - use input_data - use output_data - use utils - use setup - - implicit none - - integer :: k - - real, allocatable :: pres_b4_adj_output(:,:) - real, allocatable :: pres_output(:,:) - real, allocatable :: q_b4_adj_output(:,:,:), q_output(:,:,:) - -!--------------------------------------------------------------------------------- -! First, compute the mid-layer pressure using the interpolated surface pressure. -!--------------------------------------------------------------------------------- - - allocate(pres_b4_adj_output(ij_output,lev)) - pres_b4_adj_output = 0.0 - - print*,'before newpr1, sfcp b4 adj: ', sfcp_b4_adj_output(ij_output/2) - - print* - print*,"COMPUTE MID-LAYER PRESSURE FROM INTERPOLATED SURFACE PRESSURE." - call newpr1(ij_output, lev, idvc, idsl, nvcoord_input, vcoord_input, & - sfcp_b4_adj_output, pres_b4_adj_output) - - print*,'after newpr1, pres b4 adj: ', pres_b4_adj_output(ij_output/2,:) - -!--------------------------------------------------------------------------------- -! Adjust surface pressure based on differences between interpolated and -! grid terrain. -!--------------------------------------------------------------------------------- - - allocate(sfcp_output(ij_output)) - sfcp_output = 0.0 - - print*,"ADJUST SURFACE PRESSURE BASED ON TERRAIN DIFFERENCES" - call newps(hgt_output, sfcp_b4_adj_output, ij_output, & - lev, pres_b4_adj_output, tmp_b4_adj_output, & - spfh_b4_adj_output, hgt_external_output, sfcp_output) - - print*,'after newps ',sfcp_b4_adj_output(ij_output/2),sfcp_output(ij_output/2) - - deallocate(sfcp_b4_adj_output) - -!--------------------------------------------------------------------------------- -! Recompute mid-layer pressure based on the adjusted surface pressure. -!--------------------------------------------------------------------------------- - - allocate(pres_output(ij_output, lev_output)) - pres_output = 0.0 - - allocate(dpres_output(ij_output, lev_output)) - dpres_output = 0.0 - - print*,'before newpr1 ',sfcp_output(ij_output/2) - print*,'before newpr1 ',idvc,idsl,nvcoord,vcoord - - print*,"RECOMPUTE MID-LAYER PRESSURE." - call newpr1(ij_output, lev_output, idvc, idsl, nvcoord, vcoord, & - sfcp_output, pres_output, dpres_output) - - do k = 1, lev_output - print*,'after newpr1 ',pres_output(ij_output/2,k), dpres_output(ij_output/2,k) - enddo - -!--------------------------------------------------------------------------------- -! Vertically interpolate from the pre-adjusted to the adjusted mid-layer -! pressures. -!--------------------------------------------------------------------------------- - - allocate(q_b4_adj_output(ij_output,lev,ntrac)) - q_b4_adj_output(:,:,1) = spfh_b4_adj_output(:,:) - q_b4_adj_output(:,:,2) = o3mr_b4_adj_output(:,:) - q_b4_adj_output(:,:,3) = clwmr_b4_adj_output(:,:) - q_b4_adj_output(:,:,4) = rwmr_b4_adj_output(:,:) - q_b4_adj_output(:,:,5) = icmr_b4_adj_output(:,:) - q_b4_adj_output(:,:,6) = snmr_b4_adj_output(:,:) - q_b4_adj_output(:,:,7) = grle_b4_adj_output(:,:) - q_b4_adj_output(:,:,8) = cldamt_b4_adj_output(:,:) - - allocate(q_output(ij_output,lev_output,ntrac)) - q_output = 0.0 - - allocate(dzdt_output(ij_output,lev_output)) - dzdt_output = 0.0 - - allocate(ugrd_output(ij_output,lev_output)) - ugrd_output=0.0 - - allocate(vgrd_output(ij_output,lev_output)) - vgrd_output=0.0 - - allocate(tmp_output(ij_output,lev_output)) - tmp_output=0.0 - - print*,"VERTICALLY INTERPOLATE TO NEW PRESSURE LEVELS" - call vintg(ij_output, lev, lev_output, ntrac, pres_b4_adj_output, & - ugrd_b4_adj_output, vgrd_b4_adj_output, tmp_b4_adj_output, q_b4_adj_output, & - dzdt_b4_adj_output, pres_output, ugrd_output, vgrd_output, tmp_output, & - q_output, dzdt_output) - - deallocate (dzdt_b4_adj_output, q_b4_adj_output) -!deallocate (pres_b4_adj_output, pres_output) - - allocate(spfh_output(ij_output,lev_output)) - spfh_output = q_output(:,:,1) - allocate(o3mr_output(ij_output,lev_output)) - o3mr_output = q_output(:,:,2) - allocate(clwmr_output(ij_output,lev_output)) - clwmr_output = q_output(:,:,3) - allocate(rwmr_output(ij_output,lev_output)) - rwmr_output = q_output(:,:,4) - allocate(icmr_output(ij_output,lev_output)) - icmr_output = q_output(:,:,5) - allocate(snmr_output(ij_output,lev_output)) - snmr_output = q_output(:,:,6) - allocate(grle_output(ij_output,lev_output)) - grle_output = q_output(:,:,7) - allocate(cldamt_output(ij_output,lev_output)) - cldamt_output = q_output(:,:,8) - - deallocate(q_output) - - do k = 1, lev - print*,'after vintg tmp b4 ',tmp_b4_adj_output(ij_output/2,k), pres_b4_adj_output(ij_output/2,k) - enddo - do k = 1, lev_output - print*,'after vintg tmp ',tmp_output(ij_output/2,k),pres_output(ij_output/2,k) - enddo - - deallocate(tmp_b4_adj_output) - - deallocate(ugrd_b4_adj_output) - - deallocate(vgrd_b4_adj_output) - - deallocate(spfh_b4_adj_output) - - deallocate(o3mr_b4_adj_output) - - deallocate(clwmr_b4_adj_output) - - deallocate(rwmr_b4_adj_output) - - deallocate(icmr_b4_adj_output) - - deallocate(snmr_b4_adj_output) - - deallocate(grle_b4_adj_output) - - deallocate(cldamt_b4_adj_output) - - allocate(delz_output(ij_output, lev_output)) - delz_output = 0.0 - - call compute_delz(ij_output, lev_output, vcoord(:,1), vcoord(:,2), sfcp_output, hgt_output, & - tmp_output, spfh_output, delz_output) - - do k = 1, lev_output - print*,'after compute_delz ',delz_output(ij_output/2,k) - enddo - - deallocate(hgt_output) - - end subroutine adjust_for_terrain - - subroutine gaus_to_gaus - -!---------------------------------------------------------------------------------- -! Interpolate data from the input to output grid using IPOLATES library. -!---------------------------------------------------------------------------------- - - use output_data - use input_data - use setup - - implicit none - - integer :: ip, ipopt(20), i - integer :: num_fields - integer :: iret, numpts - integer, allocatable :: ibi(:), ibo(:) - - logical*1, allocatable :: bitmap_input(:,:), bitmap_output(:,:) - logical :: same_grid - - real, allocatable :: data_input(:,:) - real, allocatable :: data_output(:,:), crot(:), srot(:) - - same_grid=.true. - do i = 1, 11 - if (kgds_input(i) /= kgds_output(i)) then - same_grid=.false. - exit - endif - enddo - - if (same_grid) then - - print* - print*,'INPUT AND OUTPUT GRIDS ARE THE SAME.' - print*,'NO HORIZ INTERPOLATION REQUIRED.' - - allocate(hgt_output(ij_output)) - hgt_output = hgt_input - deallocate(hgt_input) - - allocate(sfcp_b4_adj_output(ij_output)) - sfcp_b4_adj_output = sfcp_input - deallocate(sfcp_input) - - allocate(tmp_b4_adj_output(ij_output,lev)) - tmp_b4_adj_output = tmp_input - deallocate(tmp_input) - - allocate(clwmr_b4_adj_output(ij_output,lev)) - clwmr_b4_adj_output = clwmr_input - deallocate(clwmr_input) - - allocate(spfh_b4_adj_output(ij_output,lev)) - spfh_b4_adj_output = spfh_input - deallocate(spfh_input) - - allocate(o3mr_b4_adj_output(ij_output,lev)) - o3mr_b4_adj_output = o3mr_input - deallocate(o3mr_input) - - allocate(dzdt_b4_adj_output(ij_output,lev)) - dzdt_b4_adj_output = dzdt_input - deallocate(dzdt_input) - - allocate(rwmr_b4_adj_output(ij_output,lev)) - rwmr_b4_adj_output = rwmr_input - deallocate(rwmr_input) - - allocate(snmr_b4_adj_output(ij_output,lev)) - snmr_b4_adj_output = snmr_input - deallocate(snmr_input) - - allocate(icmr_b4_adj_output(ij_output,lev)) - icmr_b4_adj_output = icmr_input - deallocate(icmr_input) - - allocate(grle_b4_adj_output(ij_output,lev)) - grle_b4_adj_output = grle_input - deallocate(grle_input) - - allocate(cldamt_b4_adj_output(ij_output,lev)) - cldamt_b4_adj_output = cldamt_input - deallocate(cldamt_input) - - allocate(ugrd_b4_adj_output(ij_output,lev)) - ugrd_b4_adj_output = ugrd_input - deallocate(ugrd_input) - - allocate(vgrd_b4_adj_output(ij_output,lev)) - vgrd_b4_adj_output = vgrd_input - deallocate(vgrd_input) - - else - - print* - print*,'INTERPOLATE DATA TO OUTPUT GRID' - - - ip = 0 ! bilinear - ipopt = 0 - -!---------------------------------------------------------------------------------- -! Do 2-D fields first -!---------------------------------------------------------------------------------- - - num_fields = 1 - - allocate(ibi(num_fields)) - ibi = 0 ! no bitmap - allocate(ibo(num_fields)) - ibo = 0 ! no bitmap - - allocate(bitmap_input(ij_input,num_fields)) - bitmap_input = .true. - allocate(bitmap_output(ij_output,num_fields)) - bitmap_output = .true. - - allocate(rlat_output(ij_output)) - rlat_output = 0.0 - allocate(rlon_output(ij_output)) - rlon_output = 0.0 - -!---------------- -! Surface height -!---------------- - - allocate(data_input(ij_input,num_fields)) - data_input(:,num_fields) = hgt_input(:) - deallocate(hgt_input) - - allocate(data_output(ij_output,num_fields)) - data_output = 0 - - print*,"INTERPOLATE SURFACE HEIGHT" - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, data_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - data_output, iret) - if (iret /= 0) goto 89 - - allocate(hgt_output(ij_output)) - hgt_output = data_output(:,num_fields) - -!------------------ -! surface pressure -!------------------ - - data_input(:,num_fields) = sfcp_input(:) - deallocate(sfcp_input) - - print*,"INTERPOLATE SURFACE PRESSURE" - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, data_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - data_output, iret) - if (iret /= 0) goto 89 - - allocate(sfcp_b4_adj_output(ij_output)) - sfcp_b4_adj_output = data_output(:,num_fields) - - deallocate(ibi, ibo, bitmap_input, bitmap_output, data_input, data_output) - -!---------------------------------------------------------------------------------- -! 3d scalars -!---------------------------------------------------------------------------------- - - num_fields = lev - - allocate(ibi(num_fields)) - ibi = 0 ! no bitmap - allocate(ibo(num_fields)) - ibo = 0 ! no bitmap - - allocate(bitmap_input(ij_input,num_fields)) - bitmap_input = .true. - allocate(bitmap_output(ij_output,num_fields)) - bitmap_output = .true. - -!------------- -! Temperature -!------------- - - allocate(tmp_b4_adj_output(ij_output,num_fields)) - tmp_b4_adj_output = 0 - - print*,'INTERPOLATE TEMPERATURE' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, tmp_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - tmp_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(tmp_input) - -!-------------------- -! Cloud liquid water -!-------------------- - - allocate(clwmr_b4_adj_output(ij_output,num_fields)) - clwmr_b4_adj_output = 0 - - print*,'INTERPOLATE CLOUD LIQUID WATER' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, clwmr_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - clwmr_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(clwmr_input) - -!-------------------- -! Specific humidity -!-------------------- - - allocate(spfh_b4_adj_output(ij_output,num_fields)) - spfh_b4_adj_output = 0 - - print*,'INTERPOLATE SPECIFIC HUMIDITY' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, spfh_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - spfh_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(spfh_input) - -!----------- -! Ozone -!----------- - - allocate(o3mr_b4_adj_output(ij_output,num_fields)) - o3mr_b4_adj_output = 0 - - print*,'INTERPOLATE OZONE' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, o3mr_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - o3mr_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(o3mr_input) - -!----------- -! DZDT -!----------- - - allocate(dzdt_b4_adj_output(ij_output,num_fields)) - dzdt_b4_adj_output = 0 - - print*,'INTERPOLATE DZDT' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, dzdt_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - dzdt_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(dzdt_input) - -!---------------------------------------------------------------------------------- -! Interpolate additional 3-d scalars for GFDL microphysics. -!---------------------------------------------------------------------------------- - - -!------------- -! Rain water -!------------- - - allocate(rwmr_b4_adj_output(ij_output,num_fields)) - rwmr_b4_adj_output = 0 - - print*,'INTERPOLATE RWMR' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, rwmr_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - rwmr_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(rwmr_input) - -!------------- -! Snow water -!------------- - - allocate(snmr_b4_adj_output(ij_output,num_fields)) - snmr_b4_adj_output = 0 - - print*,'INTERPOLATE SNMR' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, snmr_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - snmr_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(snmr_input) - -!------------- -! Ice water -!------------- - - allocate(icmr_b4_adj_output(ij_output,num_fields)) - icmr_b4_adj_output = 0 - - print*,'INTERPOLATE ICMR' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, icmr_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - icmr_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(icmr_input) - -!------------- -! Graupel -!------------- - - allocate(grle_b4_adj_output(ij_output,num_fields)) - grle_b4_adj_output = 0 - - print*,'INTERPOLATE GRLE' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, grle_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - grle_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(grle_input) - - -!--------------------------- -! Cloud amount -!--------------------------- - - allocate(cldamt_b4_adj_output(ij_output,num_fields)) - cldamt_b4_adj_output = 0 - - print*,'INTERPOLATE CLD_AMT' - call ipolates(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, cldamt_input, & - numpts, rlat_output, rlon_output, ibo, bitmap_output, & - cldamt_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate(cldamt_input) - - - -!---------------------------------------------------------------------------------- -! 3d u/v winds -!---------------------------------------------------------------------------------- - - allocate(crot(ij_output), srot(ij_output)) - crot = 0. - srot = 0. - - allocate(ugrd_b4_adj_output(ij_output,num_fields)) - ugrd_b4_adj_output = 0 - allocate(vgrd_b4_adj_output(ij_output,num_fields)) - vgrd_b4_adj_output = 0 - - print*,'INTERPOLATE WINDS' - call ipolatev(ip, ipopt, kgds_input, kgds_output, ij_input, ij_output,& - num_fields, ibi, bitmap_input, ugrd_input, vgrd_input, & - numpts, rlat_output, rlon_output, crot, srot, ibo, bitmap_output, & - ugrd_b4_adj_output, vgrd_b4_adj_output, iret) - if (iret /= 0) goto 89 - - deallocate (ugrd_input, vgrd_input) - deallocate (crot, srot) - deallocate (ibi, ibo, bitmap_input, bitmap_output) - - endif - - return - - 89 continue - print*,"FATAL ERROR IN IPOLATES. IRET IS: ", iret - call errexit(23) - - end subroutine gaus_to_gaus - - end module interp diff --git a/sorc/enkf_chgres_recenter_nc.fd/makefile b/sorc/enkf_chgres_recenter_nc.fd/makefile deleted file mode 100644 index c9f4c7be37..0000000000 --- a/sorc/enkf_chgres_recenter_nc.fd/makefile +++ /dev/null @@ -1,28 +0,0 @@ -SHELL= /bin/sh - -LIBS= $(FV3GFS_NCIO_LIB) $(BACIO_LIB4) $(W3NCO_LIB4) $(IP_LIB4) $(SP_LIB4) -L$(NETCDF)/lib -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lz - -CMD= enkf_chgres_recenter_nc.x - -OBJS = driver.o input_data.o interp.o output_data.o utils.o setup.o - -$(CMD): $(OBJS) - $(FC) $(FFLAGS) -o $(CMD) $(OBJS) $(LIBS) - -driver.o: setup.o output_data.o interp.o input_data.o driver.f90 - $(FC) $(FFLAGS) -I$(FV3GFS_NCIO_INC) -I$(NETCDF)/include -c driver.f90 -interp.o: setup.o utils.o output_data.o input_data.o interp.f90 - $(FC) $(FFLAGS) -I$(FV3GFS_NCIO_INC) -I$(NETCDF)/include -c interp.f90 -input_data.o: setup.o utils.o input_data.f90 - $(FC) $(FFLAGS) -I$(FV3GFS_NCIO_INC) -I$(NETCDF)/include -c input_data.f90 -output_data.o: setup.o utils.o input_data.o output_data.f90 - $(FC) $(FFLAGS) -I$(FV3GFS_NCIO_INC) -I$(NETCDF)/include -c output_data.f90 -setup.o: setup.f90 - $(FC) $(FFLAGS) -I$(FV3GFS_NCIO_INC) -I$(NETCDF)/include -c setup.f90 -utils.o: utils.f90 - $(FC) $(FFLAGS) -I$(FV3GFS_NCIO_INC) -I$(NETCDF)/include -c utils.f90 -clean: - rm -f *.o *.mod ${CMD} -install: - -cp $(CMD) ../../exec/. - diff --git a/sorc/enkf_chgres_recenter_nc.fd/output_data.f90 b/sorc/enkf_chgres_recenter_nc.fd/output_data.f90 deleted file mode 100644 index 00b39fc7c8..0000000000 --- a/sorc/enkf_chgres_recenter_nc.fd/output_data.f90 +++ /dev/null @@ -1,288 +0,0 @@ - module output_data - - use module_ncio - - implicit none - - private - - integer, public :: kgds_output(200) - -! data on the output grid. - real, allocatable, public :: hgt_output(:) ! interpolated from input grid - real, allocatable, public :: hgt_external_output(:) - real, allocatable, public :: sfcp_output(:) - real, allocatable, public :: tmp_output(:,:) - real, allocatable, public :: clwmr_output(:,:) - real, allocatable, public :: delz_output(:,:) - real, allocatable, public :: dpres_output(:,:) - real, allocatable, public :: dzdt_output(:,:) - real, allocatable, public :: o3mr_output(:,:) - real, allocatable, public :: spfh_output(:,:) - real, allocatable, public :: ugrd_output(:,:) - real, allocatable, public :: vgrd_output(:,:) - real, allocatable, public :: rwmr_output(:,:) - real, allocatable, public :: icmr_output(:,:) - real, allocatable, public :: snmr_output(:,:) - real, allocatable, public :: grle_output(:,:) - real, allocatable, public :: cldamt_output(:,:) - real, allocatable, public :: rlat_output(:) - real, allocatable, public :: rlon_output(:) - - public :: set_output_grid - public :: write_output_data - type(Dataset) :: indset, outdset - - - contains - - subroutine set_output_grid - -!------------------------------------------------------------------- -! Set grid specs on the output grid. -!------------------------------------------------------------------- - - use setup - use input_data - use utils - - implicit none - - - type(Dataset) :: indset - real, allocatable :: work2d(:,:) - - - - print* - print*,"OUTPUT GRID I/J DIMENSIONS: ", i_output, j_output - -!------------------------------------------------------------------- -! Set the grib 1 grid description section, which is needed -! by the IPOLATES library. -!------------------------------------------------------------------- - - kgds_output = 0 - - call calc_kgds(i_output, j_output, kgds_output) - -!------------------------------------------------------------------- -! Read the terrain on the output grid. To ensure exact match, -! read it from an existing netcdf file. -!------------------------------------------------------------------- - - print* - print*,"OPEN OUTPUT GRID TERRAIN FILE: ", trim(terrain_file) - indset = open_dataset(terrain_file) - - allocate(hgt_external_output(ij_output)) - - print* - print*,"READ SURFACE HEIGHT" - call read_vardata(indset, 'hgtsfc', work2d) - - hgt_external_output = reshape(work2d,(/ij_output/)) - - call close_dataset(indset) - - end subroutine set_output_grid - - subroutine write_output_data - -!------------------------------------------------------------------- -! Write output grid data to a netcdf file. -!------------------------------------------------------------------- - - use input_data - use setup - - implicit none - - integer :: n,nrev - real, allocatable, dimension (:,:) :: out2d - real, allocatable, dimension (:,:,:) :: out3d - -!------------------------------------------------------------------- -! Set up some header info. -!------------------------------------------------------------------- - - call header_set - -!------------------------------------------------------------------- -! Open and write file. -!------------------------------------------------------------------- -! TODO: note there can be compression applied to this output file if necessary -! see how it's done in the GSI EnKF for example - - - print* - print*,'OPEN OUTPUT FILE: ',trim(output_file) - allocate(out2d(i_output,j_output)) - allocate(out3d(i_output,j_output,lev_output)) - - print*,"WRITE SURFACE HEIGHT" - out2d = reshape(hgt_external_output, (/i_output,j_output/)) - call write_vardata(outdset, 'hgtsfc', out2d) - deallocate(hgt_external_output) - - print*,"WRITE SURFACE PRESSURE" - out2d = reshape(sfcp_output, (/i_output,j_output/)) - call write_vardata(outdset, 'pressfc', out2d) - deallocate(sfcp_output) - - print*,"WRITE TEMPERATURE" - do n=1,lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(tmp_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'tmp', out3d) - deallocate(tmp_output) - - print*,"WRITE CLOUD LIQUID WATER" - do n=1,lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(clwmr_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'clwmr', out3d) - deallocate(clwmr_output) - - print*,"WRITE SPECIFIC HUMIDITY" - do n=1,lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(spfh_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'spfh', out3d) - deallocate(spfh_output) - - print*,"WRITE OZONE" - do n=1,lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(o3mr_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'o3mr', out3d) - deallocate(o3mr_output) - - print*,"WRITE U-WINDS" - do n=1,lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(ugrd_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'ugrd', out3d) - deallocate(ugrd_output) - - print*,"WRITE V-WINDS" - do n=1,lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(vgrd_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'vgrd', out3d) - deallocate(vgrd_output) - - if (idzdt == 1) then - print*,"WRITE DZDT" - do n=1,lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(dzdt_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'dzdt', out3d) - deallocate(dzdt_output) - endif - - if (idpres == 1) then - print*,"WRITE DPRES" - do n=1,lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(dpres_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'dpres', out3d) - endif - deallocate(dpres_output) - - if (idelz == 1) then - print*,"WRITE DELZ" - do n=1,lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(delz_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'delz', out3d) - endif - deallocate(delz_output) - - if (irwmr == 1) then - print*,"WRITE RAIN WATER" - do n=1,lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(rwmr_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'rwmr', out3d) - deallocate(rwmr_output) - endif - - if (isnmr == 1) then - print*,"WRITE SNOW WATER" - do n=1,lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(snmr_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'snmr', out3d) - deallocate(snmr_output) - endif - - if (iicmr == 1) then - print*,"WRITE ICE WATER" - do n=1,lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(icmr_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'icmr', out3d) - deallocate(icmr_output) - endif - - if (igrle == 1) then - print*,"WRITE GRAUPEL" - do n=1,lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(grle_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'grle', out3d) - deallocate(grle_output) - endif - - if (icldamt == 1) then - print*,"WRITE CLD_AMT" - do n = 1, lev_output - nrev = lev_output+1-n - out3d(:,:,n) = reshape(cldamt_output(:,nrev), (/i_output,j_output/)) - end do - call write_vardata(outdset, 'cld_amt', out3d) - deallocate(cldamt_output) - endif - - - deallocate(out2d,out3d) - - return - - end subroutine write_output_data - - subroutine header_set - -!------------------------------------------------------------------- -! copy dimensions and metadata to the output file from the -! input terrain (output res) file -!------------------------------------------------------------------- - - use input_data - use setup - - implicit none - - print* - print*,"SET HEADER INFO FOR OUTPUT FILE." - - indset = open_dataset(ref_file) - outdset = create_dataset(output_file, indset, nocompress=.true.) - - end subroutine header_set - - end module output_data diff --git a/sorc/enkf_chgres_recenter_nc.fd/setup.f90 b/sorc/enkf_chgres_recenter_nc.fd/setup.f90 deleted file mode 100644 index ee9956ae03..0000000000 --- a/sorc/enkf_chgres_recenter_nc.fd/setup.f90 +++ /dev/null @@ -1,55 +0,0 @@ - module setup - - implicit none - - private - - character(len=300), public :: input_file - character(len=300), public :: output_file - character(len=300), public :: terrain_file - character(len=300), public :: ref_file - - integer, public :: i_output - integer, public :: j_output - integer , public :: ij_output - logical, public :: cld_amt - - public :: program_setup - - contains - - subroutine program_setup - - implicit none - - integer :: istat - character(len=500) :: filenamelist - - namelist /chgres_setup/ i_output, j_output, input_file, output_file, & - terrain_file, cld_amt, ref_file - - cld_amt = .false. ! default option - - print* - call getarg(1,filenamelist) - print*,"OPEN SETUP NAMELIST ",trim(filenamelist) - open(43, file=filenamelist, iostat=istat) - if (istat /= 0) then - print*,"FATAL ERROR OPENING NAMELIST FILE. ISTAT IS: ",istat - stop - endif - - print*,"READ SETUP NAMELIST." - read(43, nml=chgres_setup, iostat=istat) - if (istat /= 0) then - print*,"FATAL ERROR READING NAMELIST FILE. ISTAT IS: ",istat - stop - endif - - ij_output = i_output * j_output - - close(43) - - end subroutine program_setup - - end module setup diff --git a/sorc/enkf_chgres_recenter_nc.fd/utils.f90 b/sorc/enkf_chgres_recenter_nc.fd/utils.f90 deleted file mode 100644 index 786c3644b5..0000000000 --- a/sorc/enkf_chgres_recenter_nc.fd/utils.f90 +++ /dev/null @@ -1,776 +0,0 @@ - module utils - - private - - public :: calc_kgds - public :: newps - public :: newpr1 - public :: vintg - public :: compute_delz - - contains - - subroutine compute_delz(ijm, levp, ak_in, bk_in, ps, zs, t, sphum, delz) - - implicit none - integer, intent(in):: levp, ijm - real, intent(in), dimension(levp+1):: ak_in, bk_in - real, intent(in), dimension(ijm):: ps, zs - real, intent(in), dimension(ijm,levp):: t - real, intent(in), dimension(ijm,levp):: sphum - real, intent(out), dimension(ijm,levp):: delz -! Local: - real, dimension(ijm,levp+1):: zh - real, dimension(ijm,levp+1):: pe0, pn0 - real, dimension(levp+1) :: ak, bk - integer i,k - real, parameter :: GRAV = 9.80665 - real, parameter :: RDGAS = 287.05 - real, parameter :: RVGAS = 461.50 - real :: zvir - real:: grd - - print*,"COMPUTE LAYER THICKNESS." - - grd = grav/rdgas - zvir = rvgas/rdgas - 1. - ak = ak_in - bk = bk_in - ak(levp+1) = max(1.e-9, ak(levp+1)) - - do i=1, ijm - pe0(i,levp+1) = ak(levp+1) - pn0(i,levp+1) = log(pe0(i,levp+1)) - enddo - - do k=levp,1, -1 - do i=1,ijm - pe0(i,k) = ak(k) + bk(k)*ps(i) - pn0(i,k) = log(pe0(i,k)) - enddo - enddo - - do i = 1, ijm - zh(i,1) = zs(i) - enddo - - do k = 2, levp+1 - do i = 1, ijm - zh(i,k) = zh(i,k-1)+t(i,k-1)*(1.+zvir*sphum(i,k-1))* & - (pn0(i,k-1)-pn0(i,k))/grd - enddo - enddo - - do k = 1, levp - do i = 1, ijm - delz(i,k) = zh(i,k) - zh(i,k+1) - enddo - enddo - - end subroutine compute_delz - - subroutine calc_kgds(idim, jdim, kgds) - - implicit none - - integer, intent(in) :: idim, jdim - - integer, intent(out) :: kgds(200) - - kgds = 0 - kgds(1) = 4 ! OCT 6 - TYPE OF GRID (GAUSSIAN) - kgds(2) = idim ! OCT 7-8 - # PTS ON LATITUDE CIRCLE - kgds(3) = jdim ! OCT 9-10 - # PTS ON LONGITUDE CIRCLE - kgds(4) = 90000 ! OCT 11-13 - LAT OF ORIGIN - kgds(5) = 0 ! OCT 14-16 - LON OF ORIGIN - kgds(6) = 128 ! OCT 17 - RESOLUTION FLAG - kgds(7) = -90000 ! OCT 18-20 - LAT OF EXTREME POINT - kgds(8) = nint(-360000./idim) ! OCT 21-23 - LON OF EXTREME POINT - kgds(9) = nint((360.0 / float(idim))*1000.0) - ! OCT 24-25 - LONGITUDE DIRECTION INCR. - kgds(10) = jdim/2 ! OCT 26-27 - NUMBER OF CIRCLES POLE TO EQUATOR - kgds(12) = 255 ! OCT 29 - RESERVED - kgds(20) = 255 ! OCT 5 - NOT USED, SET TO 255 - - end subroutine calc_kgds - - SUBROUTINE NEWPS(ZS,PS,IM,KM,P,T,Q,ZSNEW,PSNEW) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: NEWPS COMPUTE NEW SURFACE PRESSURE -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -! -! ABSTRACT: COMPUTES A NEW SURFACE PRESSURE GIVEN A NEW OROGRAPHY. -! THE NEW PRESSURE IS COMPUTED ASSUMING A HYDROSTATIC BALANCE -! AND A CONSTANT TEMPERATURE LAPSE RATE. BELOW GROUND, THE -! LAPSE RATE IS ASSUMED TO BE -6.5 K/KM. -! -! PROGRAM HISTORY LOG: -! 91-10-31 MARK IREDELL -! -! USAGE: CALL NEWPS(ZS,PS,IM,KM,P,T,Q,ZSNEW,PSNEW) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF POINTS TO COMPUTE -! ZS REAL (IM) OLD OROGRAPHY (M) -! PS REAL (IM) OLD SURFACE PRESSURE (PA) -! KM INTEGER NUMBER OF LEVELS -! P REAL (IM,KM) PRESSURES (PA) -! T REAL (IM,KM) TEMPERATURES (K) -! Q REAL (IM,KM) SPECIFIC HUMIDITIES (KG/KG) -! ZSNEW REAL (IM) NEW OROGRAPHY (M) -! OUTPUT ARGUMENT LIST: -! PSNEW REAL (IM) NEW SURFACE PRESSURE (PA) -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - REAL ZS(IM),PS(IM),P(IM,KM),T(IM,KM),Q(IM,KM) - REAL ZSNEW(IM),PSNEW(IM) - PARAMETER(BETA=-6.5E-3,EPSILON=1.E-9) - PARAMETER(G=9.80665,RD=287.05,RV=461.50) - PARAMETER(GOR=G/RD,FV=RV/RD-1.) - REAL ZU(IM) - FTV(AT,AQ)=AT*(1+FV*AQ) - FGAM(APU,ATVU,APD,ATVD)=-GOR*LOG(ATVD/ATVU)/LOG(APD/APU) - FZ0(AP,ATV,AZD,APD)=AZD+ATV/GOR*LOG(APD/AP) - FZ1(AP,ATV,AZD,APD,AGAM)=AZD-ATV/AGAM*((APD/AP)**(-AGAM/GOR)-1) - FP0(AZ,AZU,APU,ATVU)=APU*EXP(-GOR/ATVU*(AZ-AZU)) - FP1(AZ,AZU,APU,ATVU,AGAM)=APU*(1+AGAM/ATVU*(AZ-AZU))**(-GOR/AGAM) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE SURFACE PRESSURE BELOW THE ORIGINAL GROUND - LS=0 - K=1 - GAMMA=BETA - DO I=1,IM - PU=P(I,K) - TVU=FTV(T(I,K),Q(I,K)) - ZU(I)=FZ1(PU,TVU,ZS(I),PS(I),GAMMA) - IF(ZSNEW(I).LE.ZU(I)) THEN - PU=P(I,K) - TVU=FTV(T(I,K),Q(I,K)) - IF(ABS(GAMMA).GT.EPSILON) THEN - PSNEW(I)=FP1(ZSNEW(I),ZU(I),PU,TVU,GAMMA) - ELSE - PSNEW(I)=FP0(ZSNEW(I),ZU(I),PU,TVU) - ENDIF - ELSE - PSNEW(I)=0 - LS=LS+1 - ENDIF -! endif - ENDDO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE SURFACE PRESSURE ABOVE THE ORIGINAL GROUND - DO K=2,KM - IF(LS.GT.0) THEN - DO I=1,IM - IF(PSNEW(I).EQ.0) THEN - PU=P(I,K) - TVU=FTV(T(I,K),Q(I,K)) - PD=P(I,K-1) - TVD=FTV(T(I,K-1),Q(I,K-1)) - GAMMA=FGAM(PU,TVU,PD,TVD) - IF(ABS(GAMMA).GT.EPSILON) THEN - ZU(I)=FZ1(PU,TVU,ZU(I),PD,GAMMA) - ELSE - ZU(I)=FZ0(PU,TVU,ZU(I),PD) - ENDIF - IF(ZSNEW(I).LE.ZU(I)) THEN - IF(ABS(GAMMA).GT.EPSILON) THEN - PSNEW(I)=FP1(ZSNEW(I),ZU(I),PU,TVU,GAMMA) - ELSE - PSNEW(I)=FP0(ZSNEW(I),ZU(I),PU,TVU) - ENDIF - LS=LS-1 - ENDIF - ENDIF - ENDDO - ENDIF - ENDDO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE SURFACE PRESSURE OVER THE TOP - IF(LS.GT.0) THEN - K=KM - GAMMA=0 - DO I=1,IM - IF(PSNEW(I).EQ.0) THEN - PU=P(I,K) - TVU=FTV(T(I,K),Q(I,K)) - PSNEW(I)=FP0(ZSNEW(I),ZU(I),PU,TVU) - ENDIF - ENDDO - ENDIF - END SUBROUTINE NEWPS - - SUBROUTINE NEWPR1(IM,KM,IDVC,IDSL,NVCOORD,VCOORD, & - PS,PM,DP) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: NEWPR1 COMPUTE MODEL PRESSURES -! PRGMMR: JUANG ORG: W/NMC23 DATE: 2005-04-11 -! PRGMMR: Fanglin Yang ORG: W/NMC23 DATE: 2006-11-28 -! PRGMMR: S. Moorthi ORG: NCEP/EMC DATE: 2006-12-12 -! PRGMMR: S. Moorthi ORG: NCEP/EMC DATE: 2007-01-02 -! -! ABSTRACT: COMPUTE MODEL PRESSURES. -! -! PROGRAM HISTORY LOG: -! 2005-04-11 HANN_MING HENRY JUANG hybrid sigma, sigma-p, and sigma- -! -! USAGE: CALL NEWPR1(IM,IX,KM,KMP,IDVC,IDSL,NVCOORD,VCOORD,PP,TP,QP,P -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF POINTS TO COMPUTE -! KM INTEGER NUMBER OF LEVELS -! IDVC INTEGER VERTICAL COORDINATE ID -! (1 FOR SIGMA AND 2 FOR HYBRID) -! IDSL INTEGER TYPE OF SIGMA STRUCTURE -! (1 FOR PHILLIPS OR 2 FOR MEAN) -! NVCOORD INTEGER NUMBER OF VERTICAL COORDINATES -! VCOORD REAL (KM+1,NVCOORD) VERTICAL COORDINATE VALUES -! FOR IDVC=1, NVCOORD=1: SIGMA INTERFACE -! FOR IDVC=2, NVCOORD=2: HYBRID INTERFACE A AND B -! FOR IDVC=3, NVCOORD=3: JUANG GENERAL HYBRID INTERFACE -! AK REAL (KM+1) HYBRID INTERFACE A -! BK REAL (KM+1) HYBRID INTERFACE B -! PS REAL (IX) SURFACE PRESSURE (PA) -! OUTPUT ARGUMENT LIST: -! PM REAL (IX,KM) MID-LAYER PRESSURE (PA) -! DP REAL (IX,KM) LAYER DELTA PRESSURE (PA) -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IM, KM, NVCOORD, IDVC, IDSL - - REAL, INTENT(IN) :: VCOORD(KM+1,NVCOORD) - REAL, INTENT(IN) :: PS(IM) - - REAL, INTENT(OUT) :: PM(IM,KM) - REAL, OPTIONAL, INTENT(OUT) :: DP(IM,KM) - - REAL, PARAMETER :: RD=287.05, RV=461.50, CP=1004.6, & - ROCP=RD/CP, ROCP1=ROCP+1, ROCPR=1/ROCP, & - FV=RV/RD-1. - - INTEGER :: I, K - - REAL :: AK(KM+1), BK(KM+1), PI(IM,KM+1) - - IF(IDVC.EQ.2) THEN - DO K=1,KM+1 - AK(K) = VCOORD(K,1) - BK(K) = VCOORD(K,2) - PI(:,K) = AK(K) + BK(K)*PS(:) - ENDDO - ELSE - print*,'routine only works for idvc 2' - stop - ENDIF - - IF(IDSL.EQ.2) THEN - DO K=1,KM - PM(1:IM,K) = (PI(1:IM,K)+PI(1:IM,K+1))/2 - ENDDO - ELSE - DO K=1,KM - PM(1:IM,K) = ((PI(1:IM,K)**ROCP1-PI(1:IM,K+1)**ROCP1)/ & - (ROCP1*(PI(1:IM,K)-PI(1:IM,K+1))))**ROCPR - ENDDO - ENDIF - - IF(PRESENT(DP))THEN - DO K=1,KM - DO I=1,IM - DP(I,K) = PI(I,K) - PI(I,K+1) - ENDDO - ENDDO - ENDIF - - END SUBROUTINE NEWPR1 - - SUBROUTINE TERP3(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, & - KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2,KXQ2,Z2,Q2,J2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: TERP3 CUBICALLY INTERPOLATE IN ONE DIMENSION -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-05-01 -! -! ABSTRACT: INTERPOLATE FIELD(S) IN ONE DIMENSION ALONG THE COLUMN(S). -! THE INTERPOLATION IS CUBIC LAGRANGIAN WITH A MONOTONIC CONSTRAINT -! IN THE CENTER OF THE DOMAIN. IN THE OUTER INTERVALS IT IS LINEAR. -! OUTSIDE THE DOMAIN, FIELDS ARE HELD CONSTANT. -! -! PROGRAM HISTORY LOG: -! 98-05-01 MARK IREDELL -! 1999-01-04 IREDELL USE ESSL SEARCH -! -! USAGE: CALL TERP3(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, -! & KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2,KXQ2,Z2,Q2,J2) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF COLUMNS -! IXZ1 INTEGER COLUMN SKIP NUMBER FOR Z1 -! IXQ1 INTEGER COLUMN SKIP NUMBER FOR Q1 -! IXZ2 INTEGER COLUMN SKIP NUMBER FOR Z2 -! IXQ2 INTEGER COLUMN SKIP NUMBER FOR Q2 -! NM INTEGER NUMBER OF FIELDS PER COLUMN -! NXQ1 INTEGER FIELD SKIP NUMBER FOR Q1 -! NXQ2 INTEGER FIELD SKIP NUMBER FOR Q2 -! KM1 INTEGER NUMBER OF INPUT POINTS -! KXZ1 INTEGER POINT SKIP NUMBER FOR Z1 -! KXQ1 INTEGER POINT SKIP NUMBER FOR Q1 -! Z1 REAL (1+(IM-1)*IXZ1+(KM1-1)*KXZ1) -! INPUT COORDINATE VALUES IN WHICH TO INTERPOLATE -! (Z1 MUST BE STRICTLY MONOTONIC IN EITHER DIRECTION) -! Q1 REAL (1+(IM-1)*IXQ1+(KM1-1)*KXQ1+(NM-1)*NXQ1) -! INPUT FIELDS TO INTERPOLATE -! KM2 INTEGER NUMBER OF OUTPUT POINTS -! KXZ2 INTEGER POINT SKIP NUMBER FOR Z2 -! KXQ2 INTEGER POINT SKIP NUMBER FOR Q2 -! Z2 REAL (1+(IM-1)*IXZ2+(KM2-1)*KXZ2) -! OUTPUT COORDINATE VALUES TO WHICH TO INTERPOLATE -! (Z2 NEED NOT BE MONOTONIC) -! -! OUTPUT ARGUMENT LIST: -! Q2 REAL (1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) -! OUTPUT INTERPOLATED FIELDS -! J2 REAL (1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) -! OUTPUT INTERPOLATED FIELDS CHANGE WRT Z2 -! -! SUBPROGRAMS CALLED: -! RSEARCH SEARCH FOR A SURROUNDING REAL INTERVAL -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE - INTEGER IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2 - INTEGER KM1,KXZ1,KXQ1,KM2,KXZ2,KXQ2 - INTEGER I,K1,K2,N - REAL Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) - REAL Q1(1+(IM-1)*IXQ1+(KM1-1)*KXQ1+(NM-1)*NXQ1) - REAL Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) - REAL Q2(1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) - REAL J2(1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) - REAL FFA(IM),FFB(IM),FFC(IM),FFD(IM) - REAL GGA(IM),GGB(IM),GGC(IM),GGD(IM) - INTEGER K1S(IM,KM2) - REAL Z1A,Z1B,Z1C,Z1D,Q1A,Q1B,Q1C,Q1D,Z2S,Q2S,J2S -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. - CALL RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,1,IM,K1S) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! GENERALLY INTERPOLATE CUBICALLY WITH MONOTONIC CONSTRAINT -! FROM TWO NEAREST INPUT POINTS ON EITHER SIDE OF THE OUTPUT POINT, -! BUT WITHIN THE TWO EDGE INTERVALS INTERPOLATE LINEARLY. -! KEEP THE OUTPUT FIELDS CONSTANT OUTSIDE THE INPUT DOMAIN. - -!!$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(IM,IXZ1,IXQ1,IXZ2), & -!!$OMP& SHARED(IXQ2,NM,NXQ1,NXQ2,KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2), & -!!$OMP& SHARED(KXQ2,Z2,Q2,J2,K1S) - - DO K2=1,KM2 - DO I=1,IM - K1=K1S(I,K2) - IF(K1.EQ.1.OR.K1.EQ.KM1-1) THEN - Z2S=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - Z1A=Z1(1+(I-1)*IXZ1+(K1-1)*KXZ1) - Z1B=Z1(1+(I-1)*IXZ1+(K1+0)*KXZ1) - FFA(I)=(Z2S-Z1B)/(Z1A-Z1B) - FFB(I)=(Z2S-Z1A)/(Z1B-Z1A) - GGA(I)=1/(Z1A-Z1B) - GGB(I)=1/(Z1B-Z1A) - ELSEIF(K1.GT.1.AND.K1.LT.KM1-1) THEN - Z2S=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - Z1A=Z1(1+(I-1)*IXZ1+(K1-2)*KXZ1) - Z1B=Z1(1+(I-1)*IXZ1+(K1-1)*KXZ1) - Z1C=Z1(1+(I-1)*IXZ1+(K1+0)*KXZ1) - Z1D=Z1(1+(I-1)*IXZ1+(K1+1)*KXZ1) - FFA(I)=(Z2S-Z1B)/(Z1A-Z1B)* & - (Z2S-Z1C)/(Z1A-Z1C)* & - (Z2S-Z1D)/(Z1A-Z1D) - FFB(I)=(Z2S-Z1A)/(Z1B-Z1A)* & - (Z2S-Z1C)/(Z1B-Z1C)* & - (Z2S-Z1D)/(Z1B-Z1D) - FFC(I)=(Z2S-Z1A)/(Z1C-Z1A)* & - (Z2S-Z1B)/(Z1C-Z1B)* & - (Z2S-Z1D)/(Z1C-Z1D) - FFD(I)=(Z2S-Z1A)/(Z1D-Z1A)* & - (Z2S-Z1B)/(Z1D-Z1B)* & - (Z2S-Z1C)/(Z1D-Z1C) - GGA(I)= 1/(Z1A-Z1B)* & - (Z2S-Z1C)/(Z1A-Z1C)* & - (Z2S-Z1D)/(Z1A-Z1D)+ & - (Z2S-Z1B)/(Z1A-Z1B)* & - 1/(Z1A-Z1C)* & - (Z2S-Z1D)/(Z1A-Z1D)+ & - (Z2S-Z1B)/(Z1A-Z1B)* & - (Z2S-Z1C)/(Z1A-Z1C)* & - 1/(Z1A-Z1D) - GGB(I)= 1/(Z1B-Z1A)* & - (Z2S-Z1C)/(Z1B-Z1C)* & - (Z2S-Z1D)/(Z1B-Z1D)+ & - (Z2S-Z1A)/(Z1B-Z1A)* & - 1/(Z1B-Z1C)* & - (Z2S-Z1D)/(Z1B-Z1D)+ & - (Z2S-Z1A)/(Z1B-Z1A)* & - (Z2S-Z1C)/(Z1B-Z1C)* & - 1/(Z1B-Z1D) - GGC(I)= 1/(Z1C-Z1A)* & - (Z2S-Z1B)/(Z1C-Z1B)* & - (Z2S-Z1D)/(Z1C-Z1D)+ & - (Z2S-Z1A)/(Z1C-Z1A)* & - 1/(Z1C-Z1B)* & - (Z2S-Z1D)/(Z1C-Z1D)+ & - (Z2S-Z1A)/(Z1C-Z1A)* & - (Z2S-Z1B)/(Z1C-Z1B)* & - 1/(Z1C-Z1D) - GGD(I)= 1/(Z1D-Z1A)* & - (Z2S-Z1B)/(Z1D-Z1B)* & - (Z2S-Z1C)/(Z1D-Z1C)+ & - (Z2S-Z1A)/(Z1D-Z1A)* & - 1/(Z1D-Z1B)* & - (Z2S-Z1C)/(Z1D-Z1C)+ & - (Z2S-Z1A)/(Z1D-Z1A)* & - (Z2S-Z1B)/(Z1D-Z1B)* & - 1/(Z1D-Z1C) - ENDIF - ENDDO -! INTERPOLATE. - DO N=1,NM - DO I=1,IM - K1=K1S(I,K2) - IF(K1.EQ.0) THEN - Q2S=Q1(1+(I-1)*IXQ1+(N-1)*NXQ1) - J2S=0 - ELSEIF(K1.EQ.KM1) THEN - Q2S=Q1(1+(I-1)*IXQ1+(KM1-1)*KXQ1+(N-1)*NXQ1) - J2S=0 - ELSEIF(K1.EQ.1.OR.K1.EQ.KM1-1) THEN - Q1A=Q1(1+(I-1)*IXQ1+(K1-1)*KXQ1+(N-1)*NXQ1) - Q1B=Q1(1+(I-1)*IXQ1+(K1+0)*KXQ1+(N-1)*NXQ1) - Q2S=FFA(I)*Q1A+FFB(I)*Q1B - J2S=GGA(I)*Q1A+GGB(I)*Q1B - ELSE - Q1A=Q1(1+(I-1)*IXQ1+(K1-2)*KXQ1+(N-1)*NXQ1) - Q1B=Q1(1+(I-1)*IXQ1+(K1-1)*KXQ1+(N-1)*NXQ1) - Q1C=Q1(1+(I-1)*IXQ1+(K1+0)*KXQ1+(N-1)*NXQ1) - Q1D=Q1(1+(I-1)*IXQ1+(K1+1)*KXQ1+(N-1)*NXQ1) - Q2S=FFA(I)*Q1A+FFB(I)*Q1B+FFC(I)*Q1C+FFD(I)*Q1D - J2S=GGA(I)*Q1A+GGB(I)*Q1B+GGC(I)*Q1C+GGD(I)*Q1D - IF(Q2S.LT.MIN(Q1B,Q1C)) THEN - Q2S=MIN(Q1B,Q1C) - J2S=0 - ELSEIF(Q2S.GT.MAX(Q1B,Q1C)) THEN - Q2S=MAX(Q1B,Q1C) - J2S=0 - ENDIF - ENDIF - Q2(1+(I-1)*IXQ2+(K2-1)*KXQ2+(N-1)*NXQ2)=Q2S - J2(1+(I-1)*IXQ2+(K2-1)*KXQ2+(N-1)*NXQ2)=J2S - ENDDO - ENDDO - ENDDO -!!$OMP END PARALLEL DO - - END SUBROUTINE TERP3 - - SUBROUTINE RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2,& - L2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: RSEARCH SEARCH FOR A SURROUNDING REAL INTERVAL -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-05-01 -! -! ABSTRACT: THIS SUBPROGRAM SEARCHES MONOTONIC SEQUENCES OF REAL NUMBERS -! FOR INTERVALS THAT SURROUND A GIVEN SEARCH SET OF REAL NUMBERS. -! THE SEQUENCES MAY BE MONOTONIC IN EITHER DIRECTION; THE REAL NUMBERS -! MAY BE SINGLE OR DOUBLE PRECISION; THE INPUT SEQUENCES AND SETS -! AND THE OUTPUT LOCATIONS MAY BE ARBITRARILY DIMENSIONED. -! -! PROGRAM HISTORY LOG: -! 1999-01-05 MARK IREDELL -! -! USAGE: CALL RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2, -! & L2) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF SEQUENCES TO SEARCH -! KM1 INTEGER NUMBER OF POINTS IN EACH SEQUENCE -! IXZ1 INTEGER SEQUENCE SKIP NUMBER FOR Z1 -! KXZ1 INTEGER POINT SKIP NUMBER FOR Z1 -! Z1 REAL (1+(IM-1)*IXZ1+(KM1-1)*KXZ1) -! SEQUENCE VALUES TO SEARCH -! (Z1 MUST BE MONOTONIC IN EITHER DIRECTION) -! KM2 INTEGER NUMBER OF POINTS TO SEARCH FOR -! IN EACH RESPECTIVE SEQUENCE -! IXZ2 INTEGER SEQUENCE SKIP NUMBER FOR Z2 -! KXZ2 INTEGER POINT SKIP NUMBER FOR Z2 -! Z2 REAL (1+(IM-1)*IXZ2+(KM2-1)*KXZ2) -! SET OF VALUES TO SEARCH FOR -! (Z2 NEED NOT BE MONOTONIC) -! IXL2 INTEGER SEQUENCE SKIP NUMBER FOR L2 -! KXL2 INTEGER POINT SKIP NUMBER FOR L2 -! -! OUTPUT ARGUMENT LIST: -! L2 INTEGER (1+(IM-1)*IXL2+(KM2-1)*KXL2) -! INTERVAL LOCATIONS HAVING VALUES FROM 0 TO KM1 -! (Z2 WILL BE BETWEEN Z1(L2) AND Z1(L2+1)) -! -! SUBPROGRAMS CALLED: -! SBSRCH ESSL BINARY SEARCH -! DBSRCH ESSL BINARY SEARCH -! -! REMARKS: -! IF THE ARRAY Z1 IS DIMENSIONED (IM,KM1), THEN THE SKIP NUMBERS ARE -! IXZ1=1 AND KXZ1=IM; IF IT IS DIMENSIONED (KM1,IM), THEN THE SKIP -! NUMBERS ARE IXZ1=KM1 AND KXZ1=1; IF IT IS DIMENSIONED (IM,JM,KM1), -! THEN THE SKIP NUMBERS ARE IXZ1=1 AND KXZ1=IM*JM; ETCETERA. -! SIMILAR EXAMPLES APPLY TO THE SKIP NUMBERS FOR Z2 AND L2. -! -! RETURNED VALUES OF 0 OR KM1 INDICATE THAT THE GIVEN SEARCH VALUE -! IS OUTSIDE THE RANGE OF THE SEQUENCE. -! -! IF A SEARCH VALUE IS IDENTICAL TO ONE OF THE SEQUENCE VALUES -! THEN THE LOCATION RETURNED POINTS TO THE IDENTICAL VALUE. -! IF THE SEQUENCE IS NOT STRICTLY MONOTONIC AND A SEARCH VALUE IS -! IDENTICAL TO MORE THAN ONE OF THE SEQUENCE VALUES, THEN THE -! LOCATION RETURNED MAY POINT TO ANY OF THE IDENTICAL VALUES. -! -! TO BE EXACT, FOR EACH I FROM 1 TO IM AND FOR EACH K FROM 1 TO KM2, -! Z=Z2(1+(I-1)*IXZ2+(K-1)*KXZ2) IS THE SEARCH VALUE AND -! L=L2(1+(I-1)*IXL2+(K-1)*KXL2) IS THE LOCATION RETURNED. -! IF L=0, THEN Z IS LESS THAN THE START POINT Z1(1+(I-1)*IXZ1) -! FOR ASCENDING SEQUENCES (OR GREATER THAN FOR DESCENDING SEQUENCES). -! IF L=KM1, THEN Z IS GREATER THAN OR EQUAL TO THE END POINT -! Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1) FOR ASCENDING SEQUENCES -! (OR LESS THAN OR EQUAL TO FOR DESCENDING SEQUENCES). -! OTHERWISE Z IS BETWEEN THE VALUES Z1(1+(I-1)*IXZ1+(L-1)*KXZ1) AND -! Z1(1+(I-1)*IXZ1+(L-0)*KXZ1) AND MAY EQUAL THE FORMER. -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ -! IMPLICIT NONE -! INTEGER,INTENT(IN):: IM,KM1,IXZ1,KXZ1,KM2,IXZ2,KXZ2,IXL2,KXL2 -! REAL,INTENT(IN):: Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) -! REAL,INTENT(IN):: Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) -! INTEGER,INTENT(OUT):: L2(1+(IM-1)*IXL2+(KM2-1)*KXL2) -! INTEGER(4) INCX,N,INCY,M,INDX(KM2),RC(KM2),IOPT -! INTEGER I,K2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. -! DO I=1,IM -! IF(Z1(1+(I-1)*IXZ1).LE.Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1)) THEN -! INPUT COORDINATE IS MONOTONICALLY ASCENDING. -! INCX=KXZ2 -! N=KM2 -! INCY=KXZ1 -! M=KM1 -! IOPT=1 -! IF(DIGITS(1.).LT.DIGITS(1._8)) THEN -! CALL SBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ELSE -! CALL DBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ENDIF -! DO K2=1,KM2 -! L2(1+(I-1)*IXL2+(K2-1)*KXL2)=INDX(K2)-RC(K2) -! ENDDO -! ELSE -! INPUT COORDINATE IS MONOTONICALLY DESCENDING. -! INCX=KXZ2 -! N=KM2 -! INCY=-KXZ1 -! M=KM1 -! IOPT=0 -! IF(DIGITS(1.).LT.DIGITS(1._8)) THEN -! CALL SBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ELSE -! CALL DBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ENDIF -! DO K2=1,KM2 -! L2(1+(I-1)*IXL2+(K2-1)*KXL2)=KM1+1-INDX(K2) -! ENDDO -! ENDIF -! ENDDO -! - IMPLICIT NONE - INTEGER,INTENT(IN):: IM,KM1,IXZ1,KXZ1,KM2,IXZ2,KXZ2,IXL2,KXL2 - REAL,INTENT(IN):: Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) - REAL,INTENT(IN):: Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) - INTEGER,INTENT(OUT):: L2(1+(IM-1)*IXL2+(KM2-1)*KXL2) - INTEGER I,K2,L - REAL Z -!C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!C FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. - DO I=1,IM - IF(Z1(1+(I-1)*IXZ1).LE.Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1)) THEN -!C INPUT COORDINATE IS MONOTONICALLY ASCENDING. - DO K2=1,KM2 - Z=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - L=0 - DO - IF(Z.LT.Z1(1+(I-1)*IXZ1+L*KXZ1)) EXIT - L=L+1 - IF(L.EQ.KM1) EXIT - ENDDO - L2(1+(I-1)*IXL2+(K2-1)*KXL2)=L - ENDDO - ELSE -!C INPUT COORDINATE IS MONOTONICALLY DESCENDING. - DO K2=1,KM2 - Z=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - L=0 - DO - IF(Z.GT.Z1(1+(I-1)*IXZ1+L*KXZ1)) EXIT - L=L+1 - IF(L.EQ.KM1) EXIT - ENDDO - L2(1+(I-1)*IXL2+(K2-1)*KXL2)=L - ENDDO - ENDIF - ENDDO - - END SUBROUTINE RSEARCH - - SUBROUTINE VINTG(IM,KM1,KM2,NT,P1,U1,V1,T1,Q1,W1,P2, & - U2,V2,T2,Q2,W2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: VINTG VERTICALLY INTERPOLATE UPPER-AIR FIELDS -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -! -! ABSTRACT: VERTICALLY INTERPOLATE UPPER-AIR FIELDS. -! WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS ARE INTERPOLATED. -! THE INTERPOLATION IS CUBIC LAGRANGIAN IN LOG PRESSURE -! WITH A MONOTONIC CONSTRAINT IN THE CENTER OF THE DOMAIN. -! IN THE OUTER INTERVALS IT IS LINEAR IN LOG PRESSURE. -! OUTSIDE THE DOMAIN, FIELDS ARE GENERALLY HELD CONSTANT, -! EXCEPT FOR TEMPERATURE AND HUMIDITY BELOW THE INPUT DOMAIN, -! WHERE THE TEMPERATURE LAPSE RATE IS HELD FIXED AT -6.5 K/KM AND -! THE RELATIVE HUMIDITY IS HELD CONSTANT. -! -! PROGRAM HISTORY LOG: -! 91-10-31 MARK IREDELL -! -! USAGE: CALL VINTG(IM,KM1,KM2,NT,P1,U1,V1,T1,Q1,P2, -! & U2,V2,T2,Q2) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF POINTS TO COMPUTE -! KM1 INTEGER NUMBER OF INPUT LEVELS -! KM2 INTEGER NUMBER OF OUTPUT LEVELS -! NT INTEGER NUMBER OF TRACERS -! P1 REAL (IM,KM1) INPUT PRESSURES -! ORDERED FROM BOTTOM TO TOP OF ATMOSPHERE -! U1 REAL (IM,KM1) INPUT ZONAL WIND -! V1 REAL (IM,KM1) INPUT MERIDIONAL WIND -! T1 REAL (IM,KM1) INPUT TEMPERATURE (K) -! Q1 REAL (IM,KM1,NT) INPUT TRACERS (HUMIDITY FIRST) -! P2 REAL (IM,KM2) OUTPUT PRESSURES -! OUTPUT ARGUMENT LIST: -! U2 REAL (IM,KM2) OUTPUT ZONAL WIND -! V2 REAL (IM,KM2) OUTPUT MERIDIONAL WIND -! T2 REAL (IM,KM2) OUTPUT TEMPERATURE (K) -! Q2 REAL (IM,KM2,NT) OUTPUT TRACERS (HUMIDITY FIRST) -! -! SUBPROGRAMS CALLED: -! TERP3 CUBICALLY INTERPOLATE IN ONE DIMENSION -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IM, KM1, KM2, NT - - REAL, INTENT(IN) :: P1(IM,KM1),U1(IM,KM1),V1(IM,KM1) - REAL, INTENT(IN) :: T1(IM,KM1),Q1(IM,KM1,NT) - REAL, INTENT(IN) :: W1(IM,KM1),P2(IM,KM2) - REAL, INTENT(OUT) :: U2(IM,KM2),V2(IM,KM2) - REAL, INTENT(OUT) :: T2(IM,KM2),Q2(IM,KM2,NT) - REAL, INTENT(OUT) :: W2(IM,KM2) - - REAL, PARAMETER :: DLTDZ=-6.5E-3*287.05/9.80665 - REAL, PARAMETER :: DLPVDRT=-2.5E6/461.50 - - INTEGER :: I, K, N - - REAL :: DZ - REAL,ALLOCATABLE :: Z1(:,:),Z2(:,:) - REAL,ALLOCATABLE :: C1(:,:,:),C2(:,:,:),J2(:,:,:) - - ALLOCATE (Z1(IM+1,KM1),Z2(IM+1,KM2)) - ALLOCATE (C1(IM+1,KM1,4+NT),C2(IM+1,KM2,4+NT),J2(IM+1,KM2,4+NT)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE LOG PRESSURE INTERPOLATING COORDINATE -! AND COPY INPUT WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS -!$OMP PARALLEL DO PRIVATE(K,I) - DO K=1,KM1 - DO I=1,IM - Z1(I,K) = -LOG(P1(I,K)) - C1(I,K,1) = U1(I,K) - C1(I,K,2) = V1(I,K) - C1(I,K,3) = W1(I,K) - C1(I,K,4) = T1(I,K) - C1(I,K,5) = Q1(I,K,1) - ENDDO - ENDDO -!$OMP END PARALLEL DO - DO N=2,NT - DO K=1,KM1 - DO I=1,IM - C1(I,K,4+N) = Q1(I,K,N) - ENDDO - ENDDO - ENDDO -!$OMP PARALLEL DO PRIVATE(K,I) - DO K=1,KM2 - DO I=1,IM - Z2(I,K) = -LOG(P2(I,K)) - ENDDO - ENDDO -!$OMP END PARALLEL DO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! PERFORM LAGRANGIAN ONE-DIMENSIONAL INTERPOLATION -! THAT IS 4TH-ORDER IN INTERIOR, 2ND-ORDER IN OUTSIDE INTERVALS -! AND 1ST-ORDER FOR EXTRAPOLATION. - CALL TERP3(IM,1,1,1,1,4+NT,(IM+1)*KM1,(IM+1)*KM2, & - KM1,IM+1,IM+1,Z1,C1,KM2,IM+1,IM+1,Z2,C2,J2) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COPY OUTPUT WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS -! EXCEPT BELOW THE INPUT DOMAIN, LET TEMPERATURE INCREASE WITH A FIXED -! LAPSE RATE AND LET THE RELATIVE HUMIDITY REMAIN CONSTANT. - DO K=1,KM2 - DO I=1,IM - U2(I,K)=C2(I,K,1) - V2(I,K)=C2(I,K,2) - W2(I,K)=C2(I,K,3) - DZ=Z2(I,K)-Z1(I,1) - IF(DZ.GE.0) THEN - T2(I,K)=C2(I,K,4) - Q2(I,K,1)=C2(I,K,5) - ELSE - T2(I,K)=T1(I,1)*EXP(DLTDZ*DZ) - Q2(I,K,1)=Q1(I,1,1)*EXP(DLPVDRT*(1/T2(I,K)-1/T1(I,1))-DZ) - ENDIF - ENDDO - ENDDO - DO N=2,NT - DO K=1,KM2 - DO I=1,IM - Q2(I,K,N)=C2(I,K,4+N) - ENDDO - ENDDO - ENDDO - DEALLOCATE (Z1,Z2,C1,C2,J2) - END SUBROUTINE VINTG - end module utils diff --git a/sorc/fbwndgfs.fd/CMakeLists.txt b/sorc/fbwndgfs.fd/CMakeLists.txt deleted file mode 100644 index dcdf057cd2..0000000000 --- a/sorc/fbwndgfs.fd/CMakeLists.txt +++ /dev/null @@ -1,21 +0,0 @@ -list(APPEND fortran_src - fbwndgfs.f -) - -if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -r8 -i8 -convert big_endian -assume byterecl") -elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8 -fdefault-integer-8 -fconvert=big-endian") -endif() - -set(exe_name fbwndgfs.x) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - bacio::bacio_8 - ip::ip_8 - sp::sp_8 - w3emc::w3emc_8 - w3nco::w3nco_8) - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/fbwndgfs.fd/fbwndgfs.f b/sorc/fbwndgfs.fd/fbwndgfs.f deleted file mode 100755 index ce7505fd1b..0000000000 --- a/sorc/fbwndgfs.fd/fbwndgfs.f +++ /dev/null @@ -1,969 +0,0 @@ -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C . . . . -C MAIN PROGRAM: FBWNDGFS -C PRGMMR: VUONG ORG: NP11 DATE: 2005-08-03 -C -C ABSTRACT: THIS PROGRAM CREATES BULLETINS OF FORECAST WINDS AND -C TEMPS FOR UP TO 15 LEVELS FOR PACIFIC REGION. -C THE PRIMARY (RMP) IS RUN. THE PROGRAM SETUPS TO RUN 4 TIMES PER -C DAY (T00Z, T06Z, T12Z AND T18Z). -C EACH BULLETIN OF A SET REPRESENTS A 6, 12 OR 24 HR FCST. -C THE PROGRAM GENERATED ARE THE FOLLOWING BULLETINS; -C FBOC31, FBOC33, FBOC35, FBOC37, FBOC38, FBOC39 -C THE STATION FILE (FBWNDGFS.STNLIST) IS KEYED TO INDICATE WHICH BULLETIN -C EACH STATION BELONGS IN. THE WIND SPEED (TEN OF DEGREES), WIND DIRECTION -C (KNOTS) & TEMPERATURE(CELSIUS) IN THE FORM (DDff+TT) FOR EACH STATION -C AND LEVELS APPEAR IN THE BULLETIN. WHERE DD IS THE WIND DIRECTION, -C ff IS THE WIND SPEED, AND TT IS THE TEMPERATURE -C THE FORECAST INPUT DATA IS GFS GLOBAL LAT/LON GRID 128 (0.313 DEGREE) -C FORECAST FILES U,V,& T FIELDS, 15 LEVELS: 1000', 1500', 2000', 3000', -C 6000', 9000', 12000', 15000' + 500, 400, 300, 250, 200, 150 AND 100MB -C -C THE INPUT STATION RECORD FOR EACH STATION CONTAINS STN ELEVATION -C AND LATITUDE/LONGITUDE POSITION. -C -C PROGRAM HISTORY LOG: -C 1986-01-03 CAVANAUGH -C 2004-06-29 VUONG MODIFIED THE PROGRAM TO WORK WITH GFS DATA AND -C RUN 4 TIMES PER DAY (T00Z,T06Z,T12Z AND T18Z). -C 2005-08-03 VUONG CHANGED THE FOR USE TIMES SPECIFIED ON WIND AND -C TEMPERATURE ALOFT 6 AND 12 HOUR FORECAST BULLETINS -C 2007-07-03 VUONG CHANGED NO. OF POINTS FOR GFS GLOBAL GAUSSIAN -C LAT/LON GRID 128 -C 2010-05-26 VUONG CHANGED NO. OF POINTS FOR GFS (T574) GAUSSIAN -C LAT/LON GRID -C 2012-08-16 VUONG MODIFIED VARIABLES NNPOS AND CHANGED -C VARIABLE ENVVAR TO CHARACTER*6 -C 2016-05-16 VUONG MODIFIED CODE TO USE MODULE GDSWZD_MOD IN IP.v3.0.0 -C -C USAGE: -C INPUT FILES: -C FORT.05 FBWNDGFS.STNLIST STATION DIRECTORY -C -C - GFS (T574) GLOBAL GAUSSIAN LAT/LON GRID (0.205 DEGREE) -C DIMENSIONS 1760 x 880 = 1548800 -C FORT.11 /COM/GFS/PROD/GFS.${PDY}/GFS.${CYCLE}.MASTER.GRBF06 -C FORT.12 /COM/GFS/PROD/GFS.${PDY}/GFS.${CYCLE}.MASTER.GRBF12 -C FORT.13 /COM/GFS/PROD/GFS.${PDY}/GFS.${CYCLE}.MASTER.GRBF24 -C - GFS INDEX FILES FOR GRIB GRID 128: -C FORT.31 /COM/GFS/PROD/GFS.${PDY}/GFS.${CYCLE}.MASTER.GRBIF06 -C FORT.32 /COM/GFS/PROD/GFS.${PDY}/GFS.${CYCLE}.MASTER.GRBIF12 -C FORT.33 /COM/GFS/PROD/GFS.${PDY}/GFS.${CYCLE}.MASTER.GRBIF24 -C -C WHERE PDY = YYYYMMDD, YYYY IS THE YEAR, MM IS THE MONTH, -C DD IS THE DAY OF THE MONTH -C AND -C CYCLE = T00Z, T06Z, T12Z, T18Z -C -C OUTPUT FILES: -C FORT.06 ERROR MESSAGES -C FORT.51 BULLETIN RECORDS FOR TRANSMISSION -C -C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES) -C LIBRARY: -C W3AI15 WXAI19 W3FC05 W3FI01 -C GETGB (FOR GRIB FILES) -C W3FT01 W3TAGE XMOVEX XSTORE W3UTCDAT -C -C EXIT STATES: -C COND = 110 STN DIRECTORY READ ERR (CONSOLE MSG) -C 1050 NO DATA (FIELD ID IS PRINTED)(FT06 + CONSOLE) -C 1060 NO DATA (FIELD ID IS PRINTED)(FT06 + CONSOLE) -C 1070 NO DATA (FIELD ID IS PRINTED)(FT06 + CONSOLE) -C 1080 NO DATA (FIELD ID IS PRINTED)(FT06 + CONSOLE) -C 1090 NO DATA (FIELD ID IS PRINTED)(FT06 + CONSOLE) -C ALL ARE FATAL -C PLUS W3LIB SUB-RTN RETURN CODES -C -C ATTRIBUTES: -C LANGUAGE: F90 FORTRAN -C MACHINE: IBM WCOSS -C -C$$$ -C - use gdswzd_mod - PARAMETER (NPTS=1548800) - PARAMETER (MAXSTN=800) - PARAMETER (IMAX=1760,JMAX=880) -C - REAL ALAT(MAXSTN),ALON(MAXSTN) - REAL ISTN(MAXSTN),JSTN(MAXSTN) - REAL ERAS(3),FHOUR,FILL - REAL RFLD(NPTS),RINTRP(IMAX,JMAX) - REAL XPTS(NPTS),YPTS(NPTS),RLON(NPTS),RLAT(NPTS) -C -C...MAX NR STNS FOR READ-END SHOULD BE GT ACTUAL NR OF STNS ON STN FILE - INTEGER IELEV(MAXSTN),IRAS(3),KTAU(3) - INTEGER JTIME(8),NDATE(8),MDATE(8) - INTEGER JGDS(100),KGDS(200),JREW,KBYTES - INTEGER KPDS(27),MPDS(27),KREW - INTEGER KSTNU(MAXSTN,15) - INTEGER LMTLWR(2),LMTUPR(2),NTTT -C...NPOS(ITIVE) IS TRANSMISSION SIGN 7C MASK FOR TEMP - INTEGER ICKYR,ICKMO,ICKDAY,ICKHR - INTEGER KSTNV(MAXSTN,15),KSTNT(MAXSTN,15) - INTEGER IDWD1H(3),IDWD2H(3) - INTEGER IDWD1P(3),IDWD2P(3) - INTEGER IDWD2(15),NHGTP(15) -C -C...S,L,T,B ARE SUBSCRIPTS FOR SEQ NR OF STATION, LEVEL, TAU, BULLETIN -C... B IS COUNT OF BULTNS WITHIN TAU, BB IS COUNT WITHIN RUN -C - INTEGER S,L,T,B, BB -C - CHARACTER*6 NHGT6(15), AWIPSID(6) - CHARACTER*1 BSTART,BEND - CHARACTER*1 BULTN(1280) - CHARACTER*1 SPACE(1280) - CHARACTER*1 ETBETX,ETB,ETX,ICK,ICKX - CHARACTER*1 INDIC(MAXSTN),LF,MINUS - CHARACTER*1 MUSES(MAXSTN) - CHARACTER*1 SPC80(80),TSRCE,TMODE,TFLAG - CHARACTER*3 CRCRLF - CHARACTER*4 ITRTIM,STNID(MAXSTN),IVALDA - CHARACTER*1 NNPOS - CHARACTER*4 NFDHDG(6),NCATNR(6),NVALTM(12) - CHARACTER*9 NUSETM(12) -C - CHARACTER*8 IBLANK,IBSDA,IBSTI,ITRDA - CHARACTER*8 ITEMP(MAXSTN,15),IWIND(MAXSTN,15) - CHARACTER*8 NFILE,NTTT4,RF06,RF12,RF24 - CHARACTER*6 ENVVAR - CHARACTER*80 FILEB,FILEI,SPCS,FILEO -C - CHARACTER*86 LINE73 - CHARACTER*40 LN73A,NBUL1 - CHARACTER*46 LN73B - CHARACTER*84 NBULHD - CHARACTER*34 NBUL2 - CHARACTER*32 NBASHD - CHARACTER*60 NVALHD -C - LOGICAL ENDBUL,KBMS(NPTS) -C - EQUIVALENCE (ICK,ICKX) - EQUIVALENCE (RFLD(1),RINTRP(1,1)) - EQUIVALENCE (NBULHD(1:1),NBUL1(1:1)) - EQUIVALENCE (NBULHD(41:41),NBUL2(1:1)) - EQUIVALENCE (LINE73(1:1),LN73A(1:1)) - EQUIVALENCE (LINE73(41:41),LN73B(1:1)) - EQUIVALENCE (SPCS,SPC80) - EQUIVALENCE (NTTT,NTTT4(1:1)) -C - DATA INDEX /1/ - DATA NCYCLK/ 0 / - DATA LIN / 0 / - DATA FHOUR /24.0/ - DATA KTAU /06,12,24/ - DATA LMTLWR/1,11/ - DATA LMTUPR/10,15/ - DATA IDWD1H/ 33, 34, 11/ - DATA IDWD2H/ 103, 103, 103/ - - DATA IDWD1P/ 33, 34, 11/ - DATA IDWD2P/ 100, 100, 100/ - - DATA IDWD2 / 305, 457, 610, 914, - 1 1829, 2743, 3658, 4572, - 2 500, 400, 300, 250, - 3 200, 150, 100/ - - DATA NHGT6 /'1000 ','1500 ','2000 ','3000 ', - 1 '6000 ','9000 ','12000 ','15000 ', - 2 '18000 ','24000 ','30000 ','34000 ', - 3 '39000 ','45000 ','53000'/ - DATA NHGTP /5,5,6,6,6,6,6,6,6,6,5,5,5,5,5/ - DATA BSTART/'B'/ - DATA BEND /'E'/ - DATA ETB /'>'/ - DATA ETX /'%'/ - DATA MINUS /'-'/ - DATA SPC80 /80*' '/ - DATA CRCRLF/'<<@'/ - DATA IBLANK/' '/ - DATA AWIPSID / 'FD1OC1','FD8OC7','FD3OC3', - 1 'FD9OC8','FD5OC5','FD0OC9'/ - DATA NFDHDG/ - 1 'OC31','OC37','OC33','OC38','OC35','OC39'/ - DATA NCATNR/ - 1 '1377','5980','1378','5981','1379','5982'/ - DATA NVALTM/ - 1 '0600','1200','0000','1200','1800','0600', - 2 '1800','0000','1200','0000','0600','1800'/ - DATA NUSETM/ - 1 '0200-0900','0900-1800','1800-0600', - 2 '0800-1500','1500-0000','0000-1200', - 3 '1400-2100','2100-0600','0600-1800', - 4 '2000-0300','0300-1200','1200-0000'/ -C - DATA RF06 /'6 HOURS '/ - DATA RF12 /'12 HOURS'/ - DATA RF24 /'24 HOURS'/ - DATA LN73A /' '/ - DATA LN73B /' <<@^^^'/ - DATA NBUL1 / - 1 '''10 PFB '/ - DATA NBUL2/ - 1 'FB KWNO <<@^^^ <<@$'/ - DATA NBASHD/'DATA BASED ON Z <<@@^^^'/ - DATA NVALHD/ - 1 'VALID Z FOR USE - Z. TEMPS NEG ABV 24000<<@@^'/ -C -C - NNPOS = CHAR(124) - LUGO = 51 - CALL W3TAGB('FBWNDGFS',2012,0184,0184,'NP11') - ENVVAR='FORT ' - WRITE(ENVVAR(5:6),FMT='(I2)') LUGO - CALL GETENV(ENVVAR,FILEO) -C - OPEN(LUGO,FILE=FILEO,ACCESS='DIRECT',RECL=1281) - IREC=1 -C...GET COMPUTER DATE-TIME & SAVE FOR DATA DATE VERIFICATION - CALL W3UTCDAT(JTIME) -C -C...READ AND STORE STATION LIST FROM UNIT 5 -C...INDIC = INDICATOR BEGIN, OR END, BULTN ('B' OR 'E') -C...MUSES = USED IN MULTIPLE BULTNS (FOR SAME TAU) IF '+' -C - DO 25 I = 1, MAXSTN - READ(5,10,ERR=109,END=130) INDIC(I),MUSES(I),STNID(I), - & IELEV(I),ALAT(I),ALON(I) - 25 CONTINUE -C -C/////////////////////////////////////////////////////////////////// - 10 FORMAT(A1,A1,A4,1X,I5,1X,F6.2,1X,F7.2) -C -C...ERROR - 109 CONTINUE - CALL W3TAGE('FBWNDGFS') - PRINT *,'STATION LIST READ ERROR' - CALL ERREXIT (110) -C//////////////////////////////////////////////////////////////////// -C - 130 CONTINUE -C -C CONVERT THE LAT/LONG COORDINATES OF STATION TO LAMBERT -C CONFORMAL PROJECTION I,J COORDINATES FOR GRID 221 -C - NRSTNS = I-1 - WRITE(6,'(A19,1X,I0)') ' NO. OF STATIONS = ',NRSTNS -C -C...END READ. COUNT OF STATIONS STORED -C -C...GET EXEC PARMS -C...PARM FIELD TAKEN OUT, NEXT 4 VALUES HARD WIRED - TMODE = 'M' - TSRCE = 'R' - TFLAG = 'P' - PRINT *,'SOURCE=',TSRCE,' MODE=',TMODE,' FLAG=',TFLAG -C -C********************************************************************** -C -C...READ PACKED DATA, UNPACK, INTERPOLATE, STORE IN STATION ARRAYS, -C... CREATE BULTN HDGS, INSERT STATION IN BULTNS, & WRITE BULTNS. -C - BB = 0 -C -C...BEGIN TAU -C - DO 7000 ITAU=1, 3 -C - WRITE(6,'(A6,1X,I0)') ' ITAU=',ITAU - T = ITAU -C -C SELECT FILE FOR TAU PERIOD (PRIMARY RUN) -C - IF (KTAU(ITAU).EQ.6) THEN - NFILE = RF06 - LUGB = 11 - LUGI = 31 - ELSE IF (KTAU(ITAU).EQ.12) THEN - NFILE = RF12 - LUGB = 12 - LUGI = 32 - ELSE - NFILE = RF24 - LUGB = 13 - LUGI = 33 - ENDIF -C - WRITE(ENVVAR(5:6),FMT='(I2)') LUGB - CALL GETENV(ENVVAR,FILEB) - CALL BAOPENR(LUGB,FILEB,IRET) - WRITE(ENVVAR(5:6),FMT='(I2)') LUGI - CALL GETENV(ENVVAR,FILEI) - CALL BAOPENR(LUGI,FILEI,IRET) - PRINT 1025,NFILE, FILEB, FILEI - 1025 FORMAT('NFILE= ',A8,2X,'GRIB FILE= ',A55,'INDEX FILE= ',A55) -C -C.................................. - DO 2450 ITYP=1,3 -C -C... SEE O.N. 388 FOR FILE ID COMPOSITION -C - DO 2400 L=1,15 -C -C...USE SOME OF THE VALUES IN THE PDS TO GET RECORD -C -C MPDS = -1 SETS ARRAY MPDS TO -1 -C MPDS(3) = GRID IDENTIFICATION (PDS BYTE 7) -C MPDS(5) = INDICATOR OF PARAMETER (PDS BYTE 9) -C MPDS(6) = INDICATOR OF TYPE OF LEVEL OR LAYER (PDS BYTE 10) -C MPDS(7) = HGT,PRES,ETC. OF LEVEL OR LAYER (PDS BYTE 11,12) -C MPDS(14) = P1 - PERIOD OF TIME (PDS BYTE 19) -C VALUES NOT SET TO -1 ARE USED TO FIND RECORD -C - JREW = 0 - KREW = 0 - MPDS = -1 -C -C MPDS(3) = -1 - IF (L.LE.8) THEN - MPDS(5) = IDWD1H(ITYP) -C... HEIGHT ABOVE MEAN SEA LEVEL GPML - MPDS(6) = IDWD2H(ITYP) - ELSE - MPDS(5) = IDWD1P(ITYP) -C... PRESSURE IN HectoPascals (hPa) ISBL - MPDS(6) = IDWD2P(ITYP) - ENDIF - MPDS(7) = IDWD2(L) - MPDS(14) = KTAU(ITAU) -C -C... THE FILE ID COMPLETED. -C PRINT *,MPDS -C... GET THE DATA FIELD. -C - CALL GETGB(LUGB,LUGI,NPTS,JREW,MPDS,JGDS, - & KBYTES,KREW,KPDS,KGDS,KBMS,RFLD,IRET) -C WRITE(*,119) KPDS -119 FORMAT( 1X, 'MAIN: KPDS:', 3(/1X,10(I5,2X) ) ) - -C -C/////////////////////////////////////////////////////////////////////// -C...ERROR - IF (IRET.NE.0) THEN - write(*,120) (MPDS(I),I=3,14) -120 format(1x,' MPDS = ',12(I0,1x)) - WRITE(6,'(A9,1X,I0)') ' IRET = ',IRET - IF (IRET.EQ.96) THEN - PRINT *,'ERROR READING INDEX FILE' - CALL W3TAGE('FBWNDGFS') - CALL ERREXIT (1050) - ELSE IF (IRET.EQ.97) THEN - PRINT *,'ERROR READING GRIB FILE' - CALL W3TAGE('FBWNDGFS') - CALL ERREXIT (1060) - ELSE IF (IRET.EQ.98) THEN - PRINT *,'NUMBER OF DATA POINT GREATER', - * ' THAN NPTS' - CALL W3TAGE('FBWNDGFS') - CALL ERREXIT (1070) - ELSE IF (IRET.EQ.99) THEN - PRINT *,'RECORD REQUESTED NOT FOUND' - CALL W3TAGE('FBWNDGFS') - CALL ERREXIT (1080) - ELSE - PRINT *,'GETGB-W3FI63 GRIB UNPACKER', - * ' RETURN CODE' - CALL W3TAGE('FBWNDGFS') - CALL ERREXIT (1090) - END IF - ENDIF -C -C...GET DATE-TIME FOR LATER BULTN HDG PROCESSING -C - ICKYR = KPDS(8) + 2000 - ICKMO = KPDS(9) - ICKDAY= KPDS(10) - ICKHR = KPDS(11) * 100 - IF (ICKHR.EQ.0000) ICYC=1 - IF (ICKHR.EQ.0600) ICYC=2 - IF (ICKHR.EQ.1200) ICYC=3 - IF (ICKHR.EQ.1800) ICYC=4 - IBSTIM=ICKHR -C -C...GET NEXT DAY - FOR VALID DAY AND 12Z AND 18Z BACKUP TRAN DAY -C...UPDATE TO NEXT DAY - NHOUR=ICKHR*.01 - CALL W3MOVDAT((/0.,FHOUR,0.,0.,0./), - & (/ICKYR,ICKMO,ICKDAY,0,NHOUR,0,0,0/),NDATE) - CALL W3MOVDAT((/0.,FHOUR,0.,0.,0./),NDATE,MDATE) -C -C...12Z, 18Z CYCLE,BACKUP RUN,24HR FCST: VALID DAY IS DAY-AFTER-NEXT -C...NEXT DAY-OF-MONTH NOW STORED IN 'NDATE(3)' -C...NEXT DAY PLUS 1 IN 'MDATE(3)' -C -C CONVERT EARTH COORDINATES OF STATION TO GRID COORDINATES - DO 110 J = 1,NRSTNS -C CALL GDSWIZ(KGDS,-1,1,FILL,XPTS(J),YPTS(J), -C & ALON(J),ALAT(J),IRET,0,DUM,DUM) - CALL GDSWZD(KGDS,-1,1,FILL,XPTS(J),YPTS(J), - & ALON(J),ALAT(J),IRET) - ISTN(J) = XPTS(J) - JSTN(J) = YPTS(J) -C PRINT 111,STNID(J),ALAT(J),ALON(J),ISTN(J),JSTN(J) - 111 FORMAT (3X,A3,2(2X,F8.2),2(2X,F8.3)) - 110 CONTINUE -C -C...CONVERT DATA TO CONVENTIONAL UNITS: -C... WIND FROM METERS/SEC TO KNOTS (2 DIGITS), -C WIND DIRECTION IN TENS OF DEGREES (2 DIGITS), -C AND TEMP FROM K TO CELSIUS (2 DIGITS) -C - DO 1500 I=1,NPTS -C - IF (ITYP.EQ.3) THEN - RFLD(I)=RFLD(I)-273.15 - ELSE - RFLD(I)=RFLD(I)*1.94254 - ENDIF -C - 1500 CONTINUE -C - DO 2300 S=1,NRSTNS -C -C INTERPOLATE GRIDPOINT DATA TO STATION. -C - CALL W3FT01(ISTN(S),JSTN(S),RINTRP,X,IMAX,JMAX,NCYCLK,LIN) -C WRITE(6,830) STNID(S),ISTN(S),JSTN(S),X -830 FORMAT(1X,'STN-ID = ', A4,3X,'SI,SJ = ', 2(F5.1,2X), 1X, - A 'X = ', F10.0) -C -C...INTERPOLATION COMPLETE FOR THIS STATION -C -C...CONVERT WIND, U AND V TO INTEGER -C - IF (ITYP.EQ.1) THEN - KSTNU(S,L)=X*100.0 - ELSE IF (ITYP.EQ.2) THEN - KSTNV(S,L)=X*100.0 -C...CONVERT TEMP TO I*2 - ELSE IF (ITYP.EQ.3) THEN - KSTNT(S,L)=X*100.0 - ENDIF -C - 2300 CONTINUE -C...END OF STATION LOOP -C................................... -C - 2400 CONTINUE -C...END OF LEVEL LOOP -C................................... -C - 2450 CONTINUE -C...END OF DATA TYPE LOOP -C................................... -C -C...INTERPOLATED DATA FOR ALL STATIONS,1 TAU, NOW ARRAYED IN KSTNU-V-T. -C*********************************************************************** -C -C...CONVERT WIND COMPONENTS TO DIRECTION AND SPEED -C -C................................. -C...BEGIN STATION -C - DO 3900 S=1,NRSTNS -C................................. - DO 3750 L=1,15 -C -C...PUT U & V WIND COMPONENTS IN I*4 WORK AREA - IRAS(1)=KSTNU(S,L) - IRAS(2)=KSTNV(S,L) -C...FLOAT U & V - ERAS(1)=FLOAT(IRAS(1))*.01 - ERAS(2)=FLOAT(IRAS(2))*.01 -C -C...CONVERT TO WIND DIRECTION & SPEED -C - CALL W3FC05(ERAS(1),ERAS(2),DD,SS) -C -C...WITH DIR & SPEED IN WORK AREA, PLACE TEMPERATURE -TT- IN WORK - IRAS(3)=KSTNT(S,L) - TT=FLOAT(IRAS(3))*.01 -C -C...DIRECTION, SPEED & TEMP ALL REQUIRE ADDITIONAL TREATMENT TO -C MEET REQUIREMENTS OF BULLETIN FORMAT -C - NDDD=(DD+5.0)/10.0 -C...WIND DIRECTION ROUNDED TO NEAREST 10 DEGREEES -C -C...THERE IS A POSSIBILITY WIND DIRECTION NOT IN RANGE 1-36 - - IF ((NDDD.GT.36).OR.(NDDD.LE.0)) THEN - NDDD = MOD(NDDD, 36) - IF (NDDD.LE.0) NDDD = NDDD + 36 - ENDIF - NSSS=SS+0.5 -C -C...WIND SPEED ROUNDED TO NEAREST KNOT -C...FOR SPEED, KEEP UNITS AND TENS ONLY, WIND SPEEDS OF 100 -C THROUGH 199 KNOTS ARE INDICATED BY SUBTRACTING 100 FROM -C THE SPEED AND ADDING 50 TO DIRECTION. -C -C...WIND SPEEDS GREATER THAN 199 KNOTS ARE INDICATED AS A -C FORECAST SPEED OF 199 KNOTS AND ADDING 50 TO DIRECTION. -C - IF (NSSS.GT.199) THEN - NSSS=99 - NDDD=NDDD+50 -C...SPEED GT 99 AND LE 199 KNOTS - ELSE IF (NSSS.GT.99) THEN - NSSS=NSSS-100 - NDDD=NDDD+50 -C -C...SPEED LT 5 KNOTS (CONSIDERED CALM) AND EXPRESSED BY "9900" - ELSE IF (NSSS.LT.5) THEN - NSSS=0 - NDDD=99 - ENDIF -C -C...COMBINE DIR & SPEED IN ONE WORD I*4 - NDDSS=(NDDD*100)+NSSS -C -C...STORE IN ASCII IN LEVEL ARRAY, WIND FOR ONE STATION - CALL W3AI15(NDDSS,IWIND(S,L),1,4,MINUS) -C -C...TEMP NEXT. IF POSITIVE ROUND TO NEAREST DEGREE, CONV TO ASCII - NTTT = TT - IF (TT.LE.-0.5) NTTT = TT - 0.5 - IF (TT.GE.0.5) NTTT = TT + 0.5 - CALL W3AI15(NTTT,NTTT,1,3,MINUS) - IF (TT.GT.-0.5) NTTT4(1:1) = NNPOS(1:1) - -C...SIGN & 2 DIGITS OF TEMP NOW IN ASCII IN LEFT 3 BYTES OF NTTT -C - ITEMP(S,L)(1:3) = NTTT4(1:3) -C - 3750 CONTINUE -C...END LEVEL (WIND CONVERSION) -C................................. -C -C...AT END OF LVL LOOP FOR ONE STATION, ALL WIND & TEMP DATA IS ARRAYED, -C... IN ASCII, IN IWIND (4 CHARACTER DIR & SPEED) AND ITEMP (3 CHAR -C... INCL SIGN FOR 1ST 10 LVLS, 2 CHAR WITH NO SIGN FOR 5 UPPER LVLS) -C ABOVE 24,000 FEET, THE SIGN IS OMITTED SINCE TEMPERATURES ARE NEGATIVE. -C -C...BEFORE INSERTING INTO BULTN, TEMPS FOR LVLS OTHER THAN 3000' -C... WHICH ARE LESS THAN 2500' ABOVE STATION MUST BE ELIMINATED. -C... (TEMPS FOR 3000' ARE NOT TRANSMITTED) -C...WINDS ARE BLANKED FOR LVLS LESS THAN 1500' ABOVE STATION. -C - IF (IELEV(S).GT.9500) ITEMP(S,7) = IBLANK - IF (IELEV(S).GT.6500) ITEMP(S,6) = IBLANK - IF (IELEV(S).GT.3500) ITEMP(S,5) = IBLANK - ITEMP(S,4)=IBLANK - ITEMP(S,3)=IBLANK - ITEMP(S,2)=IBLANK - ITEMP(S,1)=IBLANK -C - IF (IELEV(S).GT.10500) IWIND(S,7) = IBLANK - IF (IELEV(S).GT.7500) IWIND(S,6) = IBLANK - IF (IELEV(S).GT.4500) IWIND(S,5) = IBLANK - IF (IELEV(S).GT.1500) IWIND(S,4) = IBLANK - -C...DATA FOR 1 STATION, 15 LVLS, 1 TAU NOW READY FOR BULTN LINE -C - 3900 CONTINUE -C...END STATION (WIND CONVERSION) -C -C...DATA FOR ALL STATIONS, ONE TAU, NOW READY FOR BULTN INSERTION -C********************************************************************** -C********************************************************************* -C -C...BULLETIN CREATION -C...REACH THIS POINT ONCE PER TAU -C...B IS BULTN CNT FOR TAU, BB CUMULATIVE BULTN CNT FOR RUN, -C... S IS SEQ NR OF STN. -C... (NOT NEEDED FOR U.S. WHICH IS SET AT #1.) - B = 0 - S = 0 - ENDBUL = .FALSE. -C - DO 6900 J = 1,2 -C....................................................................... -C -C...UPDATE STATION COUNTER -C - 4150 S = S + 1 -C - ICKX=INDIC(S) - IF (ICK(1:1).EQ.BSTART(1:1)) THEN - -C...GO TO START, OR CONTINUE, BULTN -C -C...BEGIN BULLETIN -C -C - B = B + 1 - BB = BB + 1 -C*********************************************************************** -C -C...PROCESS DATE-TIME FOR HEADINGS -C - IF (BB.EQ.1) THEN -C............................... -C...ONE TIME ENTRIES -C -C...TRAN HDGS - ITRDAY=JTIME(3) - IBSDAY=ICKDAY - WRITE(ITRTIM(1:4),'(2(I2.2))') JTIME(5), JTIME(6) -C - IF (TMODE.EQ.'T') THEN -C...BACKUP - IF (ICYC.EQ.3.OR.ICYC.EQ.4) THEN -C...TRAN DAY WILL BE NEXT DAY FOR 12Z, 18Z CYCLE BACKUP - ITRDAY=NDATE(3) - IF (ICYC.EQ.4.AND.T.EQ.3) IVLDAY=MDATE(3) - ENDIF - ENDIF -C...END TRAN BACKUP DAY-HOUR -C -C...PLACE TRAN & BASE DAY-HOUR IN HDGS - CALL W3AI15(ITRDAY,ITRDA,1,2,MINUS) - CALL W3AI15(IBSDAY,IBSDA,1,2,MINUS) - CALL W3AI15(IBSTIM,IBSTI,1,4,MINUS) -C - NBUL2(13:14) = ITRDA(1:2) - NBUL2(15:18) = ITRTIM(1:4) -C - NBASHD(15:16) = IBSDA(1:2) - NBASHD(17:20) = IBSTI(1:4) - ENDIF - -C **************************************************************** -C **************************************************************** -C IF REQUIRED TO INDICATE THE SOURCE FOR THESE FD BULLETINS -C REMOVE THE COMMENT STATUS FROM THE NEXT TWO LINES -C **************************************************************** -C **************************************************************** -C -C...END ONE-TIME ENTRIES -C............................ -C -C...BLANK OUT CONTROL DATE AFTER 1ST BULTN - IF (BB.EQ.2) NBULHD(13:20) = SPCS(1:8) -C -C...CATALOG NUMBER (AND 'P' OR 'B' FOR PRIMARY OR BACKUP RUN) - NBULHD(8:8) = TFLAG - NBULHD(4:7) = NCATNR(BB)(1:4) - NBULHD(43:46) = NFDHDG(BB)(1:4) -C -C INSERT AWIPS ID INTO BULLETIN HEADER -C - NBUL2(25:30) = AWIPSID(BB)(1:6) - - -C...END CATALOG NR -C -C...END TRAN HDGS -C..................................................................... -C -C...VALID-USE HDGS - IF (TMODE.EQ.'T') THEN - -C...BACKUP DAY-HOURS WILL BE SAME AS PRIMARY RUN OF OPPOSITE CYCLE - IVLDAY=NDATE(3) - IF (ICYC.EQ.1.AND.T.EQ.1) IVLDAY=IBSDAY - IF (ICYC.EQ.4.AND.T.EQ.3) IVLDAY=MDATE(3) -C -C...SET POINTER OPPOSITE (USE WITH T -RELATIVE TAU- TO SET HOURS) - IF (ICYC.EQ.1) KCYC=2 - IF (ICYC.EQ.3) KCYC=1 - ELSE - IVLDAY=IBSDAY - IF (T.EQ.3) IVLDAY=NDATE(3) - IF (ICYC.EQ.3.AND.T.EQ.2) IVLDAY=NDATE(3) - IF (ICYC.EQ.4) IVLDAY=NDATE(3) - ENDIF - -C...END BACKUP DAY-HOUR. -C -C...CONVERT TO ASCII AND PLACE IN HDGS - CALL W3AI15(IVLDAY,IVALDA,1,2,MINUS) - NVALHD(7:8) = IVALDA(1:2) - IITAU = ITAU - IF (ICYC.EQ.2) IITAU = ITAU + 3 - IF (ICYC.EQ.3) IITAU = ITAU + 6 - IF (ICYC.EQ.4) IITAU = ITAU + 9 - NVALHD(9:12) = NVALTM(IITAU)(1:4) - NVALHD(25:33) = NUSETM(IITAU)(1:9) -C -C...END VALID-USE HDGS -C -C...MOVE WORK HDGS TO BULTN O/P (TRAN, BASE, VALID, HEIGHT HDGS) - NEXT=0 - CALL WXAI19(NBULHD,74,BULTN,1280,NEXT) -C PRINT *,(NBULHD(L:L),L=41,70) - CALL WXAI19(NBASHD,28,BULTN,1280,NEXT) -C PRINT *,(NBASHD(L:L),L=1,25) - CALL WXAI19(NVALHD,60,BULTN,1280,NEXT) -C PRINT *, (NVALHD(L:L),L=1,55) - LINE73(1:73) = SPCS(1:73) - LINE73(1:2) = 'FT' - NPOS1 = 5 - DO 4500 N = LMTLWR(J), LMTUPR(J) - IF (N.LE.3) THEN - NPOS1 = NPOS1 - ELSE IF (N.EQ.4) THEN - NPOS1 = NPOS1 - 1 - ELSE IF ((N.GE.5).AND.(N.LE.6)) THEN - NPOS1 = NPOS1 + 2 - ELSE IF ((N.EQ.7).OR.(N.EQ.11)) THEN - NPOS1 = NPOS1 + 1 - ELSE IF (N.GT.7) THEN - NPOS1 = NPOS1 + 2 - ENDIF - NPOS2 = NPOS1 + 4 - LINE73(NPOS1:NPOS2) = NHGT6(N)(1:5) - NPOS1 = NPOS1 + NHGTP(N) - 4500 CONTINUE - -C PRINT *,(LINE73(II:II),II=1,NPOS2) - CALL WXAI19(LINE73,NPOS2,BULTN,1280,NEXT) - CALL WXAI19(CRCRLF,3,BULTN,1280,NEXT) - ENDIF -C -C...BULLETIN HDGS FOR ONE BULTN COMPLETE IN O/P AREA -C -C*********************************************************************** -C -C...CONTINUE BULTN, INSERTING DATA LINES. -C - NPOS1 = 5 - LINE73(1:73) = SPCS(1:73) - LINE73(1:1) = '$' - LINE73( 2: 5) = STNID(S)(1:4) - DO 5300 M = LMTLWR(J), LMTUPR(J) - NPOS1 = NPOS1 + 1 - NPOS2 = NPOS1 + 4 - LINE73(NPOS1:NPOS2) = IWIND(S,M)(1:4) - NPOS1 = NPOS1 + 4 - IF ((M.GT.4).AND.(M.LE.10))THEN - NPOS2 = NPOS1 + 2 - LINE73(NPOS1:NPOS2) = ITEMP(S,M)(1:3) - NPOS1 = NPOS1 + 3 - END IF - IF (M.GT.10) THEN - NPOS2 = NPOS1 + 1 - LINE73(NPOS1:NPOS2) = ITEMP(S,M)(2:3) - NPOS1 = NPOS1 + 2 - END IF - 5300 CONTINUE -C PRINT *,(LINE73(II:II),II=2,NPOS2) -C...NXTSAV HOLDS BYTE COUNT IN O/P BULTN FOR RESTORING WXAI19 'NEXT' -C... FIELD SO THAT WHEN 'NEXT' IS RETURNED AS -1, AN ADDITIONAL -C... LINEFEED AND/OR ETB OR ETX CAN BE INSERTED -C - IF (NEXT.GE.1207) THEN - CALL WXAI19 (ETB,1,BULTN,1280,NEXT) - LF = CHAR(10) - do ii=1,next - space(index) = bultn(ii) - if (index .eq. 1280) then - WRITE(51,REC=IREC) space, LF - IREC=IREC + 1 - index = 0 - do kk = 1,1280 - space(kk) = ' ' - enddo - endif - index = index + 1 - enddo -C WRITE(51) BULTN, LF - NEXT = 0 - ENDIF - CALL WXAI19(LINE73,NPOS2,BULTN,1280,NEXT) - CALL WXAI19(CRCRLF,3,BULTN,1280,NEXT) -C -C...AFTER LINE STORED IN O/P, GO TO CHECK BULTN END -C -C................................... -C -C...CHECK FOR LAST STN OF BULTN - IF (ICK(1:1).NE.BEND(1:1)) GO TO 4150 -C -C...END BULLETIN. SET UP RETURN FOR NEXT STN AFTER WRITE O/P. -C...SAVE SEQ NR OF LAST STN FOR SUBSEQUENT SEARCH FOR STNS -C - NXTSAV = NEXT - ENDBUL = .TRUE. -C*********************************************************************** -C -C...OUTPUT SECTION -C - NEXT = NXTSAV - ETBETX = ETB - IF (ENDBUL) ETBETX=ETX -C...END OF TRANSMIT BLOCK, OR END OF TRANSMISSION -C - CALL WXAI19(ETBETX,1,BULTN,1280,NEXT) -C -C...OUTPUT TO HOLD FILES - LF = CHAR(10) - do ii = 1,next - space(index) = bultn(ii) - if (index .eq. 1280) then - WRITE(51,REC=IREC) space, LF - IREC=IREC + 1 - index = 0 - do kk = 1,1280 - space(kk) = ' ' - enddo - endif - index = index + 1 - enddo -C -C...TRAN. -C -C NEXT=0 - ENDBUL=.FALSE. -C -C...RETURN TO START NEW BULTN, OR CONTINUE LINE FOR WHICH THERE WAS -C... INSUFFICIENT SPACE IN BLOCK JUST WRITTEN -C - 6900 CONTINUE -C -C*********************************************************************** - 7000 CONTINUE -C...END TAU LOOP -C -C...FT51 IS TRANSMISSION FILE -C END FILE 51 -C REWIND 51 - if (index .gt. 0) then - WRITE(51,REC=IREC) space, LF - IREC=IREC+1 - endif - KRET = 0 - - CALL W3TAGE('FBWNDGFS') - STOP - END - - SUBROUTINE WXAI19(LINE, L, NBLK, N, NEXT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: WXAI19 LINE BLOCKER SUBROUTINE -C AUTHOR: ALLARD, R. ORG: W342 DATE: 01 FEB 74 -C -C ABSTRACT: FILLS A RECORD BLOCK WITH LOGICAL RECORDS OR LINES -C OF INFORMATION. -C -C PROGRAM HISTORY LOG: -C 74-02-01 BOB ALLARD -C 90-09-15 R.E.JONES CONVERT FROM IBM370 ASSEMBLER TO MICROSOFT -C FORTRAN 5.0 -C 90-10-07 R.E.JONES CONVERT TO SUN FORTRAN 1.3 -C 91-07-20 R.E.JONES CONVERT TO SiliconGraphics 3.3 FORTRAN 77 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 94-04-22 R.E.JONES ADD XMOVEX AND XSTORE TO MOVE AND -C STORE CHARACTER DATA FASTER ON THE CRAY -C 96-07-18 R.E.JONES CHANGE EBCDIC FILL TO ASCII FILL -C 96-11-18 R.E.JONES CHANGE NAME W3AI19 TO WXAI19 -C -C USAGE: CALL WXAI19 (LINE, L, NBLK, N, NEXT) -C INPUT ARGUMENT LIST: -C LINE - ARRAY ADDRESS OF LOGICAL RECORD TO BE BLOCKED -C L - NUMBER OF CHARACTERS IN LINE TO BE BLOCKED -C N - MAXIMUM CHARACTER SIZE OF NBLK -C NEXT - FLAG, INITIALIZED TO 0 -C -C OUTPUT ARGUMENT LIST: -C NBLK - BLOCK FILLED WITH LOGICAL RECORDS -C NEXT - CHARACTER COUNT, ERROR INDICATOR -C -C EXIT STATES: -C NEXT = -1 LINE WILL NOT FIT INTO REMAINDER OF BLOCK; -C OTHERWISE, NEXT IS SET TO (NEXT + L) -C NEXT = -2 N IS ZERO OR LESS -C NEXT = -3 L IS ZERO OR LESS -C -C EXTERNAL REFERENCES: XMOVEX XSTORE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -C -C METHOD: -C -C THE USER MUST SET NEXT = 0 EACH TIME NBLK IS TO BE FILLED WITH -C LOGICAL RECORDS. -C -C WXAI19 WILL THEN MOVE THE LINE OF INFORMATION INTO NBLK, STORE -C BLANK CHARACTERS IN THE REMAINDER OF THE BLOCK, AND SET NEXT = NEXT -C + L. -C -C EACH TIME WXAI19 IS ENTERED, ONE LINE IS BLOCKED AND NEXT INCRE- -C MENTED UNTIL A LINE WILL NOT FIT THE REMAINDER OF THE BLOCK. THEN -C WXAI19 WILL SET NEXT = -1 AS A FLAG FOR THE USER TO DISPOSE OF THE -C BLOCK. THE USER SHOULD BE AWARE THAT THE LAST LOGICAL RECORD WAS NOT -C BLOCKED. -C - INTEGER L - INTEGER N - INTEGER NEXT - INTEGER WBLANK -C - CHARACTER * 1 LINE(*) - CHARACTER * 1 NBLK(*) - CHARACTER * 1 BLANK -C - SAVE -C - DATA WBLANK/Z'2020202020202020'/ -C DATA WBLANK/Z''/ -C -C TEST VALUE OF NEXT. -C - IF (NEXT.LT.0) THEN - RETURN -C -C TEST N FOR ZERO OR LESS -C - ELSE IF (N.LE.0) THEN - NEXT = -2 - RETURN -C -C TEST L FOR ZERO OR LESS -C - ELSE IF (L.LE.0) THEN - NEXT = -3 - RETURN -C -C TEST TO SEE IF LINE WILL FIT IN BLOCK. -C - ELSE IF ((L + NEXT).GT.N) THEN - NEXT = -1 - RETURN -C -C FILL BLOCK WITH BLANK CHARACTERS IF NEXT EQUAL ZERO. -C BLANK IS ASCII BLANK, 20 HEX, OR 32 DECIMAL -C - ELSE IF (NEXT.EQ.0) THEN - CALL W3FI01(LW) - IWORDS = N / LW - CALL XSTORE(NBLK,WBLANK,IWORDS) - IF (MOD(N,LW).NE.0) THEN - NWORDS = IWORDS * LW - IBYTES = N - NWORDS - DO I = 1,IBYTES - NBLK(NWORDS+I) = CHAR(32) - END DO - END IF - END IF -C -C MOVE LINE INTO BLOCK. -C - CALL XMOVEX(NBLK(NEXT+1),LINE,L) -C -C ADJUST VALUE OF NEXT. -C - NEXT = NEXT + L -C - RETURN -C - END diff --git a/sorc/fbwndgfs.fd/makefile.GENERIC b/sorc/fbwndgfs.fd/makefile.GENERIC deleted file mode 100755 index f38539916f..0000000000 --- a/sorc/fbwndgfs.fd/makefile.GENERIC +++ /dev/null @@ -1,81 +0,0 @@ -SHELL=/bin/sh -# -# This makefile was produced by /usr/bin/fmgen at 12:00:38 PM on 11/27/96 -# If it is invoked by the command line -# make -f makefile -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable named a.out. -# -# If it is invoked by the command line -# make -f makefile a.out.prof -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable which profiles -# named a.out.prof. -# -# To remove all the objects but leave the executables use the command line -# make -f makefile clean -# -# To remove everything but the source files use the command line -# make -f makefile clobber -# -# To remove the source files created by /usr/bin/fmgen and this makefile -# use the command line -# make -f makefile void -# -# The parameters SRCS and OBJS should not need to be changed. If, however, -# you need to add a new module add the name of the source module to the -# SRCS parameter and add the name of the resulting object file to the OBJS -# parameter. The new modules are not limited to fortran, but may be C, YACC, -# LEX, or CAL. An explicit rule will need to be added for PASCAL modules. -# -SRCS= fbwndgfs.f - -OBJS= fbwndgfs.o - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# PROFLIB Library needed for profiling -# -FC = ifort -LDFLAGS = -LIBS = ${W3NCO_LIB8} ${W3EMC_LIB8} ${BACIO_LIB8} ${IP_LIB8} ${SP_LIB8} -CMD = fbwndgfs -PROFLIB = -lprof - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# WARNING: SIMULTANEOUSLY PROFILING AND FLOWTRACING IS NOT RECOMMENDED -FFLAGS = -O3 -g -I ${IP_INC8} -assume byterecl -convert big_endian -r8 -i8 -#FFLAGS = -F -#FFLAGS = -Wf"-ez" - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(LIBS) - -# Make the profiled version of the command and call it a.out.prof -# -$(CMD).prof: $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(PROFLIB) $(LIBS) - -install: - mkdir -p ../../exec - cp -p $(CMD) ../../exec - -clean: - -rm -f $(OBJS) - -clobber: clean - -rm -f $(CMD) $(CMD).prof - -void: clobber - -rm -f $(SRCS) makefile diff --git a/sorc/fbwndgfs.fd/makefile.theia b/sorc/fbwndgfs.fd/makefile.theia deleted file mode 100755 index f38539916f..0000000000 --- a/sorc/fbwndgfs.fd/makefile.theia +++ /dev/null @@ -1,81 +0,0 @@ -SHELL=/bin/sh -# -# This makefile was produced by /usr/bin/fmgen at 12:00:38 PM on 11/27/96 -# If it is invoked by the command line -# make -f makefile -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable named a.out. -# -# If it is invoked by the command line -# make -f makefile a.out.prof -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable which profiles -# named a.out.prof. -# -# To remove all the objects but leave the executables use the command line -# make -f makefile clean -# -# To remove everything but the source files use the command line -# make -f makefile clobber -# -# To remove the source files created by /usr/bin/fmgen and this makefile -# use the command line -# make -f makefile void -# -# The parameters SRCS and OBJS should not need to be changed. If, however, -# you need to add a new module add the name of the source module to the -# SRCS parameter and add the name of the resulting object file to the OBJS -# parameter. The new modules are not limited to fortran, but may be C, YACC, -# LEX, or CAL. An explicit rule will need to be added for PASCAL modules. -# -SRCS= fbwndgfs.f - -OBJS= fbwndgfs.o - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# PROFLIB Library needed for profiling -# -FC = ifort -LDFLAGS = -LIBS = ${W3NCO_LIB8} ${W3EMC_LIB8} ${BACIO_LIB8} ${IP_LIB8} ${SP_LIB8} -CMD = fbwndgfs -PROFLIB = -lprof - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# WARNING: SIMULTANEOUSLY PROFILING AND FLOWTRACING IS NOT RECOMMENDED -FFLAGS = -O3 -g -I ${IP_INC8} -assume byterecl -convert big_endian -r8 -i8 -#FFLAGS = -F -#FFLAGS = -Wf"-ez" - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(LIBS) - -# Make the profiled version of the command and call it a.out.prof -# -$(CMD).prof: $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(PROFLIB) $(LIBS) - -install: - mkdir -p ../../exec - cp -p $(CMD) ../../exec - -clean: - -rm -f $(OBJS) - -clobber: clean - -rm -f $(CMD) $(CMD).prof - -void: clobber - -rm -f $(SRCS) makefile diff --git a/sorc/fbwndgfs.fd/makefile.wcoss b/sorc/fbwndgfs.fd/makefile.wcoss deleted file mode 100755 index f38539916f..0000000000 --- a/sorc/fbwndgfs.fd/makefile.wcoss +++ /dev/null @@ -1,81 +0,0 @@ -SHELL=/bin/sh -# -# This makefile was produced by /usr/bin/fmgen at 12:00:38 PM on 11/27/96 -# If it is invoked by the command line -# make -f makefile -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable named a.out. -# -# If it is invoked by the command line -# make -f makefile a.out.prof -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable which profiles -# named a.out.prof. -# -# To remove all the objects but leave the executables use the command line -# make -f makefile clean -# -# To remove everything but the source files use the command line -# make -f makefile clobber -# -# To remove the source files created by /usr/bin/fmgen and this makefile -# use the command line -# make -f makefile void -# -# The parameters SRCS and OBJS should not need to be changed. If, however, -# you need to add a new module add the name of the source module to the -# SRCS parameter and add the name of the resulting object file to the OBJS -# parameter. The new modules are not limited to fortran, but may be C, YACC, -# LEX, or CAL. An explicit rule will need to be added for PASCAL modules. -# -SRCS= fbwndgfs.f - -OBJS= fbwndgfs.o - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# PROFLIB Library needed for profiling -# -FC = ifort -LDFLAGS = -LIBS = ${W3NCO_LIB8} ${W3EMC_LIB8} ${BACIO_LIB8} ${IP_LIB8} ${SP_LIB8} -CMD = fbwndgfs -PROFLIB = -lprof - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# WARNING: SIMULTANEOUSLY PROFILING AND FLOWTRACING IS NOT RECOMMENDED -FFLAGS = -O3 -g -I ${IP_INC8} -assume byterecl -convert big_endian -r8 -i8 -#FFLAGS = -F -#FFLAGS = -Wf"-ez" - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(LIBS) - -# Make the profiled version of the command and call it a.out.prof -# -$(CMD).prof: $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(PROFLIB) $(LIBS) - -install: - mkdir -p ../../exec - cp -p $(CMD) ../../exec - -clean: - -rm -f $(OBJS) - -clobber: clean - -rm -f $(CMD) $(CMD).prof - -void: clobber - -rm -f $(SRCS) makefile diff --git a/sorc/fbwndgfs.fd/makefile.wcoss_cray b/sorc/fbwndgfs.fd/makefile.wcoss_cray deleted file mode 100755 index 0ebe267cb9..0000000000 --- a/sorc/fbwndgfs.fd/makefile.wcoss_cray +++ /dev/null @@ -1,81 +0,0 @@ -SHELL=/bin/sh -# -# This makefile was produced by /usr/bin/fmgen at 12:00:38 PM on 11/27/96 -# If it is invoked by the command line -# make -f makefile -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable named a.out. -# -# If it is invoked by the command line -# make -f makefile a.out.prof -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable which profiles -# named a.out.prof. -# -# To remove all the objects but leave the executables use the command line -# make -f makefile clean -# -# To remove everything but the source files use the command line -# make -f makefile clobber -# -# To remove the source files created by /usr/bin/fmgen and this makefile -# use the command line -# make -f makefile void -# -# The parameters SRCS and OBJS should not need to be changed. If, however, -# you need to add a new module add the name of the source module to the -# SRCS parameter and add the name of the resulting object file to the OBJS -# parameter. The new modules are not limited to fortran, but may be C, YACC, -# LEX, or CAL. An explicit rule will need to be added for PASCAL modules. -# -SRCS= fbwndgfs.f - -OBJS= fbwndgfs.o - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# PROFLIB Library needed for profiling -# -FC = ftn -LDFLAGS = -LIBS = ${W3NCO_LIB8} ${W3EMC_LIB8} ${BACIO_LIB8} ${IP_LIB8} ${SP_LIB8} -CMD = fbwndgfs -PROFLIB = -lprof - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# WARNING: SIMULTANEOUSLY PROFILING AND FLOWTRACING IS NOT RECOMMENDED -FFLAGS = -O3 -g -I ${IP_INC8} -assume byterecl -convert big_endian -r8 -i8 -axCORE-AVX2 -#FFLAGS = -F -#FFLAGS = -Wf"-ez" - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(LIBS) - -# Make the profiled version of the command and call it a.out.prof -# -$(CMD).prof: $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(PROFLIB) $(LIBS) - -install: - mkdir -p ../../exec - cp -p $(CMD) ../../exec - -clean: - -rm -f $(OBJS) - -clobber: clean - -rm -f $(CMD) $(CMD).prof - -void: clobber - -rm -f $(SRCS) makefile diff --git a/sorc/fbwndgfs.fd/makefile.wcoss_dell_p3 b/sorc/fbwndgfs.fd/makefile.wcoss_dell_p3 deleted file mode 100755 index f38539916f..0000000000 --- a/sorc/fbwndgfs.fd/makefile.wcoss_dell_p3 +++ /dev/null @@ -1,81 +0,0 @@ -SHELL=/bin/sh -# -# This makefile was produced by /usr/bin/fmgen at 12:00:38 PM on 11/27/96 -# If it is invoked by the command line -# make -f makefile -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable named a.out. -# -# If it is invoked by the command line -# make -f makefile a.out.prof -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable which profiles -# named a.out.prof. -# -# To remove all the objects but leave the executables use the command line -# make -f makefile clean -# -# To remove everything but the source files use the command line -# make -f makefile clobber -# -# To remove the source files created by /usr/bin/fmgen and this makefile -# use the command line -# make -f makefile void -# -# The parameters SRCS and OBJS should not need to be changed. If, however, -# you need to add a new module add the name of the source module to the -# SRCS parameter and add the name of the resulting object file to the OBJS -# parameter. The new modules are not limited to fortran, but may be C, YACC, -# LEX, or CAL. An explicit rule will need to be added for PASCAL modules. -# -SRCS= fbwndgfs.f - -OBJS= fbwndgfs.o - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# PROFLIB Library needed for profiling -# -FC = ifort -LDFLAGS = -LIBS = ${W3NCO_LIB8} ${W3EMC_LIB8} ${BACIO_LIB8} ${IP_LIB8} ${SP_LIB8} -CMD = fbwndgfs -PROFLIB = -lprof - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# WARNING: SIMULTANEOUSLY PROFILING AND FLOWTRACING IS NOT RECOMMENDED -FFLAGS = -O3 -g -I ${IP_INC8} -assume byterecl -convert big_endian -r8 -i8 -#FFLAGS = -F -#FFLAGS = -Wf"-ez" - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(LIBS) - -# Make the profiled version of the command and call it a.out.prof -# -$(CMD).prof: $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(PROFLIB) $(LIBS) - -install: - mkdir -p ../../exec - cp -p $(CMD) ../../exec - -clean: - -rm -f $(OBJS) - -clobber: clean - -rm -f $(CMD) $(CMD).prof - -void: clobber - -rm -f $(SRCS) makefile diff --git a/sorc/fv3nc2nemsio.fd/0readme b/sorc/fv3nc2nemsio.fd/0readme deleted file mode 100644 index 7be2fbcd34..0000000000 --- a/sorc/fv3nc2nemsio.fd/0readme +++ /dev/null @@ -1,23 +0,0 @@ -The first version of this program was provided by Jeff Whitaker and Philip Pegion from ESRL. -Fanglin Ynag has subsequently made a few revsions. - -10/20/2016, Fanglin Yang -Note that FV3 lat-lon grids are located at the center of each grid box, -start from south to north, and from east to west. -For example, for a 0.5-deg uniform grid, -nlon=720, nlat=360 -X(1,1)=[0.25E,89.75S] -X(nlon,nlat)=[359.75E,89.75N] - -write out nemsio, S->N is reversed to N->S to follow NCEP convention - -12/18/2016 Fanglin Yang -updated to handle output of any frequency and any accumulation bucket - - -01/10/2017 Fanglin Yang -updated to handle both hydrostatic and nonhydrostatic cases. They have different output numbers and variable names. - -10/07/2017 Fanglin Yang -In FV3 tic26 branch which includes the lastest Write Component, hgtsfc has been defined as [m] instead of [gpm]. -The scaling by 1/grav in fv3nc2nemsio.fd needs to be removed. diff --git a/sorc/fv3nc2nemsio.fd/CMakeLists.txt b/sorc/fv3nc2nemsio.fd/CMakeLists.txt deleted file mode 100644 index 82778a1017..0000000000 --- a/sorc/fv3nc2nemsio.fd/CMakeLists.txt +++ /dev/null @@ -1,17 +0,0 @@ -list(APPEND fortran_src -constants.f90 -fv3_main.f90 -fv3_module.f90 -kinds.f90 -) - -set(exe_name fv3nc2nemsio.x) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - nemsio::nemsio - bacio::bacio_4 - w3nco::w3nco_d - NetCDF::NetCDF_Fortran) - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/fv3nc2nemsio.fd/constants.f90 b/sorc/fv3nc2nemsio.fd/constants.f90 deleted file mode 100644 index c0a066eec0..0000000000 --- a/sorc/fv3nc2nemsio.fd/constants.f90 +++ /dev/null @@ -1,314 +0,0 @@ -! this module was extracted from the GSI version operational -! at NCEP in Dec. 2007. -module constants -!$$$ module documentation block -! . . . . -! module: constants -! prgmmr: treadon org: np23 date: 2003-09-25 -! -! abstract: This module contains the definition of various constants -! used in the gsi code -! -! program history log: -! 2003-09-25 treadon - original code -! 2004-03-02 treadon - allow global and regional constants to differ -! 2004-06-16 treadon - update documentation -! 2004-10-28 treadon - replace parameter tiny=1.e-12 with tiny_r_kind -! and tiny_single -! 2004-11-16 treadon - add huge_single, huge_r_kind parameters -! 2005-01-27 cucurull - add ione -! 2005-08-24 derber - move cg_term to constants from qcmod -! 2006-03-07 treadon - add rd_over_cp_mass -! 2006-05-18 treadon - add huge_i_kind -! 2006-06-06 su - add var-qc wgtlim, change value to 0.25 (ECMWF) -! 2006-07-28 derber - add r1000 -! -! Subroutines Included: -! sub init_constants - compute derived constants, set regional/global constants -! -! Variable Definitions: -! see below -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_single,r_kind,i_kind - implicit none - -! Declare constants - integer(i_kind) izero,ione - real(r_kind) rearth,grav,omega,rd,rv,cp,cv,cvap,cliq - real(r_kind) csol,hvap,hfus,psat,t0c,ttp,jcal,cp_mass,cg_term - real(r_kind) fv,deg2rad,rad2deg,pi,tiny_r_kind,huge_r_kind,huge_i_kind - real(r_kind) ozcon,rozcon,tpwcon,rd_over_g,rd_over_cp,g_over_rd - real(r_kind) amsua_clw_d1,amsua_clw_d2,constoz,zero,one,two,four - real(r_kind) one_tenth,quarter,three,five,rd_over_cp_mass, gamma - real(r_kind) rearth_equator,stndrd_atmos_ps,r1000 - real(r_kind) semi_major_axis,semi_minor_axis,n_a,n_b - real(r_kind) eccentricity,grav_polar,grav_ratio - real(r_kind) grav_equator,earth_omega,grav_constant - real(r_kind) flattening,eccentricity_linear,somigliana - real(r_kind) dldt,dldti,hsub,psatk,tmix,xa,xai,xb,xbi - real(r_kind) eps,epsm1,omeps,wgtlim - real(r_kind) elocp,cpr,el2orc,cclimit,climit,epsq - real(r_kind) pcpeff0,pcpeff1,pcpeff2,pcpeff3,rcp,c0,delta - real(r_kind) h1000,factor1,factor2,rhcbot,rhctop,dx_max,dx_min,dx_inv - real(r_kind) h300,half,cmr,cws,ke2,row,rrow - real(r_single) zero_single,tiny_single,huge_single - real(r_single) rmw_mean_distance, roic_mean_distance - logical :: constants_initialized = .true. - - -! Define constants common to global and regional applications -! name value description units -! ---- ----- ----------- ----- - parameter(rearth_equator= 6.37813662e6_r_kind) ! equatorial earth radius (m) - parameter(omega = 7.2921e-5_r_kind) ! angular velocity of earth (1/s) - parameter(cp = 1.0046e+3_r_kind) ! specific heat of air @pressure (J/kg/K) - parameter(cvap = 1.8460e+3_r_kind) ! specific heat of h2o vapor (J/kg/K) - parameter(csol = 2.1060e+3_r_kind) ! specific heat of solid h2o (ice)(J/kg/K) - parameter(hvap = 2.5000e+6_r_kind) ! latent heat of h2o condensation (J/kg) - parameter(hfus = 3.3358e+5_r_kind) ! latent heat of h2o fusion (J/kg) - parameter(psat = 6.1078e+2_r_kind) ! pressure at h2o triple point (Pa) - parameter(t0c = 2.7315e+2_r_kind) ! temperature at zero celsius (K) - parameter(ttp = 2.7316e+2_r_kind) ! temperature at h2o triple point (K) - parameter(jcal = 4.1855e+0_r_kind) ! joules per calorie () - parameter(stndrd_atmos_ps = 1013.25e2_r_kind) ! 1976 US standard atmosphere ps (Pa) - -! Numeric constants - parameter(izero = 0) - parameter(ione = 1) - parameter(zero_single = 0.0_r_single) - parameter(zero = 0.0_r_kind) - parameter(one_tenth = 0.10_r_kind) - parameter(quarter= 0.25_r_kind) - parameter(one = 1.0_r_kind) - parameter(two = 2.0_r_kind) - parameter(three = 3.0_r_kind) - parameter(four = 4.0_r_kind) - parameter(five = 5.0_r_kind) - parameter(r1000 = 1000.0_r_kind) - -! Constants for gps refractivity - parameter(n_a=77.6_r_kind) !K/mb - parameter(n_b=3.73e+5_r_kind) !K^2/mb - -! Parameters below from WGS-84 model software inside GPS receivers. - parameter(semi_major_axis = 6378.1370e3_r_kind) ! (m) - parameter(semi_minor_axis = 6356.7523142e3_r_kind) ! (m) - parameter(grav_polar = 9.8321849378_r_kind) ! (m/s2) - parameter(grav_equator = 9.7803253359_r_kind) ! (m/s2) - parameter(earth_omega = 7.292115e-5_r_kind) ! (rad/s) - parameter(grav_constant = 3.986004418e14_r_kind) ! (m3/s2) - -! Derived geophysical constants - parameter(flattening = (semi_major_axis-semi_minor_axis)/semi_major_axis)!() - parameter(somigliana = & - (semi_minor_axis/semi_major_axis) * (grav_polar/grav_equator) - one)!() - parameter(grav_ratio = (earth_omega*earth_omega * & - semi_major_axis*semi_major_axis * semi_minor_axis) / grav_constant) !() - -! Derived thermodynamic constants - parameter ( dldti = cvap-csol ) - parameter ( hsub = hvap+hfus ) - parameter ( psatk = psat*0.001_r_kind ) - parameter ( tmix = ttp-20._r_kind ) - parameter ( elocp = hvap/cp ) - parameter ( rcp = one/cp ) - -! Constants used in GFS moist physics - parameter ( h300 = 300._r_kind ) - parameter ( half = 0.5_r_kind ) - parameter ( cclimit = 0.001_r_kind ) - parameter ( climit = 1.e-20_r_kind) - parameter ( epsq = 2.e-12_r_kind ) - parameter ( h1000 = 1000.0_r_kind) - parameter ( rhcbot=0.85_r_kind ) - parameter ( rhctop=0.85_r_kind ) - parameter ( dx_max=-8.8818363_r_kind ) - parameter ( dx_min=-5.2574954_r_kind ) - parameter ( dx_inv=one/(dx_max-dx_min) ) - parameter ( c0=0.002_r_kind ) - parameter ( delta=0.6077338_r_kind ) - parameter ( pcpeff0=1.591_r_kind ) - parameter ( pcpeff1=-0.639_r_kind ) - parameter ( pcpeff2=0.0953_r_kind ) - parameter ( pcpeff3=-0.00496_r_kind ) - parameter ( cmr = one/0.0003_r_kind ) - parameter ( cws = 0.025_r_kind ) - parameter ( ke2 = 0.00002_r_kind ) - parameter ( row = 1000._r_kind ) - parameter ( rrow = one/row ) - -! Constant used to process ozone - parameter ( constoz = 604229.0_r_kind) - -! Constants used in cloud liquid water correction for AMSU-A -! brightness temperatures - parameter ( amsua_clw_d1 = 0.754_r_kind ) - parameter ( amsua_clw_d2 = -2.265_r_kind ) - -! Constants used for variational qc - parameter ( wgtlim = 0.25_r_kind) ! Cutoff weight for concluding that obs has been - ! rejected by nonlinear qc. This limit is arbitrary - ! and DOES NOT affect nonlinear qc. It only affects - ! the printout which "counts" the number of obs that - ! "fail" nonlinear qc. Observations counted as failing - ! nonlinear qc are still assimilated. Their weight - ! relative to other observations is reduced. Changing - ! wgtlim does not alter the analysis, only - ! the nonlinear qc data "count" - -! Constants describing the Extended Best-Track Reanalysis [Demuth et -! al., 2008] tropical cyclone (TC) distance for regions relative to TC -! track position; units are in kilometers - - parameter (rmw_mean_distance = 64.5479412) - parameter (roic_mean_distance = 338.319656) - -contains - subroutine init_constants_derived -!$$$ subprogram documentation block -! . . . . -! subprogram: init_constants_derived set derived constants -! prgmmr: treadon org: np23 date: 2004-12-02 -! -! abstract: This routine sets derived constants -! -! program history log: -! 2004-12-02 treadon -! 2005-03-03 treadon - add implicit none -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp -! -!$$$ - implicit none - -! Trigonometric constants - pi = acos(-one) - deg2rad = pi/180.0_r_kind - rad2deg = one/deg2rad - cg_term = (sqrt(two*pi))/two ! constant for variational qc - tiny_r_kind = tiny(zero) - huge_r_kind = huge(zero) - tiny_single = tiny(zero_single) - huge_single = huge(zero_single) - huge_i_kind = huge(izero) - -! Geophysical parameters used in conversion of geopotential to -! geometric height - eccentricity_linear = sqrt(semi_major_axis**2 - semi_minor_axis**2) - eccentricity = eccentricity_linear / semi_major_axis - constants_initialized = .true. - - return - end subroutine init_constants_derived - - subroutine init_constants(regional) -!$$$ subprogram documentation block -! . . . . -! subprogram: init_constants set regional or global constants -! prgmmr: treadon org: np23 date: 2004-03-02 -! -! abstract: This routine sets constants specific to regional or global -! applications of the gsi -! -! program history log: -! 2004-03-02 treadon -! 2004-06-16 treadon, documentation -! 2004-10-28 treadon - use intrinsic TINY function to set value -! for smallest machine representable positive -! number -! 2004-12-03 treadon - move derived constants to init_constants_derived -! 2005-03-03 treadon - add implicit none -! -! input argument list: -! regional - if .true., set regional gsi constants; -! otherwise (.false.), use global constants -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp -! -!$$$ - implicit none - logical regional - real(r_kind) reradius,g,r_d,r_v,cliq_wrf - - gamma = 0.0065 - -! Define regional constants here - if (regional) then - -! Name given to WRF constants - reradius = one/6370.e03_r_kind - g = 9.81_r_kind - r_d = 287.04_r_kind - r_v = 461.6_r_kind - cliq_wrf = 4190.0_r_kind - cp_mass = 1004.67_r_kind - -! Transfer WRF constants into unified GSI constants - rearth = one/reradius - grav = g - rd = r_d - rv = r_v - cv = cp-r_d - cliq = cliq_wrf - rd_over_cp_mass = rd / cp_mass - -! Define global constants here - else - rearth = 6.3712e+6_r_kind - grav = 9.80665e+0_r_kind - rd = 2.8705e+2_r_kind - rv = 4.6150e+2_r_kind - cv = 7.1760e+2_r_kind - cliq = 4.1855e+3_r_kind - cp_mass= zero - rd_over_cp_mass = zero - endif - - -! Now define derived constants which depend on constants -! which differ between global and regional applications. - -! Constants related to ozone assimilation - ozcon = grav*21.4e-9_r_kind - rozcon= one/ozcon - -! Constant used in vertical integral for precipitable water - tpwcon = 100.0_r_kind/grav - -! Derived atmospheric constants - fv = rv/rd-one ! used in virtual temperature equation - dldt = cvap-cliq - xa = -(dldt/rv) - xai = -(dldti/rv) - xb = xa+hvap/(rv*ttp) - xbi = xai+hsub/(rv*ttp) - eps = rd/rv - epsm1 = rd/rv-one - omeps = one-eps - factor1 = (cvap-cliq)/rv - factor2 = hvap/rv-factor1*t0c - cpr = cp*rd - el2orc = hvap*hvap/(rv*cp) - rd_over_g = rd/grav - rd_over_cp = rd/cp - g_over_rd = grav/rd - - return - end subroutine init_constants - -end module constants diff --git a/sorc/fv3nc2nemsio.fd/fv3_main.f90 b/sorc/fv3nc2nemsio.fd/fv3_main.f90 deleted file mode 100644 index 48c7440b14..0000000000 --- a/sorc/fv3nc2nemsio.fd/fv3_main.f90 +++ /dev/null @@ -1,215 +0,0 @@ -program fv3_main - use fv3_module - use netcdf - use nemsio_module - implicit none - - type(nemsio_gfile) :: gfile - type(nemsio_meta) :: meta_nemsio - integer,parameter :: nvar2d=48 - character(nemsio_charkind) :: name2d(nvar2d) - integer :: nvar3d - character(nemsio_charkind), allocatable :: name3din(:), name3dout(:) - character(nemsio_charkind) :: varname,levtype - character(len=300) :: inpath,outpath - character(len=100) :: infile2d,infile3d,outfile - character(len=10) :: analdate, cfhour - character(len=5) :: cfhr,cfhzh - character(len=2) :: nhcase - real , allocatable :: lons(:),lats(:),tmp2d(:,:), tmp2dx(:,:) - real*8,allocatable :: tmp1d(:),tmp1dx(:),fhours(:) - real*4 :: fhour - integer :: fhzh, nhcas - - integer :: ii,i,j,k,ncid2d,ncid3d,ifhr,nlevs,nlons,nlats,ntimes,nargs,iargc,YYYY,MM,DD,HH,stat,varid - - data name2d /'ALBDOsfc','CPRATsfc','PRATEsfc','DLWRFsfc','ULWRFsfc','DSWRFsfc','USWRFsfc','DSWRFtoa','USWRFtoa',& - 'ULWRFtoa','GFLUXsfc','HGTsfc','HPBLsfc',& - 'ICECsfc','SLMSKsfc','LHTFLsfc','SHTFLsfc','PRESsfc','PWATclm','SOILM','SOILW1','SOILW2','SOILW3','SOILW4','SPFH2m',& - 'SOILT1','SOILT2','SOILT3','SOILT4','TMP2m','TMPsfc','UGWDsfc','VGWDsfc','UFLXsfc','VFLXsfc','UGRD10m','VGRD10m',& - 'WEASDsfc','SNODsfc','ZORLsfc','VFRACsfc','F10Msfc','VTYPEsfc','STYPEsfc',& - 'TCDCclm', 'TCDChcl', 'TCDCmcl', 'TCDClcl'/ - - !===================================================================== - - ! read in from command line - nargs=iargc() - IF (nargs .NE. 10) THEN - print*,'usage fv3_interface analdate ifhr fhzh fhour inpath infile2d infile3d outpath,outfile,nhcase' - STOP 1 - ENDIF - call getarg(1,analdate) - call getarg(2,cfhr) - call getarg(3,cfhzh) - call getarg(4,cfhour) - call getarg(5,inpath) - call getarg(6,infile2d) - call getarg(7,infile3d) - call getarg(8,outpath) - call getarg(9,outfile) - call getarg(10,nhcase) -! print*,analdate,cfhr,cfhzh,cfhour,inpath,infile2d,infile3d,outpath,outfile,nhcase - - read(nhcase,'(i2.1)') nhcas - read(cfhr,'(i5.1)') ifhr - read(cfhzh,'(i5.1)') fhzh - read(cfhour,*) fhour - read(analdate(1:4),'(i4)') YYYY - read(analdate(5:6),'(i2)') MM - read(analdate(7:8),'(i2)') DD - read(analdate(9:10),'(i2)') HH - print*,"ifhr,fhzh,fhour,analdate ",ifhr,fhzh,fhour,analdate - - if (nhcas == 0 ) then !non-hydrostatic case - nvar3d=9 - allocate (name3din(nvar3d), name3dout(nvar3d)) - name3din=(/'ucomp ','vcomp ','temp ','sphum ','o3mr ','nhpres','w ','clwmr ','delp '/) - name3dout=(/'ugrd ','vgrd ','tmp ','spfh ','o3mr ','pres ','vvel ','clwmr','dpres'/) - else - nvar3d=8 - allocate (name3din(nvar3d), name3dout(nvar3d)) - name3din=(/'ucomp ','vcomp ','temp ','sphum ','o3mr ','hypres','clwmr ','delp '/) - name3dout=(/'ugrd ','vgrd ','tmp ','spfh ','o3mr ','pres ','clwmr','dpres'/) - endif - - ! open netcdf files - print*,'reading',trim(inpath)//'/'//trim(infile2d) - stat = nf90_open(trim(inpath)//'/'//trim(infile2d),NF90_NOWRITE, ncid2d) - if (stat .NE.0) print*,stat - print*,'reading',trim(inpath)//'/'//trim(infile3d) - stat = nf90_open(trim(inpath)//'/'//trim(infile3d),NF90_NOWRITE, ncid3d) - if (stat .NE.0) print*,stat - ! get dimesions - - stat = nf90_inq_dimid(ncid2d,'time',varid) - if (stat .NE.0) print*,stat,varid - if (stat .NE. 0) STOP 1 - stat = nf90_inquire_dimension(ncid2d,varid,len=ntimes) - if (stat .NE.0) print*,stat,ntimes - if (stat .NE. 0) STOP 1 - allocate(fhours(ntimes)) - stat = nf90_inq_varid(ncid2d,'time',varid) - if (stat .NE. 0) STOP 1 - stat = nf90_get_var(ncid2d,varid,fhours) - if (stat .NE.0) print*,stat,fhours - if (stat .NE. 0) STOP 1 - - stat = nf90_inq_dimid(ncid3d,'grid_xt',varid) - if (stat .NE.0) print*,stat,varid - if (stat .NE. 0) STOP 1 - stat = nf90_inquire_dimension(ncid3d,varid,len=nlons) - if (stat .NE.0) print*,stat,nlons - if (stat .NE. 0) STOP 1 - allocate(lons(nlons)) - allocate(tmp1d(nlons)) - stat = nf90_inq_varid(ncid3d,'grid_xt',varid) - if (stat .NE. 0) STOP 1 - stat = nf90_get_var(ncid3d,varid,tmp1d) - if (stat .NE.0) print*,stat - if (stat .NE. 0) STOP 1 - - lons=real(tmp1d,kind=4) - !print*,lons(1),lons(3072) - deallocate(tmp1d) - - stat = nf90_inq_dimid(ncid3d,'grid_yt',varid) - if (stat .NE.0) print*,stat - if (stat .NE. 0) STOP 1 - stat = nf90_inquire_dimension(ncid3d,varid,len=nlats) - if (stat .NE.0) print*,stat - if (stat .NE. 0) STOP 1 - allocate(lats(nlats)) - allocate(tmp1d(nlats)) - allocate(tmp1dx(nlats)) - stat = nf90_inq_varid(ncid3d,'grid_yt',varid) - stat = nf90_get_var(ncid3d,varid,tmp1dx,start=(/1/),count=(/nlats/)) - if (stat .NE.0) print*,stat - if (stat .NE. 0) STOP 1 - do j=1,nlats - tmp1d(j)=tmp1dx(nlats-j+1) - enddo - lats=real(tmp1d,kind=4) - print*,"lats_beg, lats_end",lats(1),lats(nlats) - deallocate(tmp1d, tmp1dx) - - stat = nf90_inq_dimid(ncid3d,'pfull',varid) - if (stat .NE.0) print*,stat - if (stat .NE. 0) STOP 1 - stat = nf90_inquire_dimension(ncid3d,varid,len=nlevs) - if (stat .NE.0) print*,stat - if (stat .NE. 0) STOP 1 - - call define_nemsio_meta(meta_nemsio,nlons,nlats,nlevs,nvar2d,nvar3d,lons,lats) - - allocate (tmp2d(nlons,nlats)) - allocate (tmp2dx(nlons,nlats)) - - meta_nemsio%idate(1)=YYYY - meta_nemsio%idate(2)=MM - meta_nemsio%idate(3)=DD - meta_nemsio%idate(4)=HH - - meta_nemsio%varrval(1)=float(fhzh) -! if (ifhr.EQ.0) then -! meta_nemsio%varrval(1)=0.0 -! else -! meta_nemsio%varrval(1)=(ifhr-1.0)*6.0 -! endif - - ! read in data - meta_nemsio%nfhour= fhours(ifhr) - meta_nemsio%fhour= fhours(ifhr) - print*,fhours(ifhr),ifhr,'calling netcdf read' -!--for ifhr=1, fhours=dt but fhour=00 if diag is determined by FHOUT - if (fhour .ne. fhours(ifhr) .and. ifhr.gt.1 )then - print*, 'requested ',fhour, ' not equal to fhours(ifhr) ', fhours(ifhr) - print*, 'abort ! ' - stop 1 - endif - - call nems_write_init(outpath,outfile,meta_nemsio,gfile) -! read in all of the 2d variables and write out - print*,'calling write',meta_nemsio%rlat_min,meta_nemsio%rlat_max - print*,'lats',minval(meta_nemsio%lat),maxval(meta_nemsio%lat) - print *,'loop over 2d variables' - DO i=1,nvar2d - print *,i,trim(name2d(i)) - call fv3_netcdf_read_2d(ncid2d,ifhr,meta_nemsio,name2d(i),tmp2dx) - do ii=1,nlons - do j=1,nlats - tmp2d(ii,j)=tmp2dx(ii,nlats-j+1) - enddo - enddo - call nems_write(gfile,meta_nemsio%recname(i),meta_nemsio%reclevtyp(i),meta_nemsio%reclev(i), & - nlons*nlats,tmp2d,stat) - ENDDO - levtype='mid layer' -! loop through 3d fields - print *,'loop over 3d variables' - DO i=1,nvar3d - print*,i,trim(name3din(i)) - DO k=1,nlevs -! print*,k - call fv3_netcdf_read_3d(ncid3d,ifhr,meta_nemsio,name3din(i),k,tmp2dx) - do ii=1,nlons - do j=1,nlats - tmp2d(ii,j)=tmp2dx(ii,nlats-j+1) - enddo - enddo - call nems_write(gfile,name3dout(i),levtype,nlevs-k+1,nlons*nlats,tmp2d(:,:),stat) - IF (stat .NE. 0) then - print*,'error writing ,named3dout(i)',stat - STOP 1 - ENDIF - ENDDO - ENDDO - - call nemsio_close(gfile,iret=stat) - stat = nf90_close(ncid2d) - stat = nf90_close(ncid3d) - - deallocate(tmp2dx,tmp2d) - deallocate(name3din,name3dout) - - stop -end program fv3_main diff --git a/sorc/fv3nc2nemsio.fd/fv3_module.f90 b/sorc/fv3nc2nemsio.fd/fv3_module.f90 deleted file mode 100644 index 8d161acfcf..0000000000 --- a/sorc/fv3nc2nemsio.fd/fv3_module.f90 +++ /dev/null @@ -1,372 +0,0 @@ -module fv3_module - - - !======================================================================= - - ! Define associated modules and subroutines - - !----------------------------------------------------------------------- - use netcdf - use constants - use kinds - use nemsio_module - - type nemsio_meta - character(nemsio_charkind), dimension(:), allocatable :: recname - character(nemsio_charkind), dimension(:), allocatable :: reclevtyp - character(16), dimension(:), allocatable :: variname - character(16), dimension(:), allocatable :: varrname - character(16), dimension(:), allocatable :: varr8name - character(16), dimension(:), allocatable :: aryiname - character(16), dimension(:), allocatable :: aryr8name - character(nemsio_charkind8) :: gdatatype - character(nemsio_charkind8) :: modelname - real(nemsio_realkind) :: rlon_min - real(nemsio_realkind) :: rlon_max - real(nemsio_realkind) :: rlat_min - real(nemsio_realkind) :: rlat_max - real(nemsio_realkind), dimension(:), allocatable :: lon - real(nemsio_realkind), dimension(:), allocatable :: lat - real(nemsio_realkind), dimension(:), allocatable :: varrval - integer(nemsio_intkind), dimension(:,:), allocatable :: aryival - integer(nemsio_intkind), dimension(:), allocatable :: reclev - integer(nemsio_intkind), dimension(:), allocatable :: varival - integer(nemsio_intkind), dimension(:), allocatable :: aryilen - integer(nemsio_intkind), dimension(:), allocatable :: aryr8len - integer(nemsio_intkind) :: idate(7) - integer(nemsio_intkind) :: version - integer(nemsio_intkind) :: nreo_vc - integer(nemsio_intkind) :: nrec - integer(nemsio_intkind) :: nmeta - integer(nemsio_intkind) :: nmetavari - integer(nemsio_intkind) :: nmetaaryi - integer(nemsio_intkind) :: nmetavarr - integer(nemsio_intkind) :: nfhour - integer(nemsio_intkind) :: nfminute - integer(nemsio_intkind) :: nfsecondn - integer(nemsio_intkind) :: nfsecondd - integer(nemsio_intkind) :: dimx - integer(nemsio_intkind) :: dimy - integer(nemsio_intkind) :: dimz - integer(nemsio_intkind) :: nframe - integer(nemsio_intkind) :: nsoil - integer(nemsio_intkind) :: ntrac - integer(nemsio_intkind) :: ncldt - integer(nemsio_intkind) :: idvc - integer(nemsio_intkind) :: idsl - integer(nemsio_intkind) :: idvm - integer(nemsio_intkind) :: idrt - integer(nemsio_intkind) :: fhour - - end type nemsio_meta ! type nemsio_meta - contains -!----------------------------------------------------------------------- - subroutine fv3_netcdf_read_2d(ncid2d,ifhr,meta_nemsio,varname,data2d) - - implicit none - type(nemsio_meta) :: meta_nemsio - integer :: ncid2d - integer :: ifhr,varid,stat - real :: data2d(meta_nemsio%dimx,meta_nemsio%dimy) - character(nemsio_charkind) :: varname - - ! loop through 2d data - stat = nf90_inq_varid(ncid2d,trim(varname),varid) - !print*,stat,varid,trim(varname) - stat = nf90_get_var(ncid2d,varid,data2d,start=(/1,1,ifhr/),count=(/meta_nemsio%dimx,meta_nemsio%dimy,1/)) - IF (stat .NE. 0 ) THEN - print*,'error reading ',varname - STOP - ENDIF - -end subroutine fv3_netcdf_read_2d -!----------------------------------------------------------------------- - - subroutine fv3_netcdf_read_3d(ncid3d,ifhr,meta_nemsio,varname,k,data2d) - - implicit none - - type(nemsio_meta) :: meta_nemsio - integer :: ncid3d - integer :: k - integer :: ifhr,varid,stat - character(nemsio_charkind) :: varname - !real :: data3d(meta_nemsio%dimx,meta_nemsio%dimy,meta_nemsio%dimz) - real :: data2d(meta_nemsio%dimx,meta_nemsio%dimy) - - - stat = nf90_inq_varid(ncid3d,trim(varname),varid) - !print*,stat,varname,varid - !stat = nf90_get_var(ncid3d,varid,data3d,start=(/1,1,1,ifhr/),count=(/meta_nemsio%dimx,meta_nemsio%dimy,meta_nemsio%dimz,1/)) - stat = nf90_get_var(ncid3d,varid,data2d,start=(/1,1,k,ifhr/),count=(/meta_nemsio%dimx,meta_nemsio%dimy,1,1/)) - - IF (stat .NE. 0 ) THEN - print*,'error reading ',varname - STOP - ENDIF - -end subroutine fv3_netcdf_read_3d -!----------------------------------------------------------------------- - - subroutine define_nemsio_meta(meta_nemsio,nlons,nlats,nlevs,nvar2d,nvar3d,lons,lats) - implicit none - type(nemsio_meta) :: meta_nemsio - integer :: nlons,nlats,nlevs,i,j,k,nvar2d,nvar3d - integer*8 :: ct - real :: lons(nlons),lats(nlats) -! local - - meta_nemsio%idate(1:6) = 0 - meta_nemsio%idate(7) = 1 - meta_nemsio%modelname = 'GFS' - meta_nemsio%version = 198410 - meta_nemsio%nrec = nvar2d + nlevs*nvar3d - meta_nemsio%nmeta = 8 - meta_nemsio%nmetavari = 3 - meta_nemsio%nmetavarr = 1 - meta_nemsio%nmetaaryi = 1 - meta_nemsio%dimx = nlons - meta_nemsio%dimy = nlats - meta_nemsio%dimz = nlevs - meta_nemsio%rlon_min = minval(lons) - meta_nemsio%rlon_max = maxval(lons) - meta_nemsio%rlat_min = minval(lats) - meta_nemsio%rlat_max = maxval(lats) - meta_nemsio%nsoil = 4 - meta_nemsio%nframe = 0 - meta_nemsio%nfminute = 0 - meta_nemsio%nfsecondn = 0 - meta_nemsio%nfsecondd = 1 - meta_nemsio%ntrac = 3 - meta_nemsio%idrt = 0 - meta_nemsio%ncldt = 3 - meta_nemsio%idvc = 2 - - - allocate(meta_nemsio%recname(meta_nemsio%nrec)) - allocate(meta_nemsio%reclevtyp(meta_nemsio%nrec)) - allocate(meta_nemsio%reclev(meta_nemsio%nrec)) - allocate(meta_nemsio%variname(meta_nemsio%nmetavari)) - allocate(meta_nemsio%varival(meta_nemsio%nmetavari)) - allocate(meta_nemsio%aryiname(meta_nemsio%nmetavari)) - allocate(meta_nemsio%aryilen(meta_nemsio%nmetavari)) - allocate(meta_nemsio%varrname(meta_nemsio%nmetavarr)) - allocate(meta_nemsio%varrval(meta_nemsio%nmetavarr)) - allocate(meta_nemsio%lon(nlons*nlats)) - allocate(meta_nemsio%lat(nlons*nlats)) - - meta_nemsio%varrname(1)='zhour' - meta_nemsio%variname(1)='cu_physics' - meta_nemsio%varival(1)=4 - meta_nemsio%variname(2)='mp_physics' - meta_nemsio%varival(2)=1000 - meta_nemsio%variname(3)='IVEGSRC' - meta_nemsio%varival(3)=2 - ct=1 - DO j=1,nlats - DO i=1,nlons - meta_nemsio%lon(ct) = lons(i) - meta_nemsio%lat(ct) = lats(j) - ct=ct+1 - ENDDO - ENDDO - - meta_nemsio%aryilen(1) = nlats/2 - meta_nemsio%aryiname(1) = 'lpl' - meta_nemsio%reclev(:)=1 - meta_nemsio%recname(1) = 'albdo_ave' - meta_nemsio%reclevtyp(1) = 'sfc' - meta_nemsio%recname(2) = 'cprat_ave' - meta_nemsio%reclevtyp(2) = 'sfc' - meta_nemsio%recname(3) = 'prate_ave' - meta_nemsio%reclevtyp(3) = 'sfc' - meta_nemsio%recname(4) = 'dlwrf_ave' - meta_nemsio%reclevtyp(4) = 'sfc' - meta_nemsio%recname(5) = 'ulwrf_ave' - meta_nemsio%reclevtyp(5) = 'sfc' - meta_nemsio%recname(6) = 'dswrf_ave' - meta_nemsio%reclevtyp(6) = 'sfc' - meta_nemsio%recname(7) = 'uswrf_ave' - meta_nemsio%reclevtyp(7) = 'sfc' - meta_nemsio%recname(8) = 'dswrf_ave' - meta_nemsio%reclevtyp(8) = 'nom. top' - meta_nemsio%recname(9) = 'uswrf_ave' - meta_nemsio%reclevtyp(9) = 'nom. top' - meta_nemsio%recname(10) = 'ulwrf_ave' - meta_nemsio%reclevtyp(10) = 'nom. top' - meta_nemsio%recname(11) = 'gflux_ave' - meta_nemsio%reclevtyp(11) = 'sfc' - meta_nemsio%recname(12) = 'hgt' - meta_nemsio%reclevtyp(12) = 'sfc' - meta_nemsio%recname(13) = 'hpbl' - meta_nemsio%reclevtyp(13) = 'sfc' - meta_nemsio%recname(14) = 'icec' - meta_nemsio%reclevtyp(14) = 'sfc' - meta_nemsio%recname(15) = 'land' - meta_nemsio%reclevtyp(15) = 'sfc' - meta_nemsio%recname(16) = 'lhtfl_ave' - meta_nemsio%reclevtyp(16) = 'sfc' - meta_nemsio%recname(17) = 'shtfl_ave' - meta_nemsio%reclevtyp(17) = 'sfc' - meta_nemsio%recname(18) = 'pres' - meta_nemsio%reclevtyp(18) = 'sfc' - meta_nemsio%recname(19) = 'pwat' - meta_nemsio%reclevtyp(19) = 'atmos col' - meta_nemsio%recname(20) = 'soilm' - meta_nemsio%reclevtyp(20) = '0-200 cm down' - meta_nemsio%recname(21) = 'soilw' - meta_nemsio%reclevtyp(21) = '0-10 cm down' - meta_nemsio%recname(22) = 'soilw' - meta_nemsio%reclevtyp(22) = '10-40 cm down' - meta_nemsio%recname(23) = 'soilw' - meta_nemsio%reclevtyp(23) = '40-100 cm down' - meta_nemsio%recname(24) = 'soilw' - meta_nemsio%reclevtyp(24) = '100-200 cm down' - meta_nemsio%recname(25) = 'spfh' - meta_nemsio%reclevtyp(25) = '2 m above gnd' - meta_nemsio%recname(26) = 'tmp' - meta_nemsio%reclevtyp(26) = '0-10 cm down' - meta_nemsio%recname(27) = 'tmp' - meta_nemsio%reclevtyp(27) = '10-40 cm down' - meta_nemsio%recname(28) = 'tmp' - meta_nemsio%reclevtyp(28) = '40-100 cm down' - meta_nemsio%recname(29) = 'tmp' - meta_nemsio%reclevtyp(29) = '100-200 cm down' - meta_nemsio%recname(30) = 'tmp' - meta_nemsio%reclevtyp(30) = '2 m above gnd' - meta_nemsio%recname(31) = 'tmp' - meta_nemsio%reclevtyp(31) = 'sfc' - meta_nemsio%recname(32) = 'ugwd' - meta_nemsio%reclevtyp(32) = 'sfc' - meta_nemsio%recname(33) = 'vgwd' - meta_nemsio%reclevtyp(33) = 'sfc' - meta_nemsio%recname(34) = 'uflx_ave' - meta_nemsio%reclevtyp(34) = 'sfc' - meta_nemsio%recname(35) = 'vflx_ave' - meta_nemsio%reclevtyp(35) = 'sfc' - meta_nemsio%recname(36) = 'ugrd' - meta_nemsio%reclevtyp(36) = '10 m above gnd' - meta_nemsio%recname(37) = 'vgrd' - meta_nemsio%reclevtyp(37) = '10 m above gnd' - meta_nemsio%recname(38) = 'weasd' - meta_nemsio%reclevtyp(38) = 'sfc' - meta_nemsio%recname(39) = 'snod' - meta_nemsio%reclevtyp(39) = 'sfc' - meta_nemsio%recname(40) = 'zorl' - meta_nemsio%reclevtyp(40) = 'sfc' - meta_nemsio%recname(41) = 'vfrac' - meta_nemsio%reclevtyp(41) = 'sfc' - meta_nemsio%recname(42) = 'f10m' - meta_nemsio%reclevtyp(42) = 'sfc' - meta_nemsio%recname(43) = 'vtype' - meta_nemsio%reclevtyp(43) = 'sfc' - meta_nemsio%recname(44) = 'stype' - meta_nemsio%reclevtyp(44) = 'sfc' - meta_nemsio%recname(45) = 'tcdc_ave' - meta_nemsio%reclevtyp(45) = 'atmos col' - meta_nemsio%recname(46) = 'tcdc_ave' - meta_nemsio%reclevtyp(46) = 'high cld lay' - meta_nemsio%recname(47) = 'tcdc_ave' - meta_nemsio%reclevtyp(47) = 'mid cld lay' - meta_nemsio%recname(48) = 'tcdc_ave' - meta_nemsio%reclevtyp(48) = 'low cld lay' -! loop through 3d variables - DO k = 1, nlevs - meta_nemsio%recname(k+nvar2d) = 'ugrd' - meta_nemsio%reclevtyp(k+nvar2d) = 'mid layer' - meta_nemsio%reclev(k+nvar2d) = k - meta_nemsio%recname(k+nvar2d+nlevs) = 'vgrd' - meta_nemsio%reclevtyp(k+nvar2d+nlevs) = 'mid layer' - meta_nemsio%reclev(k+nvar2d+nlevs) = k - meta_nemsio%recname(k+nvar2d+nlevs*2) = 'tmp' - meta_nemsio%reclevtyp(k+nvar2d+nlevs*2) = 'mid layer' - meta_nemsio%reclev(k+nvar2d+nlevs*2) = k - meta_nemsio%recname(k+nvar2d+nlevs*3) = 'spfh' - meta_nemsio%reclevtyp(k+nvar2d+nlevs*3) = 'mid layer' - meta_nemsio%reclev(k+nvar2d+nlevs*3) = k - meta_nemsio%recname(k+nvar2d+nlevs*4) = 'o3mr' - meta_nemsio%reclevtyp(k+nvar2d+nlevs*4) = 'mid layer' - meta_nemsio%reclev(k+nvar2d+nlevs*4) = k - meta_nemsio%recname(k+nvar2d+nlevs*5) = 'pres' - meta_nemsio%reclevtyp(k+nvar2d+nlevs*5) = 'mid layer' - meta_nemsio%reclev(k+nvar2d+nlevs*5) = k - meta_nemsio%recname(k+nvar2d+nlevs*6) = 'clwmr' - meta_nemsio%reclevtyp(k+nvar2d+nlevs*6) = 'mid layer' - meta_nemsio%reclev(k+nvar2d+nlevs*6) = k - meta_nemsio%recname(k+nvar2d+nlevs*7) = 'dpres' - meta_nemsio%reclevtyp(k+nvar2d+nlevs*7) = 'mid layer' - meta_nemsio%reclev(k+nvar2d+nlevs*7) = k - if (nvar3d == 9) then - meta_nemsio%recname(k+nvar2d+nlevs*8) = 'vvel' - meta_nemsio%reclevtyp(k+nvar2d+nlevs*8) = 'mid layer' - meta_nemsio%reclev(k+nvar2d+nlevs*8) = k - endif - ENDDO - - end subroutine define_nemsio_meta - - subroutine nems_write_init(datapath,filename_base,meta_nemsio,gfile) - - - implicit none - - type(nemsio_meta) :: meta_nemsio - character(len=200) :: datapath - character(len=100) :: filename_base - character(len=400) :: filename - type(nemsio_gfile) :: gfile - integer :: nemsio_iret - integer :: i, j, k - - write(filename,500) trim(datapath)//'/'//trim(filename_base) -500 format(a,i3.3) - print*,trim(filename) - call nemsio_init(iret=nemsio_iret) - print*,'iret=',nemsio_iret - !gfile%gtype = 'NEMSIO' - meta_nemsio%gdatatype = 'bin4' - call nemsio_open(gfile,trim(filename),'write', & - & iret=nemsio_iret, & - & modelname=trim(meta_nemsio%modelname), & - & version=meta_nemsio%version,gdatatype=meta_nemsio%gdatatype, & - & dimx=meta_nemsio%dimx,dimy=meta_nemsio%dimy, & - & dimz=meta_nemsio%dimz,rlon_min=meta_nemsio%rlon_min, & - & rlon_max=meta_nemsio%rlon_max,rlat_min=meta_nemsio%rlat_min, & - & rlat_max=meta_nemsio%rlat_max, & - & lon=meta_nemsio%lon,lat=meta_nemsio%lat, & - & idate=meta_nemsio%idate,nrec=meta_nemsio%nrec, & - & nframe=meta_nemsio%nframe,idrt=meta_nemsio%idrt,ncldt= & - & meta_nemsio%ncldt,idvc=meta_nemsio%idvc, & - & nfhour=meta_nemsio%nfhour,nfminute=meta_nemsio%nfminute, & - & nfsecondn=meta_nemsio%nfsecondn,nmeta=meta_nemsio%nmeta, & - & nfsecondd=meta_nemsio%nfsecondd,extrameta=.true., & - & nmetaaryi=meta_nemsio%nmetaaryi,recname=meta_nemsio%recname, & - & nmetavari=meta_nemsio%nmetavari,variname=meta_nemsio%variname, & - & varival=meta_nemsio%varival,varrval=meta_nemsio%varrval, & - & nmetavarr=meta_nemsio%nmetavarr,varrname=meta_nemsio%varrname, & - & reclevtyp=meta_nemsio%reclevtyp, & - & reclev=meta_nemsio%reclev,aryiname=meta_nemsio%aryiname, & - & aryilen=meta_nemsio%aryilen) - print*,'iret=',nemsio_iret - end subroutine nems_write_init - - -!------------------------------------------------------ - subroutine nems_write(gfile,recname,reclevtyp,level,dimx,data2d,iret) - - implicit none - type(nemsio_gfile) :: gfile - integer :: iret,level,dimx - real :: data2d(dimx) - character(nemsio_charkind) :: recname, reclevtyp - - call nemsio_writerecv(gfile,recname,levtyp=reclevtyp,lev=level,data=data2d,iret=iret) - if (iret.NE.0) then - print*,'error writing',recname,level,iret - STOP - ENDIF - - end subroutine nems_write - - -end module fv3_module diff --git a/sorc/fv3nc2nemsio.fd/kinds.f90 b/sorc/fv3nc2nemsio.fd/kinds.f90 deleted file mode 100644 index b3378bfccf..0000000000 --- a/sorc/fv3nc2nemsio.fd/kinds.f90 +++ /dev/null @@ -1,107 +0,0 @@ -! this module was extracted from the GSI version operational -! at NCEP in Dec. 2007. -module kinds -!$$$ module documentation block -! . . . . -! module: kinds -! prgmmr: treadon org: np23 date: 2004-08-15 -! -! abstract: Module to hold specification kinds for variable declaration. -! This module is based on (copied from) Paul vanDelst's -! type_kinds module found in the community radiative transfer -! model -! -! module history log: -! 2004-08-15 treadon -! -! Subroutines Included: -! -! Functions Included: -! -! remarks: -! The numerical data types defined in this module are: -! i_byte - specification kind for byte (1-byte) integer variable -! i_short - specification kind for short (2-byte) integer variable -! i_long - specification kind for long (4-byte) integer variable -! i_llong - specification kind for double long (8-byte) integer variable -! r_single - specification kind for single precision (4-byte) real variable -! r_double - specification kind for double precision (8-byte) real variable -! r_quad - specification kind for quad precision (16-byte) real variable -! -! i_kind - generic specification kind for default integer -! r_kind - generic specification kind for default floating point -! -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - implicit none - private - -! Integer type definitions below - -! Integer types - integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer - integer, parameter, public :: i_short = selected_int_kind(4) ! short integer - integer, parameter, public :: i_long = selected_int_kind(8) ! long integer - integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer - integer, parameter, public :: i_llong = max( llong_t, i_long ) - -! Expected 8-bit byte sizes of the integer kinds - integer, parameter, public :: num_bytes_for_i_byte = 1 - integer, parameter, public :: num_bytes_for_i_short = 2 - integer, parameter, public :: num_bytes_for_i_long = 4 - integer, parameter, public :: num_bytes_for_i_llong = 8 - -! Define arrays for default definition - integer, parameter, private :: num_i_kinds = 4 - integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & - i_byte, i_short, i_long, i_llong /) - integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & - num_bytes_for_i_byte, num_bytes_for_i_short, & - num_bytes_for_i_long, num_bytes_for_i_llong /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** - integer, parameter, private :: default_integer = 3 ! 1=byte, - ! 2=short, - ! 3=long, - ! 4=llong - integer, parameter, public :: i_kind = integer_types( default_integer ) - integer, parameter, public :: num_bytes_for_i_kind = & - integer_byte_sizes( default_integer ) - - -! Real definitions below - -! Real types - integer, parameter, public :: r_single = selected_real_kind(6) ! single precision - integer, parameter, public :: r_double = selected_real_kind(15) ! double precision - integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision - integer, parameter, public :: r_quad = max( quad_t, r_double ) - -! Expected 8-bit byte sizes of the real kinds - integer, parameter, public :: num_bytes_for_r_single = 4 - integer, parameter, public :: num_bytes_for_r_double = 8 - integer, parameter, public :: num_bytes_for_r_quad = 16 - -! Define arrays for default definition - integer, parameter, private :: num_r_kinds = 3 - integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & - r_single, r_double, r_quad /) - integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & - num_bytes_for_r_single, num_bytes_for_r_double, & - num_bytes_for_r_quad /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** - integer, parameter, private :: default_real = 1 ! 1=single, - ! 2=double, - ! 3=quad - integer, parameter, public :: r_kind = real_kinds( default_real ) - integer, parameter, public :: num_bytes_for_r_kind = & - real_byte_sizes( default_real ) - -end module kinds diff --git a/sorc/fv3nc2nemsio.fd/makefile.sh b/sorc/fv3nc2nemsio.fd/makefile.sh deleted file mode 100755 index 94b9b253cc..0000000000 --- a/sorc/fv3nc2nemsio.fd/makefile.sh +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/ksh -set -x - -machine=${1:-"cray"} - -source ../../modulefiles/module-setup.sh.inc -module use ../../modulefiles -module load modulefile.fv3nc2nemsio.$machine - -LIBnetcdf=`$NETCDF/bin/nf-config --flibs` -INCnetcdf=`$NETCDF/bin/nf-config --fflags` -export NETCDF_LDFLAGS=$LIBnetcdf -export NETCDF_INCLUDE=$INCnetcdf - - -$FCMP $FFLAGS -c kinds.f90 -$FCMP $FFLAGS -c constants.f90 -$FCMP $FFLAGS $NETCDF_INCLUDE -I $NEMSIO_INC -c fv3_module.f90 -$FCMP $FFLAGS $NETCDF_INCLUDE -I $NEMSIO_INC -I. -o fv3nc2nemsio.x fv3_main.f90 fv3_module.o $NETCDF_LDFLAGS $NEMSIO_LIB $BACIO_LIB4 $W3NCO_LIBd - -mv fv3nc2nemsio.x ../../exec/. -rm -f *.o *.mod - -exit 0 diff --git a/sorc/gaussian_sfcanl.fd/.gitignore b/sorc/gaussian_sfcanl.fd/.gitignore deleted file mode 100644 index 0a4391755c..0000000000 --- a/sorc/gaussian_sfcanl.fd/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -*.o -*.mod -*.exe diff --git a/sorc/gaussian_sfcanl.fd/CMakeLists.txt b/sorc/gaussian_sfcanl.fd/CMakeLists.txt deleted file mode 100644 index 6447fdaf6a..0000000000 --- a/sorc/gaussian_sfcanl.fd/CMakeLists.txt +++ /dev/null @@ -1,21 +0,0 @@ -list(APPEND fortran_src - gaussian_sfcanl.f90 -) - -if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -r8 -i4 -fp-model precise") -elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8") -endif() - -set(exe_name gaussian_sfcanl.x) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - nemsio::nemsio - bacio::bacio_4 - sp::sp_4 - w3nco::w3nco_d - NetCDF::NetCDF_Fortran) - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/gaussian_sfcanl.fd/Makefile b/sorc/gaussian_sfcanl.fd/Makefile deleted file mode 100755 index 69cd35f7ae..0000000000 --- a/sorc/gaussian_sfcanl.fd/Makefile +++ /dev/null @@ -1,22 +0,0 @@ -SHELL= /bin/sh - -CMD= gaussian_sfcanl.exe - -OBJS = gaussian_sfcanl.o - -build: $(CMD) - -$(CMD): $(OBJS) - $(FCOMP) $(FFLAGS) -I$(NEMSIO_INC) $(NETCDF_INCLUDE) -o $(CMD) $(OBJS) $(NETCDF_LDFLAGS_F) $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIBd) $(SP_LIB4) - -gaussian_sfcanl.o: gaussian_sfcanl.f90 - $(FCOMP) $(FFLAGS) -I$(NEMSIO_INC) $(NETCDF_INCLUDE) -c gaussian_sfcanl.f90 - -install: - cp ${CMD} ../../exec - -clean: - rm -f *.o *.mod ${CMD} ../../exec/${CMD} - -test: - @echo NO TESTS YET diff --git a/sorc/gaussian_sfcanl.fd/gaussian_sfcanl.f90 b/sorc/gaussian_sfcanl.fd/gaussian_sfcanl.f90 deleted file mode 100644 index acce575cd7..0000000000 --- a/sorc/gaussian_sfcanl.fd/gaussian_sfcanl.f90 +++ /dev/null @@ -1,2093 +0,0 @@ -!------------------------------------------------------------------ -! -! Read in surface and nst data on the cubed-sphere grid, -! interpolate it to the gaussian grid, and output the result -! to a nemsio or netcdf file. To not process nst data, -! set flag 'donst' to 'no'. To process nst, set to 'yes'. -! To output gaussian file in netcdf, set netcdf_out=.true. -! Otherwise, nemsio format will be output. -! -! Input files: -! ------------ -! weights.nc Interpolation weights. netcdf format -! anal.tile[1-6].nc fv3 surface restart files -! orog.tile[1-6].nc fv3 orography files -! fort.41 namelist Configuration namelist -! vcoord.txt Vertical coordinate definition file -! (ascii) -! -! Output files: -! ------------- -! sfc.gaussian.analysis.file surface data on gaussian grid - -! nemsio or netcdf. -! -! Namelist variables: -! ------------------- -! yy/mm/dd/hh year/month/day/hour of data. -! i/jgaus i/j dimension of gaussian grid. -! donst When 'no' do not process nst data. -! When 'yes' process nst data. -! netcdf_out When 'true', output gaussian file in -! netcdf. Otherwise output nemsio format. -! -! 2018-Jan-30 Gayno Initial version -! 2019-Oct-30 Gayno Option to output gaussian analysis file -! in netcdf. -! -!------------------------------------------------------------------ - - module io - - use nemsio_module - - implicit none - - character(len=3) :: donst - - integer, parameter :: num_tiles = 6 - - integer :: itile, jtile, igaus, jgaus - - integer(nemsio_intkind) :: idate(8) - - type :: sfc_data -! surface variables - real, allocatable :: alvsf(:) - real, allocatable :: alvwf(:) - real, allocatable :: alnsf(:) - real, allocatable :: alnwf(:) - real, allocatable :: canopy(:) - real, allocatable :: facsf(:) - real, allocatable :: facwf(:) - real, allocatable :: ffhh(:) - real, allocatable :: ffmm(:) - real, allocatable :: fice(:) - real, allocatable :: f10m(:) - real, allocatable :: hice(:) - real, allocatable :: q2m(:) - real, allocatable :: orog(:) - real, allocatable :: sheleg(:) - real, allocatable :: slmask(:) - real, allocatable :: shdmax(:) - real, allocatable :: shdmin(:) - real, allocatable :: slope(:) - real, allocatable :: srflag(:) - real, allocatable :: snoalb(:) - real, allocatable :: snwdph(:) - real, allocatable :: stype(:) - real, allocatable :: t2m(:) - real, allocatable :: tprcp(:) - real, allocatable :: tisfc(:) - real, allocatable :: tsea(:) - real, allocatable :: tg3(:) - real, allocatable :: uustar(:) - real, allocatable :: vfrac(:) - real, allocatable :: vtype(:) - real, allocatable :: zorl(:) - real, allocatable :: slc(:,:) - real, allocatable :: smc(:,:) - real, allocatable :: stc(:,:) -! nst variables - real, allocatable :: c0(:) - real, allocatable :: cd(:) - real, allocatable :: dconv(:) - real, allocatable :: dtcool(:) - real, allocatable :: land(:) - real, allocatable :: qrain(:) - real, allocatable :: tref(:) - real, allocatable :: w0(:) - real, allocatable :: wd(:) - real, allocatable :: xs(:) - real, allocatable :: xt(:) - real, allocatable :: xtts(:) - real, allocatable :: xu(:) - real, allocatable :: xv(:) - real, allocatable :: xz(:) - real, allocatable :: xzts(:) - real, allocatable :: zc(:) - end type sfc_data - - type(sfc_data) :: tile_data, gaussian_data - - end module io - -!------------------------------------------------------------------------------ -! Main program -!------------------------------------------------------------------------------ - - program main - - use netcdf - use io - - implicit none - - character(len=12) :: weightfile - - integer :: i, error, ncid, id_ns, n_s - integer :: id_col, id_row, id_s, n - integer :: yy, mm, dd, hh - integer, allocatable :: col(:), row(:) - - logical :: netcdf_out - - real(kind=8), allocatable :: s(:) - - namelist /setup/ yy, mm, dd, hh, igaus, jgaus, donst, netcdf_out - - call w3tagb('GAUSSIAN_SFCANL',2018,0179,0055,'NP20') - - print*,"- BEGIN EXECUTION" - - netcdf_out = .true. - - donst = 'no' - - print* - print*,"- READ SETUP NAMELIST" - open(41, file="./fort.41") - read(41, nml=setup, iostat=error) - if (error /= 0) then - print*,"** FATAL ERROR READING NAMELIST. ISTAT IS: ", error - call errexit(56) - endif - close (41) - - idate = 0 - idate(1) = yy - idate(2) = mm - idate(3) = dd - idate(4) = hh - -!------------------------------------------------------------------------------ -! Read interpolation weight file. -!------------------------------------------------------------------------------ - - print* - print*,"- READ INTERPOLATION WEIGHT FILE" - - weightfile = "./weights.nc" - - error=nf90_open(trim(weightfile),nf90_nowrite,ncid) - call netcdf_err(error, 'OPENING weights.nc' ) - - error=nf90_inq_dimid(ncid, 'n_s', id_ns) - call netcdf_err(error, 'READING n_s id' ) - error=nf90_inquire_dimension(ncid,id_ns,len=n_s) - call netcdf_err(error, 'READING n_s' ) - - allocate(col(n_s)) - error=nf90_inq_varid(ncid, 'col', id_col) - call netcdf_err(error, 'READING col id' ) - error=nf90_get_var(ncid, id_col, col) - call netcdf_err(error, 'READING col' ) - - allocate(row(n_s)) - error=nf90_inq_varid(ncid, 'row', id_row) - call netcdf_err(error, 'READING row id' ) - error=nf90_get_var(ncid, id_row, row) - call netcdf_err(error, 'READING row' ) - - allocate(s(n_s)) - error=nf90_inq_varid(ncid, 'S', id_s) - call netcdf_err(error, 'READING s id' ) - error=nf90_get_var(ncid, id_s, s) - call netcdf_err(error, 'READING s' ) - - error = nf90_close(ncid) - -!------------------------------------------------------------------------------ -! Read the tiled analysis data. -!------------------------------------------------------------------------------ - - call read_data_anl - -!------------------------------------------------------------------------------ -! Interpolate tiled data to gaussian grid. -!------------------------------------------------------------------------------ - - allocate(gaussian_data%orog(igaus*jgaus)) ! sfc - allocate(gaussian_data%t2m(igaus*jgaus)) - allocate(gaussian_data%tisfc(igaus*jgaus)) - allocate(gaussian_data%q2m(igaus*jgaus)) - allocate(gaussian_data%stype(igaus*jgaus)) - allocate(gaussian_data%snwdph(igaus*jgaus)) - allocate(gaussian_data%slope(igaus*jgaus)) - allocate(gaussian_data%shdmax(igaus*jgaus)) - allocate(gaussian_data%shdmin(igaus*jgaus)) - allocate(gaussian_data%snoalb(igaus*jgaus)) - allocate(gaussian_data%slmask(igaus*jgaus)) - allocate(gaussian_data%tg3(igaus*jgaus)) - allocate(gaussian_data%alvsf(igaus*jgaus)) - allocate(gaussian_data%alvwf(igaus*jgaus)) - allocate(gaussian_data%alnsf(igaus*jgaus)) - allocate(gaussian_data%alnwf(igaus*jgaus)) - allocate(gaussian_data%facsf(igaus*jgaus)) - allocate(gaussian_data%facwf(igaus*jgaus)) - allocate(gaussian_data%ffhh(igaus*jgaus)) - allocate(gaussian_data%ffmm(igaus*jgaus)) - allocate(gaussian_data%sheleg(igaus*jgaus)) - allocate(gaussian_data%canopy(igaus*jgaus)) - allocate(gaussian_data%vfrac(igaus*jgaus)) - allocate(gaussian_data%vtype(igaus*jgaus)) - allocate(gaussian_data%zorl(igaus*jgaus)) - allocate(gaussian_data%tsea(igaus*jgaus)) - allocate(gaussian_data%f10m(igaus*jgaus)) - allocate(gaussian_data%tprcp(igaus*jgaus)) - allocate(gaussian_data%uustar(igaus*jgaus)) - allocate(gaussian_data%fice(igaus*jgaus)) - allocate(gaussian_data%hice(igaus*jgaus)) - allocate(gaussian_data%srflag(igaus*jgaus)) - allocate(gaussian_data%slc(igaus*jgaus,4)) - allocate(gaussian_data%smc(igaus*jgaus,4)) - allocate(gaussian_data%stc(igaus*jgaus,4)) - - if (trim(donst) == "yes" .or. trim(donst) == "YES") then - allocate(gaussian_data%c0(igaus*jgaus)) ! nst - allocate(gaussian_data%cd(igaus*jgaus)) - allocate(gaussian_data%dconv(igaus*jgaus)) - allocate(gaussian_data%dtcool(igaus*jgaus)) - allocate(gaussian_data%land(igaus*jgaus)) - allocate(gaussian_data%qrain(igaus*jgaus)) - allocate(gaussian_data%tref(igaus*jgaus)) - allocate(gaussian_data%w0(igaus*jgaus)) - allocate(gaussian_data%wd(igaus*jgaus)) - allocate(gaussian_data%xs(igaus*jgaus)) - allocate(gaussian_data%xt(igaus*jgaus)) - allocate(gaussian_data%xtts(igaus*jgaus)) - allocate(gaussian_data%xu(igaus*jgaus)) - allocate(gaussian_data%xv(igaus*jgaus)) - allocate(gaussian_data%xz(igaus*jgaus)) - allocate(gaussian_data%xzts(igaus*jgaus)) - allocate(gaussian_data%zc(igaus*jgaus)) - endif - - do i = 1, n_s - gaussian_data%orog(row(i)) = gaussian_data%orog(row(i)) + s(i)*tile_data%orog(col(i)) - gaussian_data%t2m(row(i)) = gaussian_data%t2m(row(i)) + s(i)*tile_data%t2m(col(i)) - gaussian_data%tisfc(row(i)) = gaussian_data%tisfc(row(i)) + s(i)*tile_data%tisfc(col(i)) - gaussian_data%q2m(row(i)) = gaussian_data%q2m(row(i)) + s(i)*tile_data%q2m(col(i)) - gaussian_data%stype(row(i)) = gaussian_data%stype(row(i)) + s(i)*tile_data%stype(col(i)) - gaussian_data%snwdph(row(i)) = gaussian_data%snwdph(row(i)) + s(i)*tile_data%snwdph(col(i)) - gaussian_data%slope(row(i)) = gaussian_data%slope(row(i)) + s(i)*tile_data%slope(col(i)) - gaussian_data%shdmax(row(i)) = gaussian_data%shdmax(row(i)) + s(i)*tile_data%shdmax(col(i)) - gaussian_data%shdmin(row(i)) = gaussian_data%shdmin(row(i)) + s(i)*tile_data%shdmin(col(i)) - gaussian_data%slmask(row(i)) = gaussian_data%slmask(row(i)) + s(i)*tile_data%slmask(col(i)) - gaussian_data%tg3(row(i)) = gaussian_data%tg3(row(i)) + s(i)*tile_data%tg3(col(i)) - gaussian_data%alvsf(row(i)) = gaussian_data%alvsf(row(i)) + s(i)*tile_data%alvsf(col(i)) - gaussian_data%alvwf(row(i)) = gaussian_data%alvwf(row(i)) + s(i)*tile_data%alvwf(col(i)) - gaussian_data%alnsf(row(i)) = gaussian_data%alnsf(row(i)) + s(i)*tile_data%alnsf(col(i)) - gaussian_data%alnwf(row(i)) = gaussian_data%alnwf(row(i)) + s(i)*tile_data%alnwf(col(i)) - gaussian_data%sheleg(row(i)) = gaussian_data%sheleg(row(i)) + s(i)*tile_data%sheleg(col(i)) - gaussian_data%canopy(row(i)) = gaussian_data%canopy(row(i)) + s(i)*tile_data%canopy(col(i)) - gaussian_data%vfrac(row(i)) = gaussian_data%vfrac(row(i)) + s(i)*tile_data%vfrac(col(i)) - gaussian_data%zorl(row(i)) = gaussian_data%zorl(row(i)) + s(i)*tile_data%zorl(col(i)) - gaussian_data%tsea(row(i)) = gaussian_data%tsea(row(i)) + s(i)*tile_data%tsea(col(i)) - gaussian_data%f10m(row(i)) = gaussian_data%f10m(row(i)) + s(i)*tile_data%f10m(col(i)) - gaussian_data%vtype(row(i)) = gaussian_data%vtype(row(i)) + s(i)*tile_data%vtype(col(i)) - gaussian_data%tprcp(row(i)) = gaussian_data%tprcp(row(i)) + s(i)*tile_data%tprcp(col(i)) - gaussian_data%facsf(row(i)) = gaussian_data%facsf(row(i)) + s(i)*tile_data%facsf(col(i)) - gaussian_data%facwf(row(i)) = gaussian_data%facwf(row(i)) + s(i)*tile_data%facwf(col(i)) - gaussian_data%ffhh(row(i)) = gaussian_data%ffhh(row(i)) + s(i)*tile_data%ffhh(col(i)) - gaussian_data%ffmm(row(i)) = gaussian_data%ffmm(row(i)) + s(i)*tile_data%ffmm(col(i)) - gaussian_data%uustar(row(i)) = gaussian_data%uustar(row(i)) + s(i)*tile_data%uustar(col(i)) - gaussian_data%fice(row(i)) = gaussian_data%fice(row(i)) + s(i)*tile_data%fice(col(i)) - gaussian_data%hice(row(i)) = gaussian_data%hice(row(i)) + s(i)*tile_data%hice(col(i)) - gaussian_data%snoalb(row(i)) = gaussian_data%snoalb(row(i)) + s(i)*tile_data%snoalb(col(i)) - gaussian_data%srflag(row(i)) = gaussian_data%srflag(row(i)) + s(i)*tile_data%srflag(col(i)) - if (trim(donst) == "yes" .or. trim(donst) == "YES") then - gaussian_data%c0(row(i)) = gaussian_data%c0(row(i)) + s(i)*tile_data%c0(col(i)) - gaussian_data%cd(row(i)) = gaussian_data%cd(row(i)) + s(i)*tile_data%cd(col(i)) - gaussian_data%dconv(row(i)) = gaussian_data%dconv(row(i)) + s(i)*tile_data%dconv(col(i)) - gaussian_data%dtcool(row(i)) = gaussian_data%dtcool(row(i)) + s(i)*tile_data%dtcool(col(i)) - gaussian_data%qrain(row(i)) = gaussian_data%qrain(row(i)) + s(i)*tile_data%qrain(col(i)) - gaussian_data%tref(row(i)) = gaussian_data%tref(row(i)) + s(i)*tile_data%tref(col(i)) - gaussian_data%w0(row(i)) = gaussian_data%w0(row(i)) + s(i)*tile_data%w0(col(i)) - gaussian_data%wd(row(i)) = gaussian_data%wd(row(i)) + s(i)*tile_data%wd(col(i)) - gaussian_data%xs(row(i)) = gaussian_data%xs(row(i)) + s(i)*tile_data%xs(col(i)) - gaussian_data%xt(row(i)) = gaussian_data%xt(row(i)) + s(i)*tile_data%xt(col(i)) - gaussian_data%xtts(row(i)) = gaussian_data%xtts(row(i)) + s(i)*tile_data%xtts(col(i)) - gaussian_data%xu(row(i)) = gaussian_data%xu(row(i)) + s(i)*tile_data%xu(col(i)) - gaussian_data%xv(row(i)) = gaussian_data%xv(row(i)) + s(i)*tile_data%xv(col(i)) - gaussian_data%xz(row(i)) = gaussian_data%xz(row(i)) + s(i)*tile_data%xz(col(i)) - gaussian_data%xzts(row(i)) = gaussian_data%xzts(row(i)) + s(i)*tile_data%xzts(col(i)) - gaussian_data%zc(row(i)) = gaussian_data%zc(row(i)) + s(i)*tile_data%zc(col(i)) - endif - do n = 1, 4 - gaussian_data%slc(row(i),n) = gaussian_data%slc(row(i),n) + s(i)*tile_data%slc(col(i),n) - gaussian_data%smc(row(i),n) = gaussian_data%smc(row(i),n) + s(i)*tile_data%smc(col(i),n) - gaussian_data%stc(row(i),n) = gaussian_data%stc(row(i),n) + s(i)*tile_data%stc(col(i),n) - enddo - enddo - - deallocate(col, row, s) - - deallocate(tile_data%orog) - deallocate(tile_data%t2m) - deallocate(tile_data%tisfc) - deallocate(tile_data%q2m) - deallocate(tile_data%stype) - deallocate(tile_data%snwdph) - deallocate(tile_data%slope) - deallocate(tile_data%shdmax) - deallocate(tile_data%shdmin) - deallocate(tile_data%snoalb) - deallocate(tile_data%slmask) - deallocate(tile_data%tg3) - deallocate(tile_data%alvsf) - deallocate(tile_data%alvwf) - deallocate(tile_data%alnsf) - deallocate(tile_data%alnwf) - deallocate(tile_data%facsf) - deallocate(tile_data%facwf) - deallocate(tile_data%ffhh) - deallocate(tile_data%ffmm) - deallocate(tile_data%sheleg) - deallocate(tile_data%canopy) - deallocate(tile_data%vfrac) - deallocate(tile_data%vtype) - deallocate(tile_data%zorl) - deallocate(tile_data%tsea) - deallocate(tile_data%f10m) - deallocate(tile_data%tprcp) - deallocate(tile_data%uustar) - deallocate(tile_data%fice) - deallocate(tile_data%hice) - deallocate(tile_data%srflag) - deallocate(tile_data%slc) - deallocate(tile_data%smc) - deallocate(tile_data%stc) - - if (trim(donst) == "yes" .or. trim(donst) == "YES") then - deallocate(tile_data%c0) - deallocate(tile_data%cd) - deallocate(tile_data%dconv) - deallocate(tile_data%dtcool) - deallocate(tile_data%qrain) - deallocate(tile_data%tref) - deallocate(tile_data%w0) - deallocate(tile_data%wd) - deallocate(tile_data%xs) - deallocate(tile_data%xt) - deallocate(tile_data%xtts) - deallocate(tile_data%xu) - deallocate(tile_data%xv) - deallocate(tile_data%xz) - deallocate(tile_data%xzts) - deallocate(tile_data%zc) - endif - -!------------------------------------------------------------------------------ -! Write gaussian data to either netcdf or nemsio file. -!------------------------------------------------------------------------------ - - if (netcdf_out) then - call write_sfc_data_netcdf - else - call write_sfc_data_nemsio - endif - - deallocate(gaussian_data%orog) - deallocate(gaussian_data%t2m) - deallocate(gaussian_data%tisfc) - deallocate(gaussian_data%q2m) - deallocate(gaussian_data%stype) - deallocate(gaussian_data%snwdph) - deallocate(gaussian_data%slope) - deallocate(gaussian_data%shdmax) - deallocate(gaussian_data%shdmin) - deallocate(gaussian_data%snoalb) - deallocate(gaussian_data%slmask) - deallocate(gaussian_data%tg3) - deallocate(gaussian_data%alvsf) - deallocate(gaussian_data%alvwf) - deallocate(gaussian_data%alnsf) - deallocate(gaussian_data%alnwf) - deallocate(gaussian_data%facsf) - deallocate(gaussian_data%facwf) - deallocate(gaussian_data%ffhh) - deallocate(gaussian_data%ffmm) - deallocate(gaussian_data%sheleg) - deallocate(gaussian_data%canopy) - deallocate(gaussian_data%vfrac) - deallocate(gaussian_data%vtype) - deallocate(gaussian_data%zorl) - deallocate(gaussian_data%tsea) - deallocate(gaussian_data%f10m) - deallocate(gaussian_data%tprcp) - deallocate(gaussian_data%uustar) - deallocate(gaussian_data%fice) - deallocate(gaussian_data%hice) - deallocate(gaussian_data%srflag) - deallocate(gaussian_data%slc) - deallocate(gaussian_data%smc) - deallocate(gaussian_data%stc) - - if (trim(donst) == "yes" .or. trim(donst) == "YES") then - deallocate(gaussian_data%c0) - deallocate(gaussian_data%cd) - deallocate(gaussian_data%dconv) - deallocate(gaussian_data%dtcool) - deallocate(gaussian_data%land) - deallocate(gaussian_data%qrain) - deallocate(gaussian_data%tref) - deallocate(gaussian_data%w0) - deallocate(gaussian_data%wd) - deallocate(gaussian_data%xs) - deallocate(gaussian_data%xt) - deallocate(gaussian_data%xtts) - deallocate(gaussian_data%xu) - deallocate(gaussian_data%xv) - deallocate(gaussian_data%xz) - deallocate(gaussian_data%xzts) - deallocate(gaussian_data%zc) - endif - - print* - print*,'- NORMAL TERMINATION' - - call w3tage('GAUSSIAN_SFCANL') - - end program main - -!------------------------------------------------------------------------------------------- -! Write gaussian surface data to netcdf file. -!------------------------------------------------------------------------------------------- - - subroutine write_sfc_data_netcdf - - use netcdf - use io - - implicit none - - character(len=50) :: outfile - character(len=31) :: date_string - character(len=4) :: year - character(len=2) :: mon, day, hour - - integer :: header_buffer_val = 16384 - integer :: i, error, ncid, dim_xt, dim_yt, dim_time - integer :: id_xt, id_yt, id_lon, id_lat, id_time - integer :: n - -! noah variables - integer, parameter :: num_noah=44 - character(len=30) :: noah_var(num_noah) - character(len=70) :: noah_name(num_noah) - character(len=30) :: noah_units(num_noah) - -! nst variables - integer, parameter :: num_nst=16 - character(len=30) :: nst_var(num_nst) - character(len=70) :: nst_name(num_nst) - character(len=30) :: nst_units(num_nst) - -! variables to be output - integer :: num_vars - character(len=30), allocatable :: var(:) - character(len=70), allocatable :: name(:) - character(len=30), allocatable :: units(:) - integer, allocatable :: id_var(:) - - real, parameter :: missing = 9.99e20 - - real(kind=4), allocatable :: dummy(:,:), slat(:), wlat(:) - -! define noah fields - - data noah_var /"alnsf", & - "alnwf", & - "alvsf", & - "alvwf", & - "cnwat", & - "crain",& - "f10m", & - "facsf", & - "facwf", & - "ffhh", & - "ffmm", & - "fricv", & - "icec", & - "icetk", & - "land", & - "orog", & - "sfcr", & - "shdmax", & - "shdmin", & - "sltyp", & - "snoalb", & - "snod", & - "soill1", & - "soill2", & - "soill3", & - "soill4", & - "soilt1", & - "soilt2", & - "soilt3", & - "soilt4", & - "soilw1", & - "soilw2", & - "soilw3", & - "soilw4", & - "sotyp", & - "spfh2m", & - "tg3" , & - "tisfc", & - "tmp2m", & - "tmpsfc", & - "tprcp", & - "veg", & - "vtype", & - "weasd" / - - data noah_name /"mean nir albedo with strong cosz dependency", & - "mean nir albedo with weak cosz dependency", & - "mean vis albedo with strong cosz dependency", & - "mean vis albedo with weak cosz dependency", & - "canopy water (cnwat in gfs data)" , & - "instantaneous categorical rain", & - "10-meter wind speed divided by lowest model wind speed", & - "fractional coverage with strong cosz dependency", & - "fractional coverage with weak cosz dependency", & - "fh parameter from PBL scheme" , & - "fm parameter from PBL scheme" , & - "uustar surface frictional wind", & - "surface ice concentration (ice=1; no ice=0)", & - "sea ice thickness (icetk in gfs_data)", & - "sea-land-ice mask (0-sea, 1-land, 2-ice)", & - "surface geopotential height", & - "surface roughness", & - "maximum fractional coverage of green vegetation", & - "minimum fractional coverage of green vegetation", & - "surface slope type" , & - "maximum snow albedo in fraction", & - "surface snow depth", & - "liquid soil moisture at layer-1", & - "liquid soil moisture at layer-2", & - "liquid soil moisture at layer-3", & - "liquid soil moisture at layer-4", & - "soil temperature 0-10cm", & - "soil temperature 10-40cm", & - "soil temperature 40-100cm", & - "soil temperature 100-200cm", & - "volumetric soil moisture 0-10cm", & - "volumetric soil moisture 10-40cm", & - "volumetric soil moisture 40-100cm", & - "volumetric soil moisture 100-200cm", & - "soil type in integer", & - "2m specific humidity" , & - "deep soil temperature" , & - "surface temperature over ice fraction", & - "2m temperature", & - "surface temperature", & - "total precipitation" , & - "vegetation fraction", & - "vegetation type in integer", & - "surface snow water equivalent" / - - data noah_units /"%", & - "%", & - "%", & - "%", & - "XXX", & - "number", & - "N/A", & - "XXX", & - "XXX", & - "XXX", & - "XXX", & - "XXX", & - "fraction", & - "XXX", & - "numerical", & - "gpm", & - "m", & - "XXX", & - "XXX", & - "XXX", & - "XXX", & - "m", & - "XXX", & - "XXX", & - "XXX", & - "XXX", & - "K", & - "K", & - "K", & - "K", & - "fraction", & - "fraction", & - "fraction", & - "fraction", & - "number", & - "kg/kg", & - "K", & - "K", & - "K", & - "K", & - "kg/m**2", & - "fraction", & - "number" , & - "kg/m**2" / - -! define nst fields - - data nst_var /"c0", & - "cd", & - "dconv", & - "dtcool", & - "qrain", & - "tref", & - "w0", & - "wd", & - "xs", & - "xt", & - "xtts", & - "xu", & - "xv", & - "xz", & - "xzts", & - "zc" / - - data nst_name /"nsst coefficient1 to calculate d(tz)/d(ts)", & - "nsst coefficient2 to calculate d(tz)/d(ts)", & - "nsst thickness of free convection layer", & - "nsst sub-layer cooling amount", & - "nsst sensible heat flux due to rainfall", & - "nsst reference or foundation temperature", & - "nsst coefficient3 to calculate d(tz)/d(ts)", & - "nsst coefficient4 to calculate d(tz)/d(ts)", & - "nsst salinity content in diurnal thermocline layer", & - "nsst heat content in diurnal thermocline layer", & - "nsst d(xt)/d(ts)", & - "nsst u-current content in diurnal thermocline layer", & - "nsst v-current content in diurnal thermocline layer", & - "nsst diurnal thermocline layer thickness", & - "nsst d(xt)/d(ts)", & - "nsst sub-layer cooling thickness"/ - - data nst_units /"numerical", & - "n/a", & - "m", & - "k", & - "w/m2", & - "K", & - "n/a", & - "n/a", & - "n/a", & - "k*m", & - "m", & - "m2/s", & - "m2/s", & - "m", & - "m/k", & - "m"/ - - outfile = "./sfc.gaussian.analysis.file" - - print*,"- WRITE SURFACE DATA TO NETCDF FILE: ", trim(outfile) - - error = nf90_create(outfile, cmode=IOR(IOR(NF90_CLOBBER,NF90_NETCDF4),NF90_CLASSIC_MODEL), ncid=ncid) - call netcdf_err(error, 'CREATING NETCDF FILE') - -! dimensions - - error = nf90_def_dim(ncid, 'grid_xt', igaus, dim_xt) - call netcdf_err(error, 'DEFINING GRID_XT DIMENSION') - - error = nf90_def_dim(ncid, 'grid_yt', jgaus, dim_yt) - call netcdf_err(error, 'DEFINING GRID_YT DIMENSION') - - error = nf90_def_dim(ncid, 'time', 1, dim_time) - call netcdf_err(error, 'DEFINING TIME DIMENSION') - -! global attributes - - error = nf90_put_att(ncid, nf90_global, 'nsoil', 4) - call netcdf_err(error, 'DEFINING NSOIL ATTRIBUTE') - - error = nf90_put_att(ncid, nf90_global, 'source', "FV3GFS") - call netcdf_err(error, 'DEFINING SOURCE ATTRIBUTE') - - error = nf90_put_att(ncid, nf90_global, 'grid', "gaussian") - call netcdf_err(error, 'DEFINING GRID ATTRIBUTE') - - error = nf90_put_att(ncid, nf90_global, 'im', igaus) - call netcdf_err(error, 'DEFINING IM ATTRIBUTE') - - error = nf90_put_att(ncid, nf90_global, 'jm', jgaus) - call netcdf_err(error, 'DEFINING JM ATTRIBUTE') - -! variables - -! grid_xt - - error = nf90_def_var(ncid, 'grid_xt', NF90_DOUBLE, dim_xt, id_xt) - call netcdf_err(error, 'DEFINING GRID_XT') - - error = nf90_put_att(ncid, id_xt, "cartesian_axis", "X") - call netcdf_err(error, 'DEFINING GRID_XT ATTRIBUTE') - - error = nf90_put_att(ncid, id_xt, "long_name", "T-cell longitude") - call netcdf_err(error, 'DEFINING GRID_XT ATTRIBUTE') - - error = nf90_put_att(ncid, id_xt, "units", "degrees_E") - call netcdf_err(error, 'DEFINING GRID_XT ATTRIBUTE') - -! lon - - error = nf90_def_var(ncid, 'lon', NF90_DOUBLE, (/dim_xt,dim_yt/), id_lon) - call netcdf_err(error, 'DEFINING LON') - - error = nf90_put_att(ncid, id_lon, "long_name", "T-cell longitude") - call netcdf_err(error, 'DEFINING LON ATTRIBUTE') - - error = nf90_put_att(ncid, id_lon, "units", "degrees_E") - call netcdf_err(error, 'DEFINING LON ATTRIBUTE') - -! grid_yt - - error = nf90_def_var(ncid, 'grid_yt', NF90_DOUBLE, dim_yt, id_yt) - call netcdf_err(error, 'DEFINING GRID_YT') - - error = nf90_put_att(ncid, id_yt, "cartesian_axis", "Y") - call netcdf_err(error, 'DEFINING GRID_YT ATTRIBUTE') - - error = nf90_put_att(ncid, id_yt, "long_name", "T-cell latitude") - call netcdf_err(error, 'DEFINING GRID_YT ATTRIBUTE') - - error = nf90_put_att(ncid, id_yt, "units", "degrees_N") - call netcdf_err(error, 'DEFINING GRID_YT ATTRIBUTE') - -! lat - - error = nf90_def_var(ncid, 'lat', NF90_DOUBLE, (/dim_xt,dim_yt/), id_lat) - call netcdf_err(error, 'DEFINING LAT') - - error = nf90_put_att(ncid, id_lat, "long_name", "T-cell latitude") - call netcdf_err(error, 'DEFINING LAT ATTRIBUTE') - - error = nf90_put_att(ncid, id_lat, "units", "degrees_N") - call netcdf_err(error, 'DEFINING LAT ATTRIBUTE') - -! time - - error = nf90_def_var(ncid, 'time', NF90_DOUBLE, dim_time, id_time) - call netcdf_err(error, 'DEFINING TIME') - - error = nf90_put_att(ncid, id_time, "long_name", "time") - call netcdf_err(error, 'DEFINING TIME ATTRIBUTE') - - write(year, "(i4)") idate(1) - write(mon, "(i2.2)") idate(2) - write(day, "(i2.2)") idate(3) - write(hour, "(i2.2)") idate(4) - - date_string="hours since " // year // "-" // mon // "-" // day // " " // hour // ":00:00" - - error = nf90_put_att(ncid, id_time, "units", date_string) - call netcdf_err(error, 'DEFINING TIME ATTRIBUTE') - - error = nf90_put_att(ncid, id_time, "cartesian_axis", "T") - call netcdf_err(error, 'DEFINING TIME ATTRIBUTE') - - error = nf90_put_att(ncid, id_time, "calendar_type", "JULIAN") - call netcdf_err(error, 'DEFINING TIME ATTRIBUTE') - - error = nf90_put_att(ncid, id_time, "calendar", "JULIAN") - call netcdf_err(error, 'DEFINING TIME ATTRIBUTE') - -!------------------------------------------------------------------------------------------- -! Determine what variables to output (noah, or noah plus nst). -!------------------------------------------------------------------------------------------- - - if (trim(donst) == "yes" .or. trim(donst) == "YES") then - num_vars = num_noah + num_nst - else - num_vars = num_noah - endif - - allocate(var(num_vars)) - allocate(name(num_vars)) - allocate(units(num_vars)) - allocate(id_var(num_vars)) - - var(1:num_noah) = noah_var - name(1:num_noah) = noah_name - units(1:num_noah) = noah_units - - if (trim(donst) == "yes" .or. trim(donst) == "YES") then - do n = 1, num_nst - var(n+num_noah) = nst_var(n) - name(n+num_noah) = nst_name(n) - units(n+num_noah) = nst_units(n) - enddo - endif - -!------------------------------------------------------------------------------------------- -! Define variables in netcdf file. -!------------------------------------------------------------------------------------------- - - do n = 1, num_vars - - print*,'- DEFINE VARIABLE ',trim(var(n)) - error = nf90_def_var(ncid, trim(var(n)), NF90_FLOAT, (/dim_xt,dim_yt,dim_time/), id_var(n)) - call netcdf_err(error, 'DEFINING variable') - error = nf90_def_var_deflate(ncid, id_var(n), 1, 1, 1) - call netcdf_err(error, 'DEFINING variable with compression') - - error = nf90_put_att(ncid, id_var(n), "long_name", trim(name(n))) - call netcdf_err(error, 'DEFINING name ATTRIBUTE') - - error = nf90_put_att(ncid, id_var(n), "units", trim(units(n))) - call netcdf_err(error, 'DEFINING units ATTRIBUTE') - - error = nf90_put_att(ncid, id_var(n), "missing", missing) - call netcdf_err(error, 'DEFINING missing ATTRIBUTE') - - error = nf90_put_att(ncid, id_var(n), "cell_methods", "time: point") - call netcdf_err(error, 'DEFINING cell method ATTRIBUTE') - - error = nf90_put_att(ncid, id_var(n), "output_file", "sfc") - call netcdf_err(error, 'DEFINING out file ATTRIBUTE') - - enddo - -! end variable defs - - error = nf90_enddef(ncid, header_buffer_val,4,0,4) - call netcdf_err(error, 'DEFINING HEADER') - -!------------------------------------------------------------------------------------------- -! Write variables to netcdf file. -!------------------------------------------------------------------------------------------- - - allocate(dummy(igaus,jgaus)) - do i = 1, igaus - dummy(i,:) = real((i-1),4) * 360.0_4 / real(igaus,4) - enddo - - error = nf90_put_var(ncid, id_xt, dummy(:,1)) - call netcdf_err(error, 'WRITING GRID_XT') - - error = nf90_put_var(ncid, id_lon, dummy) - call netcdf_err(error, 'WRITING LON') - - allocate(slat(jgaus)) - allocate(wlat(jgaus)) - call splat(4, jgaus, slat, wlat) - - do i = (jgaus/2+1), jgaus - dummy(:,i) = 90.0 - (acos(slat(i)) * 180.0 / (4.0*atan(1.0))) - enddo - - do i = 1, (jgaus/2) - dummy(:,i) = -(dummy(:,(jgaus-i+1))) - enddo - - deallocate(slat, wlat) - - error = nf90_put_var(ncid, id_yt, dummy(1,:)) - call netcdf_err(error, 'WRITING GRID_YT') - - error = nf90_put_var(ncid, id_lat, dummy) - call netcdf_err(error, 'WRITING LAT') - - error = nf90_put_var(ncid, id_time, 0) - call netcdf_err(error, 'WRITING TIME') - - do n = 1, num_vars - print*,'- WRITE VARIABLE ',trim(var(n)) - call get_netcdf_var(var(n), dummy) - error = nf90_put_var(ncid, id_var(n), dummy, start=(/1,1,1/), count=(/igaus,jgaus,1/)) - call netcdf_err(error, 'WRITING variable') - enddo - - deallocate (dummy) - - error = nf90_close(ncid) - - end subroutine write_sfc_data_netcdf - -!------------------------------------------------------------------------------------------- -! Retrieve variable based on its netcdf identifier. -!------------------------------------------------------------------------------------------- - - subroutine get_netcdf_var(var, dummy) - - use io - - implicit none - - character(len=*), intent(in) :: var - - real(kind=4), intent(out) :: dummy(igaus,jgaus) - - select case (var) - case ('alnsf') - dummy = reshape(gaussian_data%alnsf, (/igaus,jgaus/)) - case ('alnwf') - dummy = reshape(gaussian_data%alnwf, (/igaus,jgaus/)) - case ('alvsf') - dummy = reshape(gaussian_data%alvsf, (/igaus,jgaus/)) - case ('alvwf') - dummy = reshape(gaussian_data%alvwf, (/igaus,jgaus/)) - case ('cnwat') - dummy = reshape(gaussian_data%canopy, (/igaus,jgaus/)) - case ('f10m') - dummy = reshape(gaussian_data%f10m, (/igaus,jgaus/)) - case ('facsf') - dummy = reshape(gaussian_data%facsf, (/igaus,jgaus/)) - case ('facwf') - dummy = reshape(gaussian_data%facwf, (/igaus,jgaus/)) - case ('ffhh') - dummy = reshape(gaussian_data%ffhh, (/igaus,jgaus/)) - case ('ffmm') - dummy = reshape(gaussian_data%ffmm, (/igaus,jgaus/)) - case ('fricv') - dummy = reshape(gaussian_data%uustar, (/igaus,jgaus/)) - case ('land') - dummy = reshape(gaussian_data%slmask, (/igaus,jgaus/)) - case ('orog') - dummy = reshape(gaussian_data%orog, (/igaus,jgaus/)) - case ('sltyp') - dummy = reshape(gaussian_data%slope, (/igaus,jgaus/)) - case ('icec') - dummy = reshape(gaussian_data%fice, (/igaus,jgaus/)) - case ('icetk') - dummy = reshape(gaussian_data%hice, (/igaus,jgaus/)) - case ('snoalb') - dummy = reshape(gaussian_data%snoalb, (/igaus,jgaus/)) - case ('shdmin') - dummy = reshape(gaussian_data%shdmin, (/igaus,jgaus/)) - case ('shdmax') - dummy = reshape(gaussian_data%shdmax, (/igaus,jgaus/)) - case ('snod') - dummy = reshape(gaussian_data%snwdph, (/igaus,jgaus/)) / 1000.0 - case ('weasd') - dummy = reshape(gaussian_data%sheleg, (/igaus,jgaus/)) - case ('veg') - dummy = reshape(gaussian_data%vfrac, (/igaus,jgaus/)) * 100.0 - case ('sfcr') - dummy = reshape(gaussian_data%zorl, (/igaus,jgaus/)) / 100.0 - case ('crain') - dummy = reshape(gaussian_data%srflag, (/igaus,jgaus/)) - case ('sotyp') - dummy = reshape(gaussian_data%stype, (/igaus,jgaus/)) - case ('spfh2m') - dummy = reshape(gaussian_data%q2m, (/igaus,jgaus/)) - case ('tmp2m') - dummy = reshape(gaussian_data%t2m, (/igaus,jgaus/)) - case ('tmpsfc') - dummy = reshape(gaussian_data%tsea, (/igaus,jgaus/)) - case ('tg3') - dummy = reshape(gaussian_data%tg3, (/igaus,jgaus/)) - case ('tisfc') - dummy = reshape(gaussian_data%tisfc, (/igaus,jgaus/)) - case ('tprcp') - dummy = reshape(gaussian_data%tprcp, (/igaus,jgaus/)) - case ('vtype') - dummy = reshape(gaussian_data%vtype, (/igaus,jgaus/)) - case ('soill1') - dummy = reshape(gaussian_data%slc(:,1), (/igaus,jgaus/)) - where (dummy > 0.99) dummy = 0.0 ! replace flag value at water/landice - case ('soill2') - dummy = reshape(gaussian_data%slc(:,2), (/igaus,jgaus/)) - where (dummy > 0.99) dummy = 0.0 ! replace flag value at water/landice - case ('soill3') - dummy = reshape(gaussian_data%slc(:,3), (/igaus,jgaus/)) - where (dummy > 0.99) dummy = 0.0 ! replace flag value at water/landice - case ('soill4') - dummy = reshape(gaussian_data%slc(:,4), (/igaus,jgaus/)) - where (dummy > 0.99) dummy = 0.0 ! replace flag value at water/landice - case ('soilt1') - dummy = reshape(gaussian_data%stc(:,1), (/igaus,jgaus/)) - case ('soilt2') - dummy = reshape(gaussian_data%stc(:,2), (/igaus,jgaus/)) - case ('soilt3') - dummy = reshape(gaussian_data%stc(:,3), (/igaus,jgaus/)) - case ('soilt4') - dummy = reshape(gaussian_data%stc(:,4), (/igaus,jgaus/)) - case ('soilw1') - dummy = reshape(gaussian_data%smc(:,1), (/igaus,jgaus/)) - case ('soilw2') - dummy = reshape(gaussian_data%smc(:,2), (/igaus,jgaus/)) - case ('soilw3') - dummy = reshape(gaussian_data%smc(:,3), (/igaus,jgaus/)) - case ('soilw4') - dummy = reshape(gaussian_data%smc(:,4), (/igaus,jgaus/)) - case ('c0') - dummy = reshape(gaussian_data%c0, (/igaus,jgaus/)) - case ('cd') - dummy = reshape(gaussian_data%cd, (/igaus,jgaus/)) - case ('dconv') - dummy = reshape(gaussian_data%dconv, (/igaus,jgaus/)) - case ('dtcool') - dummy = reshape(gaussian_data%dtcool, (/igaus,jgaus/)) - case ('qrain') - dummy = reshape(gaussian_data%qrain, (/igaus,jgaus/)) - case ('tref') - dummy = reshape(gaussian_data%tref, (/igaus,jgaus/)) - case ('w0') - dummy = reshape(gaussian_data%w0, (/igaus,jgaus/)) - case ('wd') - dummy = reshape(gaussian_data%wd, (/igaus,jgaus/)) - case ('xs') - dummy = reshape(gaussian_data%xs, (/igaus,jgaus/)) - case ('xt') - dummy = reshape(gaussian_data%xt, (/igaus,jgaus/)) - case ('xtts') - dummy = reshape(gaussian_data%xtts, (/igaus,jgaus/)) - case ('xu') - dummy = reshape(gaussian_data%xu, (/igaus,jgaus/)) - case ('xv') - dummy = reshape(gaussian_data%xv, (/igaus,jgaus/)) - case ('xz') - dummy = reshape(gaussian_data%xz, (/igaus,jgaus/)) - case ('xzts') - dummy = reshape(gaussian_data%xzts, (/igaus,jgaus/)) - case ('zc') - dummy = reshape(gaussian_data%zc, (/igaus,jgaus/)) - case default - print*,'- FATAL ERROR: UNKNOWN VAR IN GET_VAR: ', var - call errexit(67) - end select - - end subroutine get_netcdf_var - -!------------------------------------------------------------------------------------------- -! Write gaussian surface data to nemsio file. -!------------------------------------------------------------------------------------------- - - subroutine write_sfc_data_nemsio - - use nemsio_module - use io - - implicit none - - integer(nemsio_intkind), parameter :: nrec_all=60 - integer(nemsio_intkind), parameter :: nmetaaryi=1 - integer(nemsio_intkind), parameter :: nmetavari=4 - integer(nemsio_intkind), parameter :: nmetavarr=1 - integer(nemsio_intkind), parameter :: nmetavarc=2 - - character(nemsio_charkind) :: recname_all(nrec_all) - character(nemsio_charkind) :: reclevtyp_all(nrec_all) - character(nemsio_charkind) :: aryiname(nmetaaryi) - character(nemsio_charkind) :: variname(nmetavari) - character(nemsio_charkind) :: varrname(nmetavarr) - character(nemsio_charkind) :: varcname(nmetavarc) - character(nemsio_charkind) :: varcval(nmetavarc) - character(nemsio_charkind), allocatable :: recname(:) - character(nemsio_charkind), allocatable :: reclevtyp(:) - - integer(nemsio_intkind) :: iret, version, nrec - integer(nemsio_intkind) :: reclev_all(nrec_all) - integer(nemsio_intkind) :: aryival(jgaus,nmetaaryi) - integer(nemsio_intkind) :: aryilen(nmetaaryi) - integer(nemsio_intkind) :: varival(nmetavari) - integer :: i, k, n, nvcoord, levs_vcoord - integer(nemsio_intkind), allocatable :: reclev(:) - - real(nemsio_realkind), allocatable :: the_data(:) - real(nemsio_realkind) :: varrval(nmetavarr) - real(nemsio_realkind), allocatable :: lat(:), lon(:) - real(kind=4), allocatable :: dummy(:,:), slat(:), wlat(:) - real(nemsio_realkind), allocatable :: vcoord(:,:,:) - - type(nemsio_gfile) :: gfileo - - data recname_all /'alnsf', 'alnwf', 'alvsf', 'alvwf', & - 'cnwat', 'crain', 'f10m', 'facsf', & - 'facwf', 'ffhh', 'ffmm', 'fricv', & - 'icec', 'icetk', 'land', 'orog', & - 'snoalb', 'sfcr', 'shdmax', 'shdmin', & - 'soill', 'soill', 'soill', 'soill', & - 'sltyp', 'soilw', 'soilw', 'soilw', & - 'soilw', 'snod', 'sotyp', 'spfh', & - 'tmp', 'tmp', 'tmp', 'tmp', & - 'tg3', 'ti', 'tmp', 'tmp', & - 'tprcp', 'veg', 'vtype', 'weasd', & - 'c0', 'cd', 'dconv', 'dtcool', & - 'qrain', 'tref', & - 'w0', 'wd', 'xs', 'xt', & - 'xtts', 'xu', 'xv', 'xz', & - 'xzts', 'zc'/ - - data reclevtyp_all /'sfc', 'sfc', 'sfc', 'sfc', & - 'sfc', 'sfc', '10 m above gnd', 'sfc', & - 'sfc', 'sfc', 'sfc', 'sfc', & - 'sfc', 'sfc', 'sfc', 'sfc', & - 'sfc', 'sfc', 'sfc', 'sfc', & - '0-10 cm down', '10-40 cm down', '40-100 cm down', '100-200 cm down', & - 'sfc', '0-10 cm down', '10-40 cm down', '40-100 cm down', & - '100-200 cm down', 'sfc', 'sfc', '2 m above gnd', & - '0-10 cm down', '10-40 cm down', '40-100 cm down', '100-200 cm down', & - 'sfc', 'sfc', '2 m above gnd', 'sfc', & - 'sfc', 'sfc', 'sfc', 'sfc', & - 'sfc', 'sfc', 'sfc', 'sfc', & - 'sfc', 'sfc', 'sfc', & - 'sfc', 'sfc', 'sfc', 'sfc', & - 'sfc', 'sfc', 'sfc', 'sfc', & - 'sfc'/ - - data reclev_all /1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1/ - - data aryiname /'lpl'/ - - data variname /'fhzero', 'ncld', 'nsoil', 'imp_physics'/ - - data varival /6, 5, 4, 11/ - - data varrname /'dtp'/ - - data varrval /225.0/ - - data varcname /"y-direction", "z-direction"/ - - data varcval /"north2south", "bottom2top"/ - - version = 200809 - - aryival = igaus ! reduced grid definition - aryilen = jgaus - - allocate(dummy(igaus,jgaus)) - do i = 1, igaus - dummy(i,:) = float(i-1) * 360.0 / float(igaus) - enddo - - allocate(lon(igaus*jgaus)) - lon = reshape (dummy, (/igaus*jgaus/) ) - -! Call 4-byte version of splib to match latitudes in history files. - - allocate(slat(jgaus)) - allocate(wlat(jgaus)) - call splat(4, jgaus, slat, wlat) - - do i = (jgaus/2+1), jgaus - dummy(:,i) = 90.0 - (acos(slat(i)) * 180.0 / (4.0*atan(1.0))) - enddo - - do i = 1, (jgaus/2) - dummy(:,i) = -(dummy(:,(jgaus-i+1))) - enddo - - deallocate(slat, wlat) - - allocate(lat(igaus*jgaus)) - lat = reshape (dummy, (/igaus*jgaus/) ) - - deallocate(dummy) - - print* - print*, "- OPEN VCOORD FILE." - open(14, file="vcoord.txt", form='formatted', iostat=iret) - if (iret /= 0) goto 43 - - print*, "- READ VCOORD FILE." - read(14, *, iostat=iret) nvcoord, levs_vcoord - if (iret /= 0) goto 43 - - allocate(vcoord(levs_vcoord,3,2)) - vcoord = 0.0 - read(14, *, iostat=iret) ((vcoord(n,k,1), k=1,nvcoord), n=1,levs_vcoord) - if (iret /= 0) goto 43 - - close (14) - - if (trim(donst) == "yes" .or. trim(donst) == "YES") then - nrec = nrec_all - allocate(recname(nrec)) - recname = recname_all - allocate(reclevtyp(nrec)) - reclevtyp = reclevtyp_all - allocate(reclev(nrec)) - reclev = reclev_all - else - nrec = 44 - allocate(recname(nrec)) - recname = recname_all(1:nrec) - allocate(reclevtyp(nrec)) - reclevtyp = reclevtyp_all(1:nrec) - allocate(reclev(nrec)) - reclev = reclev_all(1:nrec) - endif - - call nemsio_init(iret=iret) - - print* - print*,"- OPEN GAUSSIAN NEMSIO SURFACE FILE" - - call nemsio_open(gfileo, "sfc.gaussian.analysis.file", 'write', & - modelname="FV3GFS", gdatatype="bin4", version=version, & - nmeta=8, nrec=nrec, dimx=igaus, dimy=jgaus, dimz=(levs_vcoord-1), & - nframe=0, nsoil=4, ntrac=8, jcap=-9999, & - ncldt=5, idvc=-9999, idsl=-9999, idvm=-9999, & - idrt=4, lat=lat, lon=lon, vcoord=vcoord, & - nfhour=0, nfminute=0, nfsecondn=0, & - nfsecondd=1, nfday=0, idate=idate, & - recname=recname, reclevtyp=reclevtyp, & - reclev=reclev, extrameta=.true., & - nmetavari=nmetavari, variname=variname, varival=varival, & - nmetavarr=nmetavarr, varrname=varrname, varrval=varrval, & - nmetavarc=nmetavarc, varcname=varcname, varcval=varcval, & - nmetaaryi=nmetaaryi, aryiname=aryiname, & - aryival=aryival, aryilen=aryilen, iret=iret) - if (iret /= 0) goto 44 - - deallocate (lat, lon, vcoord, recname, reclevtyp, reclev) - - allocate(the_data(igaus*jgaus)) - - print*,"- WRITE GAUSSIAN NEMSIO SURFACE FILE" - - print*,"- WRITE ALNSF" - the_data = gaussian_data%alnsf - call nemsio_writerec(gfileo, 1, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE ALNWF" - the_data = gaussian_data%alnwf - call nemsio_writerec(gfileo, 2, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE ALVSF" - the_data = gaussian_data%alvsf - call nemsio_writerec(gfileo, 3, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE ALVWF" - the_data = gaussian_data%alvwf - call nemsio_writerec(gfileo, 4, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE CANOPY" - the_data = gaussian_data%canopy - call nemsio_writerec(gfileo, 5, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE CRAIN (SRFLAG)" - the_data = gaussian_data%srflag - call nemsio_writerec(gfileo, 6, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE F10M" - the_data = gaussian_data%f10m - call nemsio_writerec(gfileo, 7, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE FACSF" - the_data = gaussian_data%facsf - call nemsio_writerec(gfileo, 8, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE FACWF" - the_data = gaussian_data%facwf - call nemsio_writerec(gfileo, 9, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE FFHH" - the_data = gaussian_data%ffhh - call nemsio_writerec(gfileo, 10, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE FFMM" - the_data = gaussian_data%ffmm - call nemsio_writerec(gfileo, 11, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE UUSTAR" - the_data = gaussian_data%uustar - call nemsio_writerec(gfileo, 12, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE FICE" - the_data = gaussian_data%fice - call nemsio_writerec(gfileo, 13, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE HICE" - the_data = gaussian_data%hice - call nemsio_writerec(gfileo, 14, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE SLMSK" - the_data = gaussian_data%slmask - call nemsio_writerec(gfileo, 15, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE OROG" - the_data = gaussian_data%orog - call nemsio_writerec(gfileo, 16, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE SNOALB" - the_data = gaussian_data%snoalb - call nemsio_writerec(gfileo, 17, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE ZORL" - the_data = gaussian_data%zorl * 0.01 ! meters - call nemsio_writerec(gfileo, 18, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE SHDMAX" - the_data = gaussian_data%shdmax - call nemsio_writerec(gfileo, 19, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE SHDMIN" - the_data = gaussian_data%shdmin - call nemsio_writerec(gfileo, 20, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE SLC" - the_data = gaussian_data%slc(:,1) - call nemsio_writerec(gfileo, 21, the_data, iret=iret) - if (iret /= 0) goto 44 - - the_data = gaussian_data%slc(:,2) - call nemsio_writerec(gfileo, 22, the_data, iret=iret) - if (iret /= 0) goto 44 - - the_data = gaussian_data%slc(:,3) - call nemsio_writerec(gfileo, 23, the_data, iret=iret) - if (iret /= 0) goto 44 - - the_data = gaussian_data%slc(:,4) - call nemsio_writerec(gfileo, 24, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE SLOPE" - the_data = gaussian_data%slope - call nemsio_writerec(gfileo, 25, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE SMC" - the_data = gaussian_data%smc(:,1) - call nemsio_writerec(gfileo, 26, the_data, iret=iret) - if (iret /= 0) goto 44 - - the_data = gaussian_data%smc(:,2) - call nemsio_writerec(gfileo, 27, the_data, iret=iret) - if (iret /= 0) goto 44 - - the_data = gaussian_data%smc(:,3) - call nemsio_writerec(gfileo, 28, the_data, iret=iret) - if (iret /= 0) goto 44 - - the_data = gaussian_data%smc(:,4) - call nemsio_writerec(gfileo, 29, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE SNWDPH" - the_data = gaussian_data%snwdph * 0.001 ! meters - call nemsio_writerec(gfileo, 30, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE STYPE" - the_data = gaussian_data%stype - call nemsio_writerec(gfileo, 31, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE Q2M" - the_data = gaussian_data%q2m - call nemsio_writerec(gfileo, 32, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE STC" - the_data = gaussian_data%stc(:,1) - call nemsio_writerec(gfileo, 33, the_data, iret=iret) - if (iret /= 0) goto 44 - - the_data = gaussian_data%stc(:,2) - call nemsio_writerec(gfileo, 34, the_data, iret=iret) - if (iret /= 0) goto 44 - - the_data = gaussian_data%stc(:,3) - call nemsio_writerec(gfileo, 35, the_data, iret=iret) - if (iret /= 0) goto 44 - - the_data = gaussian_data%stc(:,4) - call nemsio_writerec(gfileo, 36, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE TG3" - the_data = gaussian_data%tg3 - call nemsio_writerec(gfileo, 37, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE TISFC" - the_data = gaussian_data%tisfc - call nemsio_writerec(gfileo, 38, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE T2M" - the_data = gaussian_data%t2m - call nemsio_writerec(gfileo, 39, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE TSEA" - the_data = gaussian_data%tsea - call nemsio_writerec(gfileo, 40, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE TPRCP" - the_data = gaussian_data%tprcp - call nemsio_writerec(gfileo, 41, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE VFRAC" - the_data = gaussian_data%vfrac * 100.0 ! whole percent - call nemsio_writerec(gfileo, 42, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE VTYPE" - the_data = gaussian_data%vtype - call nemsio_writerec(gfileo, 43, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE SHELEG" - the_data = gaussian_data%sheleg - call nemsio_writerec(gfileo, 44, the_data, iret=iret) - if (iret /= 0) goto 44 - - if (trim(donst) == "yes" .or. trim(donst) == "YES") then - - print*,"- WRITE C0" - the_data = gaussian_data%c0 - call nemsio_writerec(gfileo, 45, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE CD" - the_data = gaussian_data%cd - call nemsio_writerec(gfileo, 46, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE DCONV" - the_data = gaussian_data%dconv - call nemsio_writerec(gfileo, 47, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE DTCOOL" - the_data = gaussian_data%dtcool - call nemsio_writerec(gfileo, 48, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE QRAIN" - the_data = gaussian_data%qrain - call nemsio_writerec(gfileo, 49, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE TREF" - the_data = gaussian_data%tref - call nemsio_writerec(gfileo, 50, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE W0" - the_data = gaussian_data%w0 - call nemsio_writerec(gfileo, 51, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE WD" - the_data = gaussian_data%wd - call nemsio_writerec(gfileo, 52, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE XS" - the_data = gaussian_data%xs - call nemsio_writerec(gfileo, 53, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE XT" - the_data = gaussian_data%xt - call nemsio_writerec(gfileo, 54, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE XTTS" - the_data = gaussian_data%xtts - call nemsio_writerec(gfileo, 55, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE XU" - the_data = gaussian_data%xu - call nemsio_writerec(gfileo, 56, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE XV" - the_data = gaussian_data%xv - call nemsio_writerec(gfileo, 57, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE XZ" - the_data = gaussian_data%xz - call nemsio_writerec(gfileo, 58, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE XZTS" - the_data = gaussian_data%xzts - call nemsio_writerec(gfileo, 59, the_data, iret=iret) - if (iret /= 0) goto 44 - - print*,"- WRITE ZC" - the_data = gaussian_data%zc - call nemsio_writerec(gfileo, 60, the_data, iret=iret) - if (iret /= 0) goto 44 - - endif - - call nemsio_close(gfileo,iret=iret) - - call nemsio_finalize() - - deallocate(the_data) - - return - - 43 continue - print*,"- ** FATAL ERROR OPENING/READING VCOORD FILE." - print*,"- IRET IS: ", iret - call errexit(17) - stop - - 44 continue - print*,"- ** FATAL ERROR WRITING GAUSSIAN NEMSIO FILE." - print*,"- IRET IS: ", iret - call errexit(15) - stop - - end subroutine write_sfc_data_nemsio - -!------------------------------------------------------------------------------------------- -! Read tile data. -!------------------------------------------------------------------------------------------- - - subroutine read_data_anl - - use netcdf - use io - - implicit none - - integer :: ijtile, id_dim, id_var - integer :: error, tile, ncid - integer :: istart, iend - - real(kind=8), allocatable :: dummy(:,:), dummy3d(:,:,:) - -!------------------------------------------------------------------------------------------- -! Get tile dimensions from the first analysis file. -!------------------------------------------------------------------------------------------- - - error=nf90_open("./anal.tile1.nc",nf90_nowrite,ncid) - error=nf90_inq_dimid(ncid, 'xaxis_1', id_dim) - call netcdf_err(error, 'READING xaxis_1' ) - error=nf90_inquire_dimension(ncid,id_dim,len=itile) - call netcdf_err(error, 'READING xaxis_1' ) - - error=nf90_inq_dimid(ncid, 'yaxis_1', id_dim) - call netcdf_err(error, 'READING yaxis_1' ) - error=nf90_inquire_dimension(ncid,id_dim,len=jtile) - call netcdf_err(error, 'READING yaxis_1' ) - - error = nf90_close(ncid) - - ijtile = itile*jtile - - allocate(dummy(itile,jtile)) - allocate(dummy3d(itile,jtile,4)) - - allocate(tile_data%orog(ijtile*num_tiles)) - allocate(tile_data%canopy(ijtile*num_tiles)) - allocate(tile_data%slmask(ijtile*num_tiles)) - allocate(tile_data%tg3(ijtile*num_tiles)) - allocate(tile_data%alvsf(ijtile*num_tiles)) - allocate(tile_data%alvwf(ijtile*num_tiles)) - allocate(tile_data%alnsf(ijtile*num_tiles)) - allocate(tile_data%alnwf(ijtile*num_tiles)) - allocate(tile_data%facsf(ijtile*num_tiles)) - allocate(tile_data%facwf(ijtile*num_tiles)) - allocate(tile_data%ffhh(ijtile*num_tiles)) - allocate(tile_data%ffmm(ijtile*num_tiles)) - allocate(tile_data%fice(ijtile*num_tiles)) - allocate(tile_data%hice(ijtile*num_tiles)) - allocate(tile_data%sheleg(ijtile*num_tiles)) - allocate(tile_data%stype(ijtile*num_tiles)) - allocate(tile_data%vfrac(ijtile*num_tiles)) - allocate(tile_data%vtype(ijtile*num_tiles)) - allocate(tile_data%zorl(ijtile*num_tiles)) - allocate(tile_data%tsea(ijtile*num_tiles)) - allocate(tile_data%f10m(ijtile*num_tiles)) - allocate(tile_data%q2m(ijtile*num_tiles)) - allocate(tile_data%shdmax(ijtile*num_tiles)) - allocate(tile_data%shdmin(ijtile*num_tiles)) - allocate(tile_data%slope(ijtile*num_tiles)) - allocate(tile_data%snoalb(ijtile*num_tiles)) - allocate(tile_data%srflag(ijtile*num_tiles)) - allocate(tile_data%snwdph(ijtile*num_tiles)) - allocate(tile_data%t2m(ijtile*num_tiles)) - allocate(tile_data%tisfc(ijtile*num_tiles)) - allocate(tile_data%tprcp(ijtile*num_tiles)) - allocate(tile_data%uustar(ijtile*num_tiles)) - allocate(tile_data%slc(ijtile*num_tiles,4)) - allocate(tile_data%smc(ijtile*num_tiles,4)) - allocate(tile_data%stc(ijtile*num_tiles,4)) -! nst - if (trim(donst) == "yes" .or. trim(donst) == "YES") then - allocate(tile_data%c0(ijtile*num_tiles)) - allocate(tile_data%cd(ijtile*num_tiles)) - allocate(tile_data%dconv(ijtile*num_tiles)) - allocate(tile_data%dtcool(ijtile*num_tiles)) - allocate(tile_data%land(ijtile*num_tiles)) - allocate(tile_data%qrain(ijtile*num_tiles)) - allocate(tile_data%tref(ijtile*num_tiles)) - allocate(tile_data%w0(ijtile*num_tiles)) - allocate(tile_data%wd(ijtile*num_tiles)) - allocate(tile_data%xs(ijtile*num_tiles)) - allocate(tile_data%xt(ijtile*num_tiles)) - allocate(tile_data%xtts(ijtile*num_tiles)) - allocate(tile_data%xu(ijtile*num_tiles)) - allocate(tile_data%xv(ijtile*num_tiles)) - allocate(tile_data%xz(ijtile*num_tiles)) - allocate(tile_data%xzts(ijtile*num_tiles)) - allocate(tile_data%zc(ijtile*num_tiles)) - endif - - do tile = 1, 6 - - print* - print*, "- READ INPUT SFC DATA FOR TILE: ", tile - - istart = (ijtile) * (tile-1) + 1 - iend = istart + ijtile - 1 - - if (tile==1) error=nf90_open("./anal.tile1.nc",nf90_nowrite,ncid) - if (tile==2) error=nf90_open("./anal.tile2.nc",nf90_nowrite,ncid) - if (tile==3) error=nf90_open("./anal.tile3.nc",nf90_nowrite,ncid) - if (tile==4) error=nf90_open("./anal.tile4.nc",nf90_nowrite,ncid) - if (tile==5) error=nf90_open("./anal.tile5.nc",nf90_nowrite,ncid) - if (tile==6) error=nf90_open("./anal.tile6.nc",nf90_nowrite,ncid) - - call netcdf_err(error, 'OPENING FILE' ) - - error=nf90_inq_varid(ncid, "slmsk", id_var) - call netcdf_err(error, 'READING slmsk ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING slmsk' ) - print*,'- SLMSK: ',maxval(dummy),minval(dummy) - tile_data%slmask(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "tsea", id_var) - call netcdf_err(error, 'READING tsea ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING tsea' ) - print*,'- TSEA: ',maxval(dummy),minval(dummy) - tile_data%tsea(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "sheleg", id_var) - call netcdf_err(error, 'READING sheleg ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING sheleg' ) - print*,'- SHELEG: ',maxval(dummy),minval(dummy) - tile_data%sheleg(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "tg3", id_var) - call netcdf_err(error, 'READING tg3 ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING tg3' ) - print*,'- TG3: ',maxval(dummy),minval(dummy) - tile_data%tg3(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "zorl", id_var) - call netcdf_err(error, 'READING zorl ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING zorl' ) - print*,'- ZORL: ',maxval(dummy),minval(dummy) - tile_data%zorl(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "alvsf", id_var) - call netcdf_err(error, 'READING alvsf ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING alvsf' ) - print*,'- ALVSF: ',maxval(dummy),minval(dummy) - tile_data%alvsf(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "alvwf", id_var) - call netcdf_err(error, 'READING alvwf ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING alvwf' ) - print*,'- ALVWF: ',maxval(dummy),minval(dummy) - tile_data%alvwf(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "alnsf", id_var) - call netcdf_err(error, 'READING alnsf ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING alnsf' ) - print*,'- ALNSF: ',maxval(dummy),minval(dummy) - tile_data%alnsf(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "alnwf", id_var) - call netcdf_err(error, 'READING alnwf ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING alnwf' ) - print*,'- ALNWF: ',maxval(dummy),minval(dummy) - tile_data%alnwf(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "facsf", id_var) - call netcdf_err(error, 'READING facsf ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING facsf' ) - print*,'- FACSF: ',maxval(dummy),minval(dummy) - tile_data%facsf(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "facwf", id_var) - call netcdf_err(error, 'READING facwf ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING facwf' ) - print*,'- FACWF: ',maxval(dummy),minval(dummy) - tile_data%facwf(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "vfrac", id_var) - call netcdf_err(error, 'READING vfrac ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING vfrac' ) - print*,'- VFRAC: ',maxval(dummy),minval(dummy) - tile_data%vfrac(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "canopy", id_var) - call netcdf_err(error, 'READING canopy ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING canopy' ) - print*,'- CANOPY: ',maxval(dummy),minval(dummy) - tile_data%canopy(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "f10m", id_var) - call netcdf_err(error, 'READING f10m ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING f10m' ) - print*,'- F10M: ',maxval(dummy),minval(dummy) - tile_data%f10m(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "t2m", id_var) - call netcdf_err(error, 'READING t2m ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING t2m' ) - print*,'- T2M: ',maxval(dummy),minval(dummy) - tile_data%t2m(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "q2m", id_var) - call netcdf_err(error, 'READING q2m ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING q2m' ) - print*,'- Q2M: ',maxval(dummy),minval(dummy) - tile_data%q2m(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "vtype", id_var) - call netcdf_err(error, 'READING vtype ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING vtype' ) - print*,'- VTYPE: ',maxval(dummy),minval(dummy) - tile_data%vtype(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "stype", id_var) - call netcdf_err(error, 'READING stype ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING stype' ) - print*,'- STYPE: ',maxval(dummy),minval(dummy) - tile_data%stype(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "uustar", id_var) - call netcdf_err(error, 'READING uustar ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING uustar' ) - print*,'- UUSTAR: ',maxval(dummy),minval(dummy) - tile_data%uustar(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "ffmm", id_var) - call netcdf_err(error, 'READING ffmm ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING ffmm' ) - print*,'- FFMM: ',maxval(dummy),minval(dummy) - tile_data%ffmm(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "ffhh", id_var) - call netcdf_err(error, 'READING ffhh ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING ffhh' ) - print*,'- FFHH: ',maxval(dummy),minval(dummy) - tile_data%ffhh(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "hice", id_var) - call netcdf_err(error, 'READING hice ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING hice' ) - print*,'- HICE: ',maxval(dummy),minval(dummy) - tile_data%hice(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "fice", id_var) - call netcdf_err(error, 'READING fice ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING fice' ) - print*,'- FICE: ',maxval(dummy),minval(dummy) - tile_data%fice(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "tisfc", id_var) - call netcdf_err(error, 'READING tisfc ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING tisfc' ) - print*,'- TISFC: ',maxval(dummy),minval(dummy) - tile_data%tisfc(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "tprcp", id_var) - call netcdf_err(error, 'READING tprcp ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING tprcp' ) - print*,'- TPRCP: ',maxval(dummy),minval(dummy) - tile_data%tprcp(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "srflag", id_var) - call netcdf_err(error, 'READING srflag ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING srfalg' ) - print*,'- SRFLAG: ',maxval(dummy),minval(dummy) - tile_data%srflag(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "snwdph", id_var) - call netcdf_err(error, 'READING snwdph ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING snwdph' ) - print*,'- SNWDPH: ',maxval(dummy),minval(dummy) - tile_data%snwdph(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "shdmin", id_var) - call netcdf_err(error, 'READING shdmin ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING shdmin' ) - print*,'- SHDMIN: ',maxval(dummy),minval(dummy) - tile_data%shdmin(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "shdmax", id_var) - call netcdf_err(error, 'READING shdmax ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING shdmax' ) - print*,'- SHDMAX: ',maxval(dummy),minval(dummy) - tile_data%shdmax(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "slope", id_var) - call netcdf_err(error, 'READING slope ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING slope' ) - print*,'- SLOPE: ',maxval(dummy),minval(dummy) - tile_data%slope(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "snoalb", id_var) - call netcdf_err(error, 'READING snoalb ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING snoalb' ) - print*,'- SNOALB: ',maxval(dummy),minval(dummy) - tile_data%snoalb(istart:iend) = reshape(dummy, (/ijtile/)) - - if (trim(donst) == "yes" .or. trim(donst) == "YES") then - - error=nf90_inq_varid(ncid, "c_0", id_var) - call netcdf_err(error, 'READING c_0 ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING c_0' ) - print*,'- C_0: ',maxval(dummy),minval(dummy) - tile_data%c0(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "c_d", id_var) - call netcdf_err(error, 'READING c_d ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING c_d' ) - print*,'- C_D: ',maxval(dummy),minval(dummy) - tile_data%cd(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "d_conv", id_var) - call netcdf_err(error, 'READING d_conv ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING d_conv' ) - print*,'- D_CONV: ',maxval(dummy),minval(dummy) - tile_data%dconv(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "dt_cool", id_var) - call netcdf_err(error, 'READING dt_cool ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING dt_cool' ) - print*,'- DT_COOL: ',maxval(dummy),minval(dummy) - tile_data%dtcool(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "qrain", id_var) - call netcdf_err(error, 'READING qrain ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING qrain' ) - print*,'- QRAIN: ',maxval(dummy),minval(dummy) - tile_data%qrain(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "tref", id_var) - call netcdf_err(error, 'READING tref ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING tref' ) - print*,'- TREF: ',maxval(dummy),minval(dummy) - tile_data%tref(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "w_0", id_var) - call netcdf_err(error, 'READING w_0 ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING w_0' ) - print*,'- W_0: ',maxval(dummy),minval(dummy) - tile_data%w0(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "w_d", id_var) - call netcdf_err(error, 'READING w_d ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING w_d' ) - print*,'- W_D: ',maxval(dummy),minval(dummy) - tile_data%wd(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "xs", id_var) - call netcdf_err(error, 'READING xs ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING xs' ) - print*,'- XS: ',maxval(dummy),minval(dummy) - tile_data%xs(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "xt", id_var) - call netcdf_err(error, 'READING xt ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING xt' ) - print*,'- XT: ',maxval(dummy),minval(dummy) - tile_data%xt(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "xtts", id_var) - call netcdf_err(error, 'READING xtts ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING xtts' ) - print*,'- XTTS: ',maxval(dummy),minval(dummy) - tile_data%xtts(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "xzts", id_var) - call netcdf_err(error, 'READING xzts ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING xzts' ) - print*,'- XZTS: ',maxval(dummy),minval(dummy) - tile_data%xzts(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "xu", id_var) - call netcdf_err(error, 'READING xu ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING xu' ) - print*,'- XU: ',maxval(dummy),minval(dummy) - tile_data%xu(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "xv", id_var) - call netcdf_err(error, 'READING xv ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING xv' ) - print*,'- XV: ',maxval(dummy),minval(dummy) - tile_data%xv(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "xz", id_var) - call netcdf_err(error, 'READING xz ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING xz' ) - print*,'- XZ: ',maxval(dummy),minval(dummy) - tile_data%xz(istart:iend) = reshape(dummy, (/ijtile/)) - - error=nf90_inq_varid(ncid, "z_c", id_var) - call netcdf_err(error, 'READING z_c ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING z_c' ) - print*,'- Z_C: ',maxval(dummy),minval(dummy) - tile_data%zc(istart:iend) = reshape(dummy, (/ijtile/)) - - endif ! nst fields - - error=nf90_inq_varid(ncid, "smc", id_var) - call netcdf_err(error, 'READING smc ID' ) - error=nf90_get_var(ncid, id_var, dummy3d) - call netcdf_err(error, 'READING smc' ) - print*,'- SMC: ',maxval(dummy3d),minval(dummy3d) - tile_data%smc(istart:iend,1:4) = reshape(dummy3d, (/ijtile,4/)) - - error=nf90_inq_varid(ncid, "stc", id_var) - call netcdf_err(error, 'READING stc ID' ) - error=nf90_get_var(ncid, id_var, dummy3d) - call netcdf_err(error, 'READING stc' ) - print*,'- STC: ',maxval(dummy3d),minval(dummy3d) - tile_data%stc(istart:iend,1:4) = reshape(dummy3d, (/ijtile,4/)) - - error=nf90_inq_varid(ncid, "slc", id_var) - call netcdf_err(error, 'READING slc ID' ) - error=nf90_get_var(ncid, id_var, dummy3d) - call netcdf_err(error, 'READING slc' ) - print*,'- SLC: ',maxval(dummy3d),minval(dummy3d) - tile_data%slc(istart:iend,1:4) = reshape(dummy3d, (/ijtile,4/)) - - error = nf90_close(ncid) - - print* - print*, "- READ INPUT OROG DATA FOR TILE: ",tile - - if (tile==1) error=nf90_open("./orog.tile1.nc",nf90_nowrite,ncid) - if (tile==2) error=nf90_open("./orog.tile2.nc",nf90_nowrite,ncid) - if (tile==3) error=nf90_open("./orog.tile3.nc",nf90_nowrite,ncid) - if (tile==4) error=nf90_open("./orog.tile4.nc",nf90_nowrite,ncid) - if (tile==5) error=nf90_open("./orog.tile5.nc",nf90_nowrite,ncid) - if (tile==6) error=nf90_open("./orog.tile6.nc",nf90_nowrite,ncid) - - call netcdf_err(error, 'OPENING FILE' ) - - error=nf90_inq_varid(ncid, "orog_raw", id_var) - call netcdf_err(error, 'READING orog_raw ID' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'READING orog_raw' ) - print*,'- OROG: ',maxval(dummy),minval(dummy) - tile_data%orog(istart:iend) = reshape(dummy, (/ijtile/)) - - error = nf90_close(ncid) - - enddo - - deallocate (dummy, dummy3d) - - end subroutine read_data_anl - -!------------------------------------------------------------------------------------------- -! Netcdf error routine. -!------------------------------------------------------------------------------------------- - - subroutine netcdf_err(err, string) - - use netcdf - - implicit none - - character(len=*), intent(in) :: string - integer, intent(in) :: err - - character(len=256) :: errmsg - - if( err.eq.nf90_noerr )return - - errmsg = nf90_strerror(err) - print*,'' - print*,'** FATAL ERROR: ', trim(string), ': ', trim(errmsg) - print*,'STOP.' - call errexit(22) - - return - end subroutine netcdf_err diff --git a/sorc/gaussian_sfcanl.fd/makefile.sh b/sorc/gaussian_sfcanl.fd/makefile.sh deleted file mode 100755 index b1c5adefde..0000000000 --- a/sorc/gaussian_sfcanl.fd/makefile.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/bin/sh - -export FFLAGS="-O3 -fp-model precise -g -r8 -i4" -# for debugging -#export FFLAGS="-g -r8 -i4 -warn unused -check bounds" - -export NETCDF_INCLUDE="-I${NETCDF}/include" -export NETCDF_LDFLAGS_F="-L${NETCDF}/lib -lnetcdf -lnetcdff -L${HDF5}/lib -lhdf5 " - -make clean -make build -err=$? -if [ $err -ne 0 ]; then - echo ERROR BUILDING GAUSSIAN_SFCANL - exit 2 -fi -make install - -exit diff --git a/sorc/gaussian_sfcanl.fd/weight_gen/README b/sorc/gaussian_sfcanl.fd/weight_gen/README deleted file mode 100644 index 304c6f0e0e..0000000000 --- a/sorc/gaussian_sfcanl.fd/weight_gen/README +++ /dev/null @@ -1,23 +0,0 @@ -Creates the ESMF integration weight files to transform from cubed-sphere grids -to comparable (in resolution) global gaussian grids. - -First, compile the program that creates the 'scrip' files for the -global gaussian grids. For each resolution, two grids are created: -one normal grid and one grid with two extra rows for the N/S poles. -To compile, cd to ./scrip.fd and type 'make.sh'. Currently, only -compiles/runs on Theia. - -Then, run the 'run.theia.ksh' script for the resolution desired. -Script first calls the 'scrip' program, then calls ESMF utility -'RegridWeightGen' to create the interpolation weight files. - -Weight files for the following transforms are created: - -C48 => 192x94 and 192x96 gaussian -C96 => 384x192 and 384x194 gaussian -C128 => 512x256 and 512x258 gaussian -C192 => 768x384 and 768x386 gaussian -C384 => 1536x768 and 1536x770 gaussian -C768 => 3072x1536 and 3072x1538 gaussian -C1152 => 4608x2304 and 4608x2406 gaussian -C3072 => 12288x6144 and 12288x6146 gaussian diff --git a/sorc/gaussian_sfcanl.fd/weight_gen/run.theia.sh b/sorc/gaussian_sfcanl.fd/weight_gen/run.theia.sh deleted file mode 100755 index c1673fd655..0000000000 --- a/sorc/gaussian_sfcanl.fd/weight_gen/run.theia.sh +++ /dev/null @@ -1,152 +0,0 @@ -#!/bin/sh - -#------------------------------------------------------------------------ -# Run the "RegridWeightGen" step on Theia to create interpolation -# weight files to transform from cubed-sphere tiles to global -# gaussian. -# -# First, create the 'scrip' files for the gaussian grids. Two -# grids are created - the normal gaussian grid, and one with -# two extra rows at the N/S poles. The program to create the -# script files is in ./scrip.fd. To compile, type 'make.sh'. -# Then, run the RegridWeightGen step to create the interpolation -# weight files. -#------------------------------------------------------------------------ - -#PBS -l nodes=1:ppn=1 -#PBS -l walltime=0:30:00 -#PBS -A fv3-cpu -#PBS -q debug -#PBS -N fv3_wgtgen -#PBS -o ./log -#PBS -e ./log - -set -x - -CRES=C48 # run with one mpi task -#CRES=C96 # run with one mpi task -#CRES=C128 # run with one mpi task -#CRES=C192 # run with one mpi task -#CRES=C384 # run with one mpi task -#CRES=C768 # run with 4 mpi tasks -#CRES=C1152 # run with 8 mpi tasks -#CRES=C3072 # run on two nodes, 8 tasks per node - -WORK=/scratch3/NCEPDEV/stmp1/$LOGNAME/weight_gen -rm -fr $WORK -mkdir -p $WORK -cd $WORK - -source /apps/lmod/lmod/init/sh -module purge -module load intel/15.1.133 -module load impi/5.0.1.035 -module use /scratch4/NCEPDEV/nems/noscrub/emc.nemspara/soft/modulefiles -module load esmf/7.1.0r -module load netcdf/4.3.0 -module load hdf5/1.8.14 - -#------------------------------------------------------------------------ -# The RegridWeightGen program. -#------------------------------------------------------------------------ - -RWG=/scratch4/NCEPDEV/nems/noscrub/emc.nemspara/soft/esmf/7.1.0r/bin/ESMF_RegridWeightGen - -#------------------------------------------------------------------------ -# Path to the 'mosaic' and 'grid' files for each cubed-sphere -# resolution. -#------------------------------------------------------------------------ - -FIX_DIR=/scratch4/NCEPDEV/global/save/glopara/svn/fv3gfs/fix/fix_fv3_gmted2010/$CRES - -#------------------------------------------------------------------------ -# Create 'scrip' files for two gaussian grids. One normal grid -# and one with two extra rows at the N/S poles. -#------------------------------------------------------------------------ - -${PBS_O_WORKDIR}/scrip.fd/scrip.exe $CRES - -if [[ $? -ne 0 ]]; then - echo "ERROR CREATING SCRIP FILE" - exit 2 -fi - -#------------------------------------------------------------------------ -# Create weight files. -#------------------------------------------------------------------------ - -case $CRES in - "C48" ) - LONB="192" - LATB="94" - LATB2="96" - ;; - "C96" ) - LONB="384" - LATB="192" - LATB2="194" - ;; - "C128" ) - LONB="512" - LATB="256" - LATB2="258" - ;; - "C192" ) - LONB="768" - LATB="384" - LATB2="386" - ;; - "C384" ) - LONB="1536" - LATB="768" - LATB2="770" - ;; - "C768" ) - LONB="3072" - LATB="1536" - LATB2="1538" - ;; - "C1152" ) - LONB="4608" - LATB="2304" - LATB2="2306" - ;; - "C3072" ) - LONB="12288" - LATB="6144" - LATB2="6146" - ;; - * ) - echo "GRID NOT SUPPORTED" - exit 3 - ;; -esac - -np=$PBS_NP - -mpirun -np $np $RWG -d ./gaussian.${LONB}.${LATB}.nc -s $FIX_DIR/${CRES}_mosaic.nc \ - -w fv3_SCRIP_${CRES}_GRIDSPEC_lon${LONB}_lat${LATB}.gaussian.neareststod.nc \ - -m neareststod --64bit_offset --tilefile_path $FIX_DIR - -mpirun -np $np $RWG -d ./gaussian.${LONB}.${LATB}.nc -s $FIX_DIR/${CRES}_mosaic.nc \ - -w fv3_SCRIP_${CRES}_GRIDSPEC_lon${LONB}_lat${LATB}.gaussian.bilinear.nc \ - -m bilinear --64bit_offset --tilefile_path $FIX_DIR - -mpirun -np $np $RWG -d ./gaussian.${LONB}.${LATB2}.nc -s $FIX_DIR/${CRES}_mosaic.nc \ - -w fv3_SCRIP_${CRES}_GRIDSPEC_lon${LONB}_lat${LATB2}.gaussian.neareststod.nc \ - -m neareststod --64bit_offset --tilefile_path $FIX_DIR - -#------------------------------------------------------------------------ -# Could not get this C3072 bilinear option to work. This grid is -# so big we are pushing the limits of the utility. -#------------------------------------------------------------------------ - -if [[ $CRES == "C3072" ]]; then - exit 0 -fi - -mpirun -np $np $RWG -d ./gaussian.${LONB}.${LATB2}.nc -s $FIX_DIR/${CRES}_mosaic.nc \ - -w fv3_SCRIP_${CRES}_GRIDSPEC_lon${LONB}_lat${LATB2}.gaussian.bilinear.nc \ - -m bilinear --64bit_offset --tilefile_path $FIX_DIR - -exit diff --git a/sorc/gaussian_sfcanl.fd/weight_gen/scrip.fd/make.sh b/sorc/gaussian_sfcanl.fd/weight_gen/scrip.fd/make.sh deleted file mode 100755 index 12ed3eefd9..0000000000 --- a/sorc/gaussian_sfcanl.fd/weight_gen/scrip.fd/make.sh +++ /dev/null @@ -1,60 +0,0 @@ -#!/bin/sh - -set -x - -mac=$(hostname -f) - -case $mac in - -#--------------------------------------------------------------------------------- -# BUILD PROGRAM ON WCOSS Phase 1/2. -#--------------------------------------------------------------------------------- - -g????.ncep.noaa.gov | t????.ncep.noaa.gov) - - echo "WCOSS PHASE 1/2 BUILD NOT ADDED YET" - exit 1 ;; - -#--------------------------------------------------------------------------------- -# BUILD PROGRAM ON WCOSS CRAY. -#--------------------------------------------------------------------------------- - -llogin? | slogin?) - - echo "WCOSS CRAY BUILD NOT ADDED YET" - exit 1 ;; - -#--------------------------------------------------------------------------------- -# BUILD PROGRAM ON HERA. -#--------------------------------------------------------------------------------- - -hfe??) - - source /apps/lmod/lmod/init/sh - module purge - - module load intel/18.0.5.274 - - export FCOMP=ifort - export FFLAGS="-O0 -g -traceback -r8 -i4 -convert big_endian -check bounds" - - module load netcdf/4.7.0 - module load hdf5/1.10.5 - export NETCDF_INCLUDE="-I${NETCDF}/include" - export NETCDF_LDFLAGS_F="-L${NETCDF}/lib -lnetcdf -lnetcdff -L${HDF5}/lib -lhdf5 -lhdf5_fortran" - - module use -a /scratch2/NCEPDEV/nwprod/NCEPLIBS/modulefiles - module load sp/2.0.2 - - make clean - make - rc=$? ;; - -*) - - echo "DOES NOT BUILD ON THIS MACHINE." - exit 1 ;; - -esac - -exit diff --git a/sorc/gaussian_sfcanl.fd/weight_gen/scrip.fd/makefile b/sorc/gaussian_sfcanl.fd/weight_gen/scrip.fd/makefile deleted file mode 100755 index 74949b96bb..0000000000 --- a/sorc/gaussian_sfcanl.fd/weight_gen/scrip.fd/makefile +++ /dev/null @@ -1,14 +0,0 @@ -SHELL= /bin/sh - -CMD= scrip.exe - -OBJS = scrip.o - -$(CMD): $(OBJS) - $(FCOMP) $(FFLAGS) $(NETCDF_INCLUDE) -o $(CMD) $(OBJS) $(NETCDF_LDFLAGS_F) $(SP_LIBd) - -scrip.o: scrip.f90 - $(FCOMP) $(FFLAGS) $(NETCDF_INCLUDE) -c scrip.f90 - -clean: - rm -f *.o *.mod ${CMD} *.exe.* diff --git a/sorc/gaussian_sfcanl.fd/weight_gen/scrip.fd/scrip.f90 b/sorc/gaussian_sfcanl.fd/weight_gen/scrip.fd/scrip.f90 deleted file mode 100644 index 5c4d2a4221..0000000000 --- a/sorc/gaussian_sfcanl.fd/weight_gen/scrip.fd/scrip.f90 +++ /dev/null @@ -1,350 +0,0 @@ - program scrip - -!---------------------------------------------------------------------- -! Create "scrip" files that describes a gaussian grid. -! Two files are created: the normal gaussian grid and one with -! two extra rows for the N/S poles. -!---------------------------------------------------------------------- - - implicit none - - character(len=128) :: outfile - character(len=20) :: title - character(len=5) :: idim_ch, jdim_ch, jdimp_ch - character(len=6) :: cres - - integer :: header_buffer_val = 16384 - integer :: fsize=65536, inital = 0 - integer :: error, ncid - integer :: i, j, idim, jdim, ijdim - integer :: jdimp - integer :: dim_size, dim_corners, dim_rank - integer :: id_dims, id_center_lat, id_center_lon - integer :: id_imask, id_corner_lat, id_corner_lon - integer :: num_corners = 4 - integer :: rank = 2 - integer(kind=4), allocatable :: mask(:) - - real(kind=8) :: corner_lon_src - real(kind=8) :: dx_src, lat_edge - real(kind=8), allocatable :: lats(:,:), lons(:,:), dum1d(:) - real(kind=8), allocatable :: dum2d(:,:), latsp(:,:), lonsp(:,:) - real(kind=8), allocatable :: lats_corner(:,:,:), lons_corner(:,:,:) - real(kind=8), allocatable :: latsp_corner(:,:,:), lonsp_corner(:,:,:) - real(kind=8), allocatable :: slat(:), wlat(:) - - include "netcdf.inc" - - call getarg(1, cres) - - select case (trim(cres)) - case ("c48","C48") - idim = 192 ! cres * 4 - jdim = 94 ! cres * 2 - jdimp = 96 ! include two rows for the poles - idim_ch = "192" - jdim_ch = "94" - jdimp_ch = "96" - case ("c96","C96") - idim = 384 ! cres * 4 - jdim = 192 ! cres * 2 - jdimp = 194 ! include two rows for the poles - idim_ch = "384" - jdim_ch = "192" - jdimp_ch = "194" - case ("c128","C128") - idim = 512 ! cres * 4 - jdim = 256 ! cres * 2 - jdimp = 258 ! include two rows for the poles - idim_ch = "512" - jdim_ch = "256" - jdimp_ch = "258" - case ("c192","C192") - idim = 768 ! cres * 4 - jdim = 384 ! cres * 2 - jdimp = 386 ! include two rows for the poles - idim_ch = "768" - jdim_ch = "384" - jdimp_ch = "386" - case ("c384","C384") - idim = 1536 ! cres * 4 - jdim = 768 ! cres * 2 - jdimp = 770 ! include two rows for the poles - idim_ch = "1536" - jdim_ch = "768" - jdimp_ch = "770" - case ("c768","C768") - idim = 3072 ! cres * 4 - jdim = 1536 ! cres * 2 - jdimp = 1538 ! include two rows for the poles - idim_ch = "3072" - jdim_ch = "1536" - jdimp_ch = "1538" - case ("c1152","C1152") - idim = 4608 ! cres * 4 - jdim = 2304 ! cres * 2 - jdimp = 2306 ! include two rows for the poles - idim_ch = "4608" - jdim_ch = "2304" - jdimp_ch = "2306" - case ("c3072","C3072") - idim = 12288 ! cres * 4 - jdim = 6144 ! cres * 2 - jdimp = 6146 ! include two rows for the poles - idim_ch = "12288" - jdim_ch = "6144" - jdimp_ch = "6146" - case default - print*,'- Resolution not supported ', trim(cres) - stop 3 - end select - - corner_lon_src = 0.0 - dx_src = 360.0 / float(idim) - ijdim = idim*jdim - - allocate(slat(jdim)) - allocate(wlat(jdim)) - - call splat(4, jdim, slat, wlat) - - allocate(lats(idim,jdim)) - allocate(lats_corner(num_corners,idim,jdim)) - allocate(lons(idim,jdim)) - allocate(lons_corner(num_corners,idim,jdim)) - - do j = 1, jdim - lats(:,j) = 90.0 - (acos(slat(j))* 180.0 / (4.*atan(1.))) - enddo - - deallocate(slat, wlat) - -!---------------------------------------------------------------- -! First, output file without poles. -!---------------------------------------------------------------- - -!---------------------------------------------------------------- -! Set corners in counter-clockwise order -! -! 2 1 -! -! C -! -! 3 4 -!---------------------------------------------------------------- - - lats_corner(1,:,1) = 90.0 - lats_corner(2,:,1) = 90.0 - - lats_corner(3,:,jdim) = -90.0 - lats_corner(4,:,jdim) = -90.0 - - do j = 1, jdim - 1 - lat_edge = (lats(1,j) + lats(1,j+1)) / 2.0 - lats_corner(3,:,j) = lat_edge - lats_corner(4,:,j) = lat_edge - lats_corner(1,:,j+1) = lat_edge - lats_corner(2,:,j+1) = lat_edge - enddo - - do i = 1, idim - lons(i,:) = corner_lon_src + float(i-1)*dx_src - lons_corner(1,i,:) = lons(i,:) + (dx_src*0.5) - lons_corner(2,i,:) = lons(i,:) - (dx_src*0.5) - lons_corner(3,i,:) = lons(i,:) - (dx_src*0.5) - lons_corner(4,i,:) = lons(i,:) + (dx_src*0.5) - enddo - - i = 1 - j = 1 - print*,'center ',lats(i,j),lons(i,j) - print*,'corner 1 ',lats_corner(1,i,j),lons_corner(1,i,j) - print*,'corner 2 ',lats_corner(2,i,j),lons_corner(2,i,j) - print*,'corner 3 ',lats_corner(3,i,j),lons_corner(3,i,j) - print*,'corner 4 ',lats_corner(4,i,j),lons_corner(4,i,j) - - i = 1 - j = 2 - print*,'center ',lats(i,j),lons(i,j) - print*,'corner 1 ',lats_corner(1,i,j),lons_corner(1,i,j) - print*,'corner 2 ',lats_corner(2,i,j),lons_corner(2,i,j) - print*,'corner 3 ',lats_corner(3,i,j),lons_corner(3,i,j) - print*,'corner 4 ',lats_corner(4,i,j),lons_corner(4,i,j) - - i = 1 - j = jdim - print*,'center ',lats(i,j),lons(i,j) - print*,'corner 1 ',lats_corner(1,i,j),lons_corner(1,i,j) - print*,'corner 2 ',lats_corner(2,i,j),lons_corner(2,i,j) - print*,'corner 3 ',lats_corner(3,i,j),lons_corner(3,i,j) - print*,'corner 4 ',lats_corner(4,i,j),lons_corner(4,i,j) - - i = 1 - j = jdim-1 - print*,'center ',lats(i,j),lons(i,j) - print*,'corner 1 ',lats_corner(1,i,j),lons_corner(1,i,j) - print*,'corner 2 ',lats_corner(2,i,j),lons_corner(2,i,j) - print*,'corner 3 ',lats_corner(3,i,j),lons_corner(3,i,j) - print*,'corner 4 ',lats_corner(4,i,j),lons_corner(4,i,j) - - allocate(mask(ijdim)) - mask = 1 - -! output file without pole. - - outfile = " " - outfile = "./gaussian." // trim(idim_ch) // "." // trim(jdim_ch) // ".nc" - title = " " - title = "gaussian." // trim(idim_ch) // "." // trim(jdim_ch) - -!--- open the file - error = NF__CREATE(outfile, IOR(NF_NETCDF4,NF_CLASSIC_MODEL), inital, fsize, ncid) - print*, 'error after open ', error - -!--- define dimension - error = nf_def_dim(ncid, 'grid_size', ijdim, dim_size) - error = nf_def_dim(ncid, 'grid_corners', num_corners, dim_corners) - error = nf_def_dim(ncid, 'grid_rank', rank, dim_rank) - -!--- define field - error = nf_def_var(ncid, 'grid_dims', NF_INT, 1, (/dim_rank/), id_dims) - error = nf_def_var(ncid, 'grid_center_lat', NF_DOUBLE, 1, (/dim_size/), id_center_lat) - error = nf_put_att_text(ncid, id_center_lat, "units", 7, "degrees") - error = nf_def_var(ncid, 'grid_center_lon', NF_DOUBLE, 1, (/dim_size/), id_center_lon) - error = nf_put_att_text(ncid, id_center_lon, "units", 7, "degrees") - error = nf_def_var(ncid, 'grid_imask', NF_INT, 1, (/dim_size/), id_imask) - error = nf_put_att_text(ncid, id_imask, "units", 8, "unitless") - error = nf_def_var(ncid, 'grid_corner_lat', NF_DOUBLE, 2, (/dim_corners,dim_size/), id_corner_lat) - error = nf_put_att_text(ncid, id_corner_lat, "units", 7, "degrees") - error = nf_def_var(ncid, 'grid_corner_lon', NF_DOUBLE, 2, (/dim_corners,dim_size/), id_corner_lon) - error = nf_put_att_text(ncid, id_corner_lon, "units", 7, "degrees") - error = nf_put_att_text(ncid, NF_GLOBAL, "title", 20, trim(title)) - error = nf__enddef(ncid, header_buffer_val,4,0,4) - -!--- set fields - error = nf_put_var_int( ncid, id_dims, (/idim,jdim/)) - - allocate(dum1d(ijdim)) - dum1d = reshape(lats, (/ijdim/)) - error = nf_put_var_double( ncid, id_center_lat, dum1d) - dum1d = reshape(lons, (/ijdim/)) - error = nf_put_var_double( ncid, id_center_lon, dum1d) - deallocate(dum1d) - - error = nf_put_var_int( ncid, id_imask, mask) - deallocate(mask) - - allocate(dum2d(num_corners,ijdim)) - dum2d = reshape (lats_corner, (/num_corners,ijdim/)) - error = nf_put_var_double( ncid, id_corner_lat, dum2d) - - dum2d = reshape (lons_corner, (/num_corners,ijdim/)) - error = nf_put_var_double( ncid, id_corner_lon, dum2d) - deallocate(dum2d) - - error = nf_close(ncid) - -!---------------------------------------------------------------- -! output file with poles. -!---------------------------------------------------------------- - - outfile = " " - outfile = "./gaussian." // trim(idim_ch) // "." // trim(jdimp_ch) // ".nc" - title = " " - title = "gaussian." // trim(idim_ch) // "." // trim(jdimp_ch) - - ijdim = idim*jdimp - - allocate(latsp(idim,jdimp)) - allocate(lonsp(idim,jdimp)) - - do j = 2, jdim+1 - latsp(:,j) = lats(:,j-1) - lonsp(:,j) = lons(:,j-1) - enddo - - latsp(:,1) = 90.0_8 - lonsp(:,1) = 0.0_8 - - latsp(:,jdimp) = -90.0_8 - lonsp(:,jdimp) = 0.0_8 - - deallocate(lats, lons) - - allocate(latsp_corner(num_corners,idim,jdimp)) - allocate(lonsp_corner(num_corners,idim,jdimp)) - - latsp_corner(:,:,1) = 89.5_8 - latsp_corner(:,:,jdimp) = -89.5_8 - - lonsp_corner(1,:,1) = 0.0_8 - lonsp_corner(2,:,1) = 90.0_8 - lonsp_corner(3,:,1) = 180.0_8 - lonsp_corner(4,:,1) = 270.0_8 - - lonsp_corner(1,:,jdimp) = 0.0_8 - lonsp_corner(2,:,jdimp) = 90.0_8 - lonsp_corner(3,:,jdimp) = 180.0_8 - lonsp_corner(4,:,jdimp) = 270.0_8 - - do j = 2, jdim+1 - latsp_corner(:,:,j) = lats_corner(:,:,j-1) - lonsp_corner(:,:,j) = lons_corner(:,:,j-1) - enddo - - deallocate(lats_corner, lons_corner) - -!--- open the file - error = NF__CREATE(outfile, IOR(NF_NETCDF4,NF_CLASSIC_MODEL), inital, fsize, ncid) - print*, 'error after open ', error - -!--- define dimension - error = nf_def_dim(ncid, 'grid_size', ijdim, dim_size) - error = nf_def_dim(ncid, 'grid_corners', num_corners, dim_corners) - error = nf_def_dim(ncid, 'grid_rank', rank, dim_rank) - -!--- define field - error = nf_def_var(ncid, 'grid_dims', NF_INT, 1, (/dim_rank/), id_dims) - error = nf_def_var(ncid, 'grid_center_lat', NF_DOUBLE, 1, (/dim_size/), id_center_lat) - error = nf_put_att_text(ncid, id_center_lat, "units", 7, "degrees") - error = nf_def_var(ncid, 'grid_center_lon', NF_DOUBLE, 1, (/dim_size/), id_center_lon) - error = nf_put_att_text(ncid, id_center_lon, "units", 7, "degrees") - error = nf_def_var(ncid, 'grid_imask', NF_INT, 1, (/dim_size/), id_imask) - error = nf_put_att_text(ncid, id_imask, "units", 8, "unitless") - error = nf_def_var(ncid, 'grid_corner_lat', NF_DOUBLE, 2, (/dim_corners,dim_size/), id_corner_lat) - error = nf_put_att_text(ncid, id_corner_lat, "units", 7, "degrees") - error = nf_def_var(ncid, 'grid_corner_lon', NF_DOUBLE, 2, (/dim_corners,dim_size/), id_corner_lon) - error = nf_put_att_text(ncid, id_corner_lon, "units", 7, "degrees") - error = nf_put_att_text(ncid, NF_GLOBAL, "title", 20, trim(title)) - error = nf__enddef(ncid, header_buffer_val,4,0,4) - -!--- set fields - error = nf_put_var_int( ncid, id_dims, (/idim,jdimp/)) - - allocate(dum1d(ijdim)) - dum1d = reshape(latsp, (/ijdim/)) - error = nf_put_var_double( ncid, id_center_lat, dum1d) - dum1d = reshape(lonsp, (/ijdim/)) - error = nf_put_var_double( ncid, id_center_lon, dum1d) - deallocate(dum1d) - - allocate(mask(ijdim)) - mask = 1 - error = nf_put_var_int( ncid, id_imask, mask) - deallocate(mask) - - allocate(dum2d(num_corners,ijdim)) - dum2d = reshape (latsp_corner, (/num_corners,ijdim/)) - print*,'lat corner check ',maxval(dum2d),minval(dum2d) - error = nf_put_var_double( ncid, id_corner_lat, dum2d) - deallocate(latsp_corner) - - dum2d = reshape (lonsp_corner, (/num_corners,ijdim/)) - error = nf_put_var_double( ncid, id_corner_lon, dum2d) - deallocate(dum2d, lonsp_corner) - - error = nf_close(ncid) - - print*,'- DONE.' - - end program scrip diff --git a/sorc/gfs_bufr.fd/CMakeLists.txt b/sorc/gfs_bufr.fd/CMakeLists.txt deleted file mode 100644 index b0fc45b651..0000000000 --- a/sorc/gfs_bufr.fd/CMakeLists.txt +++ /dev/null @@ -1,55 +0,0 @@ -list(APPEND fortran_src - bfrhdr.f - bfrize.f - buff.f - #calwxt_gfs_baldwin.f - #calwxt_gfs_ramer.f - gfsbufr.f - lcl.f - meteorg.f - mstadb.f - newsig1.f - read_nemsio.f - #read_netcdf.f - read_netcdf_p.f - rsearch.f - svp.f - tdew.f - terp3.f - vintg.f -) - -list(APPEND fortran_src_free - calpreciptype.f - funcphys.f - gslp.f - machine.f - modstuff1.f - physcons.f -) - -if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -convert big_endian -fp-model source") - set_source_files_properties(${fortran_src_free} PROPERTIES COMPILE_FLAGS "-free") -elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fconvert=big-endian") - set_source_files_properties(${fortran_src_free} PROPERTIES COMPILE_FLAGS "-ffree-form") -endif() - -set(exe_name gfs_bufr.x) -add_executable(${exe_name} ${fortran_src} ${fortran_src_free}) -target_link_libraries( - ${exe_name} - nemsio::nemsio - bacio::bacio_4 - sigio::sigio - sp::sp_4 - w3emc::w3emc_4 - w3nco::w3nco_4 - bufr::bufr_4_DA - NetCDF::NetCDF_Fortran) -if(OpenMP_Fortran_FOUND) - target_link_libraries(${exe_name} OpenMP::OpenMP_Fortran) -endif() - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/gfs_bufr.fd/bfrhdr.f b/sorc/gfs_bufr.fd/bfrhdr.f deleted file mode 100755 index 8bab3043bc..0000000000 --- a/sorc/gfs_bufr.fd/bfrhdr.f +++ /dev/null @@ -1,174 +0,0 @@ - SUBROUTINE BFRHDR ( luntbl, cseqn, prfflg, clist, np, iret ) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: PROGRAM NAME (up to 20 characters) -C PRGMMR: YOUR NAME ORG: W/NMCXX DATE: YY-MM-DD -C -C ABSTRACT: START ABSTRACT HERE AND INDENT TO COLUMN 5 ON THE -C FOLLOWING LINES. PLEASE PROVIDE A BRIEF DESCRIPTION OF -C WHAT THE SUBPROGRAM DOES. -C -C PROGRAM HISTORY LOG: -C YY-MM-DD ORIGINAL PROGRAMMER'S NAME HERE -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL PROGRAM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... ) -C INPUT ARGUMENT LIST: -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS -C MACHINE: IBM SP -C -C$$$ -C*********************************************************************** -C* BFRHDR -C* -C* This subroutine reads a Jack Woollen BUFR encoding table file to -C* get the string of parameters to be written. This subroutine is -C* given the sequence nmemonic and returns the list associated with it. -C* This list is a character string and is used as the last input to -C* UFBINT. -C* -C* -C* BFRHDR ( LUNTBL, CSEQN, PRFFLG, CLIST, NP, IRET ) -C* -C* Input parameters: -C* LUNTBL INTEGER Unit number of BUFR Table file -C* CSEQN CHAR* Sequence mnemonic -C* PRFFLG LOGICAL Flag for profile parms -C* = .true. for multi-level parms -C* -C* Output parameters: -C* CLIST CHAR* String of parm names -C* NP INTEGER Number of parm names in string -C* IRET INTEGER Return code -C* 0 = normal return -C* -1 = Improper table file -C* -2 = Sequence not found -C** -C* Log: -C* K. Brill/NMC 05/94 -C*********************************************************************** -C* - CHARACTER*(*) cseqn, clist - LOGICAL prfflg -C* - LOGICAL found - CHARACTER*80 sbuf -C -C* Set starting column number of parameter list in the table. -C - DATA istart / 14 / -C----------------------------------------------------------------------- - iret = 0 -C -C* Count the number of lines to end of file (used to reposition -C* pointer to original line at the end). -C - found = .true. - lcnt = 1 - DO WHILE ( found ) - READ ( luntbl, 1000, IOSTAT=ios ) sbuf -1000 FORMAT (A) - IF ( ios .ne. 0 ) THEN - found = .false. - ELSE - lcnt = lcnt + 1 - END IF - END DO -C -C* Read from the file for positioning. -C - REWIND luntbl - found = .false. - DO WHILE ( .not. found ) - READ (luntbl, 1000, IOSTAT=ios ) sbuf - IF ( ios .ne. 0 ) THEN - iret = -1 - RETURN - END IF - iq1 = INDEX ( sbuf, '| REFERENCE' ) - iq2 = INDEX ( sbuf, '| UNITS' ) - iq = iq1 * iq2 - IF ( iq .ne. 0 ) found = .true. - END DO -C -C* Get length of sequence mnemonic string. -C - lc = LEN ( cseqn ) - DO WHILE ( cseqn ( lc:lc ) .eq. ' ' ) - lc = lc-1 - END DO -C -C* Start searching backward for the sequence mnemonic. -C - found = .false. - lenc=0 - DO WHILE ( .not. found ) - BACKSPACE luntbl - READ ( luntbl, 1000, IOSTAT=ios ) sbuf - IF ( ios .ne. 0 .or. sbuf (1:2) .eq. '.-' ) THEN - iret = -2 - RETURN - END IF - BACKSPACE luntbl - iq = INDEX ( sbuf ( 1:14 ), cseqn ( 1:lc ) ) - IF ( iq .ne. 0 ) THEN - found = .true. -C -C* Find the last character of last parameter. -C - i = 79 - DO WHILE ( sbuf ( i:i ) .eq. ' ' ) - i = i - 1 - END DO - clist = ' ' - clist = sbuf ( istart:i ) -C -C* Count the number of entries in CLIST. -C - lenc = i - istart + 1 - nspcs = 0 - np = 0 - DO j = 1, lenc - IF ( clist ( j:j ) .eq. ' ' ) nspcs = nspcs + 1 - END DO - np = nspcs + 1 -C -C* Handle profile sequence. -C - IF ( prfflg ) THEN -C sbuf = cseqn ( 1:lc ) // '^ ' // clist ( 1:lenc ) - sbuf = clist ( 1:lenc ) - clist = sbuf - END IF - END IF - END DO -C -C* Reposition file to original record. -C - found = .true. - DO WHILE ( found ) - READ ( luntbl, 1000, IOSTAT=ios ) sbuf - IF ( ios .ne. 0 ) found = .false. - END DO - DO k = 1, lcnt - BACKSPACE luntbl - END DO -C* - RETURN - END diff --git a/sorc/gfs_bufr.fd/bfrize.f b/sorc/gfs_bufr.fd/bfrize.f deleted file mode 100755 index 1183c62f34..0000000000 --- a/sorc/gfs_bufr.fd/bfrize.f +++ /dev/null @@ -1,241 +0,0 @@ - SUBROUTINE BFRIZE ( luntbl, lunbfr, sbset, iyr, imn, idy, ihr, - + seqnam, seqflg, nseq, lvlwise, data, nlvl, - + clist, npp, wrkd, iret ) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: PROGRAM NAME (up to 20 characters) -C PRGMMR: YOUR NAME ORG: W/NMCXX DATE: YY-MM-DD -C -C ABSTRACT: START ABSTRACT HERE AND INDENT TO COLUMN 5 ON THE -C FOLLOWING LINES. PLEASE PROVIDE A BRIEF DESCRIPTION OF -C WHAT THE SUBPROGRAM DOES. -C -C PROGRAM HISTORY LOG: -C YY-MM-DD ORIGINAL PROGRAMMER'S NAME HERE -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL PROGRAM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... ) -C INPUT ARGUMENT LIST: -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS -C MACHINE: IBM SP -C -C$$$ -C*********************************************************************** -C* BFRIZE -C* -C* This subroutine calls Jack Woollen's BUFR encoding routines to -C* write a BUFR message to an output file. SBSET is the Mnemonic -C* for the TABLE A entry associated with this message. It appears -C* in the table referenced by LUNTBL. If LUNTBL = 0, the output -C* BUFR file is closed. -C* -C* The data in the array DATA are ordered according to the individual -C* elements of the Sequences given in SEQNAM. The contents of SEQNAM -C* and SEQFLG and, consequently of DATA, are determined by the BUFR -C* table file referenced by LUNTBL. Each entry in SEQNAM has a list of -C* parameters associated with it in the table. This list is read from -C* the table and the number of parameters is determined. This -C* information is stored in CLIST and NPP for future calls to BFRIZE. -C* If the parameters associated with the entry in SEQNAM exist on NLVL -C* levels, the corresponding array element of SEQFLG must be .true.; -C* otherwise, it is .false. -C* -C* Profile data in array DATA may be stored such that contiguous -C* elements are values of different parameters on the same level -C* (parameter-wise storage) or the same parameter on different levels -C* (level-wise storage). If LVLWISE=.false. parameter-wise storage -C* is assumed; otherwise, LVLWISE=.true. and level-wise storage is -C* assumed. -C* -C* The example below shows the contents of SEQNAM, SEQFLG, and DATA -C* for a case when NLVL=3, LVLWISE=.true., and the table file has the -C* following entries for the Mnemonic Sequences: -C* -C* MNEMONIC | SEQUENCE -C* -C* MODELOUT | HDR {PROF} SFC -C* HDR | RLAT RLON -C* PROF | PRES TMPK -C* SFC | PMSL PRCP -C* -C* SEQNAM and SEQFLG have the following assigned entries: -C* -C* INDEX SEQNAM SEQFLG -C* 1 HDR .false. -C* 2 PROF .true. -C* 3 SFC .false. -C* -C* DATA must contain the following values in this order: -C* -C* DATA (1) = rlat DATA (6) = tmpk (1) -C* DATA (2) = rlon DATA (7) = tmpk (2) -C* DATA (3) = pres (1) DATA (8) = tmpk (3) -C* DATA (4) = pres (2) DATA (9) = pmsl -C* DATA (5) = pres (3) DATA (10) = prcp -C* -C* The lower-case names above signify numerical values of the -C* parameters. The values of multiple level parameters are stored -C* contiguously. -C* -C* To add a new output parameter, update the table file by adding the -C* Mnemonic for the parameter to an existing Sequence or by adding -C* a new Sequence. If a new Sequence has been added, SEQNAM and -C* SEQFLG must be updated accordingly. In any case, the new output -C* parameter value must be placed in the correct position within the -C* array DATA. -C* -C* CLIST contains the lists of parameter names for each element of -C* SEQNAM. If CLIST (1) is blank, BFRHDR is called with SEQNAM and -C* SEQFLG as inputs to load the names of the parameters into CLIST; -C* otherwise, the names in CLIST are used. For every element of -C* SEQNAM there is a corresponding element of CLIST. For each element -C* of CLIST, there is a corresponding element of NPP giving the number -C* of parameter names in the list. -C* -C* DATA (i) = 10.E+10 is the missing value. -C* -C* WRKD is a scratch array and should be dimensioned the same size as -C* data. WRKD is not used if LVLWISE=.false. -C* -C* BFRIZE ( LUNTBL, LUNBFR, SBSET, IYR, IMN, IDY, IHR, -C* SEQNAM, SEQFLG, NSEQ, LVLWISE, DATA, NLVL, CLIST, NPP, -C* WRKD, IRET ) -C* -C* Input parameters: -C* LUNTBL INTEGER Unit number of BUFR Table file -C* LUNBFR INTEGER Unit number of BUFR data file -C* SBSET CHAR* BUFR subset name -C* IYR INTEGER 4-digit year -C* IMN INTEGER 2-digit month -C* IDY INTEGER 2-digit day -C* IHR INTEGER 2-digit cycle hour -C* SEQNAM (NSEQ) CHAR* Mnemonic Sequence names -C* SEQFLG (NSEQ) LOGICAL Multi-level flag -C* NSEQ INTEGER Number of Sequence names & flags -C* LVLWISE LOGICAL Level-wise profile data flag -C* DATA (*) REAL Data array -C* NLVL INTEGER Number of levels -C* -C* Input and Output parameters: -C* CLIST (NSEQ) CHAR* Parameter name lists -C* NPP (NSEQ) INTEGER Number of parameter names -C* -C* Output parameters: -C* WRKD (*) REAL Array of reordered profile data -C* IRET INTEGER Return code -C* 0 = normal return -C** -C* Log: -C* K. Brill/NMC 05/94 -C* K. Brill/NMC 06/94 Added LVLWISE, CLIST, NPP, WRKD -C 98-08-28 ROZWODOSKI MADE CHANGES FOR Y2K COMPLIANCE. -C*********************************************************************** - REAL*8 data (*) - INTEGER npp (*), nlvl (*) - CHARACTER*(*) seqnam (*), sbset - LOGICAL seqflg (*), lvlwise - CHARACTER*(*) clist (*) - REAL*8 wrkd (*) -C----------------------------------------------------------------------- - iret = 0 -c print*,'Bufriz.f is creating bufr file' - -C -C* Close BUFR file if LUNTBL = 0. -C - IF ( luntbl .eq. 0 ) THEN - CALL CLOSBF ( lunbfr ) - RETURN - END IF -C -C* Check the status of the output BUFR file. -C - CALL STATUS ( lunbfr, lun, iopn, imm ) - IF ( iopn .eq. 0 ) THEN - CALL SETBLOCK(1) - CALL OPENBF ( lunbfr, 'OUT', luntbl ) - CALL DATELEN ( 10 ) - END IF -C -C* Open a new message. -C - idate = iyr * 1000000 + imn * 10000 + idy * 100 + ihr -c print *, 'Bufriz idate = ', idate - CALL OPENMB ( lunbfr, sbset, idate ) -C -C* Create the parameter name lists if CLIST (1) is blank. -C -c print *, 'clist (1) = ', clist(1) -c print *, 'npp (1) = ', npp(1) -c print *, 'seqnam (1) = ', seqnam(1) -c print *, 'seqflg (1) = ', seqflg(1) -c print *, 'nseq = ', nseq - IF ( clist (1) .eq. ' ' ) THEN - DO is = 1, nseq - CALL BFRHDR ( luntbl, seqnam (is), seqflg (is), - + clist (is), npp (is), iret ) - IF ( iret .ne. 0 ) RETURN - END DO - END IF -C -C* Load the sequences. -C - idpntr = 1 - indxlv = 0 - DO is = 1, nseq - np = npp (is) - IF ( seqflg (is) ) THEN - indxlv = indxlv + 1 - IF ( lvlwise ) THEN -C -C* This is level-wise multi-level data. -C - istrt = idpntr - indx = 0 - DO k = 1, nlvl (indxlv) - DO ip = 1, np - indx = indx + 1 - wrkd ( indx ) = - + data ( istrt + (ip-1) * nlvl (indxlv) ) - END DO - istrt = istrt + 1 - END DO - CALL UFBINT ( lunbfr, wrkd, np, nlvl (indxlv), - + irtrn, clist (is) ) - ELSE -C -C* This is parameter-wise multi-level data. -C - CALL UFBINT ( lunbfr, data (idpntr), np, - + nlvl (indxlv), irtrn, clist (is) ) - END IF - idpntr = idpntr + np * nlvl (indxlv) - ELSE -C -C* This is single-level data. -C - CALL UFBINT ( lunbfr, data (idpntr), - + np, 1, irtrn, clist (is) ) - idpntr = idpntr + np - END IF - END DO - CALL WRITSB ( lunbfr ) -C* - RETURN - END diff --git a/sorc/gfs_bufr.fd/buff.f b/sorc/gfs_bufr.fd/buff.f deleted file mode 100755 index 5441fbf5a8..0000000000 --- a/sorc/gfs_bufr.fd/buff.f +++ /dev/null @@ -1,92 +0,0 @@ - subroutine buff(nint1,nend1,nint3,nend3,npoint,idate,jdate,levs, - & dird,lss,istat,sbset,seqflg,clist,npp,wrkd) - character*150 dird, fnbufr, fmto -!! integer nint, nend, npoint, idate(4), levs, jdate - integer nint1, nend1, nint3, nend3 - integer npoint, idate(4), levs, jdate - real*8 data(6*levs+25), wrkd(1) - integer idtln, nf, nfile, np - integer lss, istat(npoint), ios - CHARACTER*150 FILESEQ - CHARACTER*8 SBSET - LOGICAL SEQFLG(4) - CHARACTER*80 CLIST(4) - INTEGER NPP(4) - CHARACTER*8 SEQNAM(4) - FMTO = '(A,".",I6.6,".",I10)' - idtln = 8 - nfile = 20 -C print *, 'inside buff.f nint1,nend1,nint3,nend3,jdate=' -C print *, nint1,nend1,nint3,nend3,jdate - do nf = 0, nend1, nint1 - nfile = nfile + 1 - rewind nfile - enddo - do nf = nend1+nint3, nend3, nint3 - nfile = nfile + 1 - rewind nfile - enddo - do np = 1, npoint -C OPEN BUFR OUTPUT FILE. - write(fnbufr,fmto) dird(1:lss),istat(np),jdate - print *, ' fnbufr =', fnbufr - open(unit=19,file=fnbufr,form='unformatted', - & status='new', iostat=ios) - IF ( ios .ne. 0 ) THEN - WRITE (6,*) ' CANNOT open ', 19 - STOP - END IF - CALL OPENBF ( 19, 'OUT', 1 ) - nfile = 20 - do nf = 0, nend1, nint1 - nfile = nfile + 1 - read(nfile) data - if(np.eq.1) then - print *, ' creating bufr file for np, nfile =', - & np, nfile - endif -CC WRITE DATA MESSAGE TO BUFR OUTPUT FILE. -CC LUNTBL=-9 BECAUSE BUFR TABLE FILE NOT USED HERE. -CC SEQNAM=XXXXXX BECAUSE MNEMONIC SEQUENCE NAMES NOT USED HERE. - CALL BFRIZE ( -9, 19, SBSET, - & idate(4), iDATE(2), - & iDATE(3), iDATE(1), - & 'XXXXXX', SEQFLG, 4, .FALSE., DATA, levs, - & CLIST, NPP, WRKD, IRET ) - IF ( IRET .NE. 0 ) THEN - PRINT *,' BFRIZE FAILED ' - ENDIF -c 300 continue - enddo -C 3hourly output starts here -!! print *, 'buff.f nfile,nend1+nint3,nend3,nint3=' -!! print *, nfile,nend1+nint3,nend3,nint3 - do nf = nend1+nint3, nend3, nint3 - nfile = nfile + 1 - read(nfile) data - if(np.eq.1) then - print *, ' creating bufr file for np, nfile =', - & np, nfile - endif -C print *, 'read2 in fort(nfile) =', nfile -CC WRITE DATA MESSAGE TO BUFR OUTPUT FILE. -CC LUNTBL=-9 BECAUSE BUFR TABLE FILE NOT USED HERE. -CC SEQNAM=XXXXXX BECAUSE MNEMONIC SEQUENCE NAMES NOT USED HERE. - CALL BFRIZE ( -9, 19, SBSET, - & idate(4), iDATE(2), - & iDATE(3), iDATE(1), - & 'XXXXXX', SEQFLG, 4, .FALSE., DATA, levs, - & CLIST, NPP, WRKD, IRET ) - IF ( IRET .NE. 0 ) THEN - PRINT *,' BFRIZE FAILED ' - ENDIF - enddo - CALL BFRIZE ( 0, 19, SBSET, - & IDATE(4), IDATE(2), - & IDATE(3), IDATE(1), - & 'XXXXXX', SEQFLG, 4, .FALSE., DATA, levs, - & CLIST, NPP, WRKD, IRET ) - call closbf(19) - enddo - return - end diff --git a/sorc/gfs_bufr.fd/calpreciptype.f b/sorc/gfs_bufr.fd/calpreciptype.f deleted file mode 100644 index 2307231337..0000000000 --- a/sorc/gfs_bufr.fd/calpreciptype.f +++ /dev/null @@ -1,1616 +0,0 @@ -SUBROUTINE CALPRECIPTYPE(kdt,nrcm,im,ix,lm,lp1,randomno, & - xlat,xlon, & - gt0,gq0,prsl,prsi,PREC, & !input - phii,n3dfercld,TSKIN,SR,phy_f3d, & !input - DOMR,DOMZR,DOMIP,DOMS) !output -! SUBROUTINE CALPRECIPTYPE(nrcm,randomno,im,lm,lp1,T,Q,PMID,PINT,PREC, & !input -! ZINT,n3dfercld,TSKIN,SR,F_RimeF, & !input -! DOMR,DOMZR,DOMIP,DOMS) !output -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: CALPRECIPTYPE COMPUTE DOMINANT PRECIP TYPE -! PRGRMMR: CHUANG ORG: W/NP2 DATE: 2008-05-28 -! -! -! ABSTRACT: -! THIS ROUTINE COMPUTES PRECIPITATION TYPE. -! . It is adopted from post but was made into a column to used by GFS model -! -! -! use vrbls3d -! use vrbls2d -! use soil -! use masks -! use params_mod -! use ctlblk_mod -! use rqstfld_mod - USE FUNCPHYS, ONLY : gfuncphys,fpvs,ftdp,fpkap,ftlcl,stma,fthe - USE PHYSCONS -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! INCLUDE "mpif.h" -! -! IN NGM SUBROUTINE OUTPUT WE FIND THE FOLLOWING COMMENT. -! "IF THE FOLLOWING THRESHOLD VALUES ARE CHANGED, CONTACT -! TDL/SYNOPTIC-SCALE TECHNIQUES BRANCH (PAUL DALLAVALLE -! AND JOHN JENSENIUS). THEY MAY BE USING IT IN ONE OF -! THEIR PACKING CODES." THE THRESHOLD VALUE IS 0.01 INCH -! OR 2.54E-4 METER. PRECIPITATION VALUES LESS THAN THIS -! THRESHOLD ARE SET TO MINUS ONE TIMES THIS THRESHOLD. - - real,PARAMETER :: PTHRESH = 0.0 -! -! SET CELCIUS TO KELVIN AND SECOND TO HOUR CONVERSION. - integer,PARAMETER :: NALG = 5 -! -! DECLARE VARIABLES. -! - integer,intent(in) :: kdt,nrcm,im,ix,lm,lp1,n3dfercld - real,intent(in) :: xlat(im),xlon(im) - real,dimension(im),intent(in) :: PREC,SR,TSKIN - real,intent(in) :: randomno(ix,nrcm) - real,dimension(ix,LM),intent(in) :: gt0,gq0,prsl,phy_f3d - real,dimension(ix,lp1),intent(in) :: prsi,phii - real,dimension(im),intent(out) :: DOMR,DOMZR,DOMIP,DOMS - INTEGER :: IWX1,IWX4,IWX5 - REAL :: IWX2,IWX3 - REAL :: ES,QC - REAL :: SLEET(NALG),RAIN(NALG),FREEZR(NALG),SNOW(NALG) - real,dimension(LM) :: T,Q,PMID,F_RimeF - real,dimension(lp1) :: pint,zint - REAL, ALLOCATABLE :: RH(:) - REAL(kind=kind_phys), ALLOCATABLE :: TD8(:) - integer :: I,IWX,ISNO,IIP,IZR,IRAIN,k,k1 - real :: time_vert,time_ncep,time_ramer,time_bourg,time_revised,& - time_dominant,btim,timef - real(kind=kind_phys) :: pv8,pr8,pk8,tr8,tdpd8,tlcl8,thelcl8 - real(kind=kind_phys) :: qwet8,t8(lm) - real(kind=kind_phys),allocatable :: twet8(:) - -! convert geopotential to height -! do l=1,lp1 -! zint(l)=zint(l)/con_g -! end do -! DON'T FORGET TO FLIP 3D ARRAYS AROUND BECAUSE GFS COUNTS FROM BOTTOM UP - - ALLOCATE ( RH(LM),TD8(LM),TWET8(LM) ) - -! Create look up table - call gfuncphys - - time_vert = 0. - time_ncep = 0. - time_ramer = 0. - time_bourg = 0. - time_revised = 0. - - do i=1,im -! print *, 'in calprecip xlat/xlon=', xlat(im),xlon(im),'levs=',lm - do k=1,lm - k1 = lm-k+1 - t8(k1) = gt0(i,k) - q(k1) = gq0(i,k) - pmid(k1) = prsl(i,k) - f_rimef(k1) = phy_f3d(i,k) - pv8 = pmid(k1)*q(k1)/(con_eps-con_epsm1*q(k1)) - td8(k1) = ftdp(pv8) - tdpd8 = t8(k1)-td8(k1) - if(pmid(k1)>=50000.)then ! only compute twet below 500mb to save time - if(tdpd8.gt.0.) then - pr8 = pmid(k1) - tr8 = t8(k1) - pk8 = fpkap(pr8) - tlcl8 = ftlcl(tr8,tdpd8) - thelcl8 = fthe(tlcl8,pk8*tlcl8/tr8) - call stma(thelcl8,pk8,twet8(k1),qwet8) - else - twet8(k1)=t8(k1) - endif - endif - ES = FPVS(T8(k1)) - ES = MIN(ES,PMID(k1)) - QC = CON_EPS*ES/(PMID(k1)+CON_EPSM1*ES) - RH(k1) = MAX(con_epsq,Q(k1))/QC - k1 = lp1-k+1 - pint(k1) = prsi(i,k) - zint(k1) = phii(i,k) !height in meters - enddo - pint(1) = prsi(i,lp1) - zint(1) = phii(i,lp1) - -! print*,'debug in calpreciptype: i,im,lm,lp1,xlon,xlat,prec,tskin,sr,nrcm,randomno,n3dfercld ', & -! i,im,lm,lp1,xlon(i)*57.29578,xlat(i)*57.29578,prec(i),tskin(i),sr(i), & -! nrcm,randomno(i,1:nrcm),n3dfercld -! do l=1,lm -! print*,'debug in calpreciptype: l,t,q,p,pint,z,twet', & -! l,t(l),q(l), & -! pmid(l),pint(l),zint(l),twet(l) -! end do -! print*,'debug in calpreciptype: lp1,pint,z ', lp1,pint(lp1),zint(lp1) -! end if -! end debug print statement - - CALL CALWXT(lm,lp1,T8(1),Q(1),PMID(1),PINT(1),PREC(i), & - PTHRESH,con_fvirt,con_rog,con_epsq, & - ZINT(1),IWX1,TWET8(1)) - IWX = IWX1 - ISNO = MOD(IWX,2) - IIP = MOD(IWX,4)/2 - IZR = MOD(IWX,8)/4 - IRAIN = IWX/8 - SNOW(1) = ISNO*1.0 - SLEET(1) = IIP*1.0 - FREEZR(1) = IZR*1.0 - RAIN(1) = IRAIN*1.0 -! print *, 'inside calprecip after calwxt iwx =',iwx -! DOMINANT PRECIPITATION TYPE -!GSM IF DOMINANT PRECIP TYPE IS REQUESTED, 4 MORE ALGORITHMS -!GSM WILL BE CALLED. THE TALLIES ARE THEN SUMMED IN -!GSM CALWXT_DOMINANT - - -! write(0,*)' i=',i,' lm=',lm,' lp1=',lp1,' T=',T(1),q(1),pmid(1) & -! &,' pint=',pint(1),' prec=',prec(i),' pthresh=',pthresh - - CALL CALWXT_RAMER(lm,lp1,T8(1),Q(1),PMID(1),RH(1),TD8(1), & - PINT(1),PREC(i),PTHRESH,IWX2) -! - IWX = NINT(IWX2) - ISNO = MOD(IWX,2) - IIP = MOD(IWX,4)/2 - IZR = MOD(IWX,8)/4 - IRAIN = IWX/8 - SNOW(2) = ISNO*1.0 - SLEET(2) = IIP*1.0 - FREEZR(2) = IZR*1.0 - RAIN(2) = IRAIN*1.0 -! print *, 'inside calprecip after ramer iwx=',iwx -! BOURGOUIN ALGORITHM - CALL CALWXT_BOURG(LM,LP1,randomno(i,1),con_g,PTHRESH, & - & T8(1),Q(1),PMID(1),PINT(1),PREC(i),ZINT(1),IWX3) - -! - IWX = NINT(IWX3) - ISNO = MOD(IWX,2) - IIP = MOD(IWX,4)/2 - IZR = MOD(IWX,8)/4 - IRAIN = IWX/8 - SNOW(3) = ISNO*1.0 - SLEET(3) = IIP*1.0 - FREEZR(3) = IZR*1.0 - RAIN(3) = IRAIN*1.0 -! print *, 'inside calprecip after bourg iwx=',iwx - -! REVISED NCEP ALGORITHM - CALL CALWXT_REVISED(LM,LP1,T8(1),Q(1),PMID(1),PINT(1),PREC(i),PTHRESH, & - con_fvirt,con_rog,con_epsq,ZINT(1),TWET8(1),IWX4) - -! - IWX = IWX4 - ISNO = MOD(IWX,2) - IIP = MOD(IWX,4)/2 - IZR = MOD(IWX,8)/4 - IRAIN = IWX/8 - SNOW(4) = ISNO*1.0 - SLEET(4) = IIP*1.0 - FREEZR(4) = IZR*1.0 - RAIN(4) = IRAIN*1.0 -! print *, 'inside calprecip after revised iwx=',iwx -! EXPLICIT ALGORITHM (UNDER 18 NOT ADMITTED WITHOUT PARENT -! OR GUARDIAN) - - IF(n3dfercld == 3) then ! Ferrier's scheme - CALL CALWXT_EXPLICIT(LM,PTHRESH, & - TSKIN(i),PREC(i),SR(i),F_RimeF(1),IWX5) - else - IWX5 = 0 - endif -! - IWX = IWX5 - ISNO = MOD(IWX,2) - IIP = MOD(IWX,4)/2 - IZR = MOD(IWX,8)/4 - IRAIN = IWX/8 - SNOW(5) = ISNO*1.0 - SLEET(5) = IIP*1.0 - FREEZR(5) = IZR*1.0 - RAIN(5) = IRAIN*1.0 -! - CALL CALWXT_DOMINANT(NALG,PREC(i),PTHRESH,RAIN(1),FREEZR(1),SLEET(1), & - SNOW(1),DOMR(i),DOMZR(i),DOMIP(i),DOMS(i)) - -! if (DOMS(i).eq.1.) then -! print *, 'Found SNOW at xlat/xlon',xlat,xlon -! elseif (DOMR(i).eq.1.) then -! print *, 'Found RAIN at xlat/xlon',xlat,xlon -! elseif(DOMZR(i).eq.1.) then -! print *, 'Found FREEZING RAIN at xlat/xlon',xlat,xlon -! elseif(DOMIP(i).eq.1.) then -! print *, 'Found ICE at xlat/xlon',xlat,xlon -! endif -! print *, 'In calpre DOMS,DOMR,DOMZR,DOMIP =', int(DOMS),int(DOMR),int(DOMZR),int(DOMIP) - - enddo ! end loop for i - - DEALLOCATE (TWET8,RH,TD8) - RETURN - END -! -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -! - SUBROUTINE CALWXT(lm,lp1,T,Q,PMID,PINT,PREC, & - PTHRESH,D608,ROG,EPSQ, & - ZINT,IWX,TWET) -! -! FILE: CALWXT.f -! WRITTEN: 11 NOVEMBER 1993, MICHAEL BALDWIN -! REVISIONS: -! 30 SEPT 1994-SETUP NEW DECISION TREE (M BALDWIN) -! 12 JUNE 1998-CONVERSION TO 2-D (T BLACK) -! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -! 02-01-15 MIKE BALDWIN - WRF VERSION -! -! -! ROUTINE TO COMPUTE PRECIPITATION TYPE USING A DECISION TREE -! APPROACH THAT USES VARIABLES SUCH AS INTEGRATED WET BULB TEMP -! BELOW FREEZING AND LOWEST LAYER TEMPERATURE -! -! SEE BALDWIN AND CONTORNO PREPRINT FROM 13TH WEATHER ANALYSIS -! AND FORECASTING CONFERENCE FOR MORE DETAILS -! (OR BALDWIN ET AL, 10TH NWP CONFERENCE PREPRINT) -! -! use params_mod -! use ctlblk_mod -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! INPUT: -! T,Q,PMID,HTM,LMH,PREC,ZINT -! - integer,intent(in):: lm,lp1 -! real,intent(in):: pthresh - real,dimension(LM),intent(in) :: Q,PMID - real*8,dimension(LM),intent(in) :: T,TWET - real,dimension(LP1),intent(in) :: ZINT,PINT - integer,intent(out) :: IWX - real,intent(in) :: PREC,PTHRESH,D608,ROG,EPSQ -! real,intent(out) :: ZWET - - -! OUTPUT: -! IWX - INSTANTANEOUS WEATHER TYPE. -! ACTS LIKE A 4 BIT BINARY -! 1111 = RAIN/FREEZING RAIN/ICE PELLETS/SNOW -! WHERE THE ONE'S DIGIT IS FOR SNOW -! THE TWO'S DIGIT IS FOR ICE PELLETS -! THE FOUR'S DIGIT IS FOR FREEZING RAIN -! AND THE EIGHT'S DIGIT IS FOR RAIN -! -! INTERNAL: -! -! REAL, ALLOCATABLE :: TWET(:) - real, parameter :: D00=0.0 - integer KARR,LICEE - real TCOLD,TWARM - -! SUBROUTINES CALLED: -! WETBULB -! -! -! INITIALIZE WEATHER TYPE ARRAY TO ZERO (IE, OFF). -! WE DO THIS SINCE WE WANT IWX TO REPRESENT THE -! INSTANTANEOUS WEATHER TYPE ON RETURN. -! -! -! ALLOCATE LOCAL STORAGE -! - - integer L,LICE,IWRML,IFRZL - real PSFCK,TDCHK,A,TDKL,TDPRE,TLMHK,TWRMK,AREAS8,AREAP4, & - SURFW,SURFC,DZKL,AREA1,PINTK1,PINTK2,PM150,PKL,TKL,QKL - -! ALLOCATE ( TWET(LM) ) -! -!!$omp parallel do - IWX = 0 -! ZWET=SPVAL -! -!!$omp parallel do -!!$omp& private(a,pkl,psfck,qkl,tdchk,tdkl,tdpre,tkl) - -! -! SKIP THIS POINT IF NO PRECIP THIS TIME STEP -! - IF (PREC.LE.PTHRESH) GOTO 800 -! -! FIND COLDEST AND WARMEST TEMPS IN SATURATED LAYER BETWEEN -! 70 MB ABOVE GROUND AND 500 MB -! ALSO FIND HIGHEST SATURATED LAYER IN THAT RANGE -! -!meb - PSFCK=PINT(LM+1) -!meb - TDCHK=2.0 - 760 TCOLD=T(LM) - TWARM=T(LM) - LICEE=LM -! - DO 775 L=1,LM - QKL=Q(L) - QKL=MAX(EPSQ,QKL) - TKL=T(L) - PKL=PMID(L) -! -! SKIP PAST THIS IF THE LAYER IS NOT BETWEEN 70 MB ABOVE GROUND -! AND 500 MB -! - IF (PKL.LT.50000.0.OR.PKL.GT.PSFCK-7000.0) GOTO 775 - A=LOG(QKL*PKL/(6.1078*(0.378*QKL+0.622))) - TDKL=(237.3*A)/(17.269-A)+273.15 - TDPRE=TKL-TDKL - IF (TDPRE.LT.TDCHK.AND.TKL.LT.TCOLD) TCOLD=TKL - IF (TDPRE.LT.TDCHK.AND.TKL.GT.TWARM) TWARM=TKL - IF (TDPRE.LT.TDCHK.AND.L.LT.LICEE) LICEE=L - 775 CONTINUE -! -! IF NO SAT LAYER AT DEW POINT DEP=TDCHK, INCREASE TDCHK -! AND START AGAIN (BUT DON'T MAKE TDCHK > 6) -! - IF (TCOLD==T(LM).AND.TDCHK<6.0) THEN - TDCHK=TDCHK+2.0 - GOTO 760 - ENDIF - 800 CONTINUE -! -! LOWEST LAYER T -! - KARR=0 - IF (PREC.LE.PTHRESH) GOTO 850 - TLMHK=T(LM) -! -! DECISION TREE TIME -! - IF (TCOLD>269.15) THEN - IF (TLMHK.LE.273.15) THEN -! TURN ON THE FLAG FOR -! FREEZING RAIN = 4 -! IF ITS NOT ON ALREADY -! IZR=MOD(IWX(I,J),8)/4 -! IF (IZR.LT.1) IWX(I,J)=IWX(I,J)+4 - IWX=IWX+4 - GOTO 850 - ELSE -! TURN ON THE FLAG FOR -! RAIN = 8 -! IF ITS NOT ON ALREADY -! IRAIN=IWX(I,J)/8 -! IF (IRAIN.LT.1) IWX(I,J)=IWX(I,J)+8 - IWX=IWX+8 - GOTO 850 - ENDIF - ENDIF - KARR=1 - 850 CONTINUE -! -! COMPUTE WET BULB ONLY AT POINTS THAT NEED IT -! -! CALL WETBULB(lm,T,Q,PMID,KARR,TWET) -! CALL WETFRZLVL(TWET,ZWET) -! -!!$omp parallel do -!!$omp& private(area1,areap4,areas8,dzkl,ifrzl,iwrml,lice, -!!$omp& lmhk,pintk1,pintk2,pm150,psfck,surfc,surfw, -!!$omp& tlmhk,twrmk) - - IF(KARR.GT.0)THEN - LICE=LICEE -!meb - PSFCK=PINT(LM+1) -!meb - TLMHK=T(LM) - TWRMK=TWARM -! -! TWET AREA VARIABLES -! CALCULATE ONLY WHAT IS NEEDED -! FROM GROUND TO 150 MB ABOVE SURFACE -! FROM GROUND TO TCOLD LAYER -! AND FROM GROUND TO 1ST LAYER WHERE WET BULB T < 0.0 -! -! PINTK1 IS THE PRESSURE AT THE BOTTOM OF THE LAYER -! PINTK2 IS THE PRESSURE AT THE TOP OF THE LAYER -! -! AREAP4 IS THE AREA OF TWET ABOVE -4 C BELOW HIGHEST SAT LYR -! - AREAS8=D00 - AREAP4=D00 - SURFW =D00 - SURFC =D00 -! - DO 1945 L=LM,LICE,-1 - DZKL=ZINT(L)-ZINT(L+1) - AREA1=(TWET(L)-269.15)*DZKL - IF (TWET(L).GE.269.15) AREAP4=AREAP4+AREA1 - 1945 CONTINUE -! - IF (AREAP4.LT.3000.0) THEN -! TURN ON THE FLAG FOR -! SNOW = 1 -! IF ITS NOT ON ALREADY -! ISNO=MOD(IWX(I,J),2) -! IF (ISNO.LT.1) IWX(I,J)=IWX(I,J)+1 - IWX=IWX+1 - GO TO 1900 - ENDIF -! -! AREAS8 IS THE NET AREA OF TWET W.R.T. FREEZING IN LOWEST 150MB -! - PINTK1=PSFCK - PM150=PSFCK-15000. -! - DO 1955 L=LM,1,-1 - PINTK2=PINT(L) - IF(PINTK1.LT.PM150)GO TO 1950 - DZKL=ZINT(L)-ZINT(L+1) -! -! SUM PARTIAL LAYER IF IN 150 MB AGL LAYER -! - IF(PINTK2.LT.PM150) & - DZKL=T(L)*(Q(L)*D608+1.0)*ROG*LOG(PINTK1/PM150) - AREA1=(TWET(L)-273.15)*DZKL - AREAS8=AREAS8+AREA1 - 1950 PINTK1=PINTK2 - 1955 CONTINUE -! -! SURFW IS THE AREA OF TWET ABOVE FREEZING BETWEEN THE GROUND -! AND THE FIRST LAYER ABOVE GROUND BELOW FREEZING -! SURFC IS THE AREA OF TWET BELOW FREEZING BETWEEN THE GROUND -! AND THE WARMEST SAT LAYER -! - IFRZL=0 - IWRML=0 -! - DO 2050 L=LM,1,-1 - IF (IFRZL.EQ.0.AND.T(L).LT.273.15) IFRZL=1 - IF (IWRML.EQ.0.AND.T(L).GE.TWRMK) IWRML=1 -! - IF (IWRML.EQ.0.OR.IFRZL.EQ.0) THEN -! if(pmid(l) < 50000.)print*,'need twet above 500mb' - DZKL=ZINT(L)-ZINT(L+1) - AREA1=(TWET(L)-273.15)*DZKL - IF(IFRZL.EQ.0.AND.TWET(L).GE.273.15)SURFW=SURFW+AREA1 - IF(IWRML.EQ.0.AND.TWET(L).LE.273.15)SURFC=SURFC+AREA1 - ENDIF - 2050 CONTINUE - IF(SURFC.LT.-3000.0.OR. & - (AREAS8.LT.-3000.0.AND.SURFW.LT.50.0)) THEN -! TURN ON THE FLAG FOR -! ICE PELLETS = 2 -! IF ITS NOT ON ALREADY -! IIP=MOD(IWX(I,J),4)/2 -! IF (IIP.LT.1) IWX(I,J)=IWX(I,J)+2 - IWX=IWX+2 - GOTO 1900 - ENDIF -! - IF(TLMHK.LT.273.15) THEN -! TURN ON THE FLAG FOR -! FREEZING RAIN = 4 -! IF ITS NOT ON ALREADY -! IZR=MOD(IWX(K),8)/4 -! IF (IZR.LT.1) IWX(K)=IWX(K)+4 - IWX=IWX+4 - ELSE -! TURN ON THE FLAG FOR -! RAIN = 8 -! IF ITS NOT ON ALREADY -! IRAIN=IWX(K)/8 -! IF (IRAIN.LT.1) IWX(K)=IWX(K)+8 - IWX=IWX+8 - ENDIF - ENDIF - 1900 CONTINUE -!--------------------------------------------------------- -! DEALLOCATE (TWET) - - RETURN - END -! -! -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! -! DoPhase is a subroutine written and provided by Jim Ramer at NOAA/FSL -! -! Ramer, J, 1993: An empirical technique for diagnosing precipitation -! type from model output. Preprints, 5th Conf. on Aviation -! Weather Systems, Vienna, VA, Amer. Meteor. Soc., 227-230. -! -! CODE ADAPTED FOR WRF POST 24 AUGUST 2005 G MANIKIN -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! - SUBROUTINE CALWXT_RAMER(lm,lp1, & - T,Q,PMID,RH,TD,PINT,PREC,PTHRESH,PTYP) - -! SUBROUTINE dophase(pq, ! input pressure sounding mb -! + t, ! input temperature sounding K -! + pmid, ! input pressure -! + pint, ! input interface pressure -! + q, ! input spec humidityfraction -! + lmh, ! input number of levels in sounding -! + prec, ! input amount of precipitation -! + ptyp) ! output(2) phase 2=Rain, 3=Frzg, 4=Solid, -! 6=IP JC 9/16/99 -! use params_mod -! use CTLBLK_mod -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! - real,PARAMETER :: twice=266.55,rhprcp=0.80,deltag=1.02, & - & emelt=0.045,rlim=0.04,slim=0.85 - real,PARAMETER :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now -! - INTEGER*4 i, k1, lll, k2, toodry -! - REAL xxx ,mye, icefrac - integer,intent(in) :: lm,lp1 - real,DIMENSION(LM),intent(in) :: Q,PMID,RH - real*8,DIMENSION(LM),intent(in) :: T,TD - real,DIMENSION(LP1),intent(in) :: PINT - real,intent(in) :: PREC,PTHRESH - real,intent(out) :: PTYP -! - real,DIMENSION(LM) :: TQ,PQ,RHQ - real,DIMENSION(LM) :: TWQ -! - integer J,L,LEV,ii - real RHMAX,TWMAX,PTOP,dpdrh,twtop,rhtop,wgt1,wgt2, & - rhavg,dtavg,dpk,ptw,pbot -! real b,qtmp,rate,qc - real,external :: xmytw -! -! Initialize. - icefrac = -9999. -! - - PTYP = 0 - DO L = 1,LM - LEV = LP1 - L -! P(L)=PMID(L) -! QC=PQ0/P(L) * EXP(A2*(T(L)-A3)/(T(L)-A4)) -!GSM forcing Q (QTMP) to be positive to deal with negative Q values -! causing problems later in this subroutine -! QTMP=MAX(H1M12,Q(L)) -! RHQTMP(LEV)=QTMP/QC - RHQ(LEV) = RH(L) - PQ(LEV) = PMID(L) * 0.01 - TQ(LEV) = T(L) - enddo - - -! -! SKIP THIS POINT IF NO PRECIP THIS TIME STEP -! - IF (PREC <= PTHRESH) return - -! -!CC RATE RESTRICTION REMOVED BY JOHN CORTINAS 3/16/99 -! -! Construct wet-bulb sounding, locate generating level. - twmax = -999.0 - rhmax = 0.0 - k1 = 0 ! top of precip generating layer - k2 = 0 ! layer of maximum rh -! - IF (rhq(1) < rhprcp) THEN - toodry = 1 - ELSE - toodry = 0 - END IF -! - pbot = pq(1) -! NQ=LM - DO L = 1, lm -! xxx = tdofesat(esat(tq(L))*rhq(L)) - xxx = td(l) !HC: use TD consistent with GFS ice physics - if (xxx < -500.) return - twq(L) = xmytw(tq(L),xxx,pq(L)) - twmax = max(twq(L),twmax) - IF (pq(L) >= 400.0) THEN - IF (rhq(L) > rhmax) THEN - rhmax = rhq(L) - k2 = L - END IF -! - IF (L /= 1) THEN - IF (rhq(L) >= rhprcp .or. toodry == 0) THEN - IF (toodry /= 0) THEN - dpdrh = log(pq(L)/pq(L-1)) / (rhq(L)-RHQ(L-1)) - pbot = exp(log(pq(L))+(rhprcp-rhq(L))*dpdrh) -! - ptw = pq(L) - toodry = 0 - ELSE IF (rhq(L)>= rhprcp) THEN - ptw = pq(L) - ELSE - toodry = 1 - dpdrh = log(pq(L)/pq(L-1)) / (rhq(L)-rhq(L-1)) - ptw = exp(log(pq(L))+(rhprcp-rhq(L))*dpdrh) - -!lin dpdrh = (Pq(i)-Pq(i-1))/(Rhq(i)-Rhq(i-1)) -!lin ptw = Pq(i)+(rhprcp-Rhq(i))*dpdrh -! - END IF -! - IF (pbot/ptw >= deltag) THEN -!lin If (pbot-ptw.lt.deltag) Goto 2003 - k1 = L - ptop = ptw - END IF - END IF - END IF - END IF - enddo -! -! Gross checks for liquid and solid precip which dont require generating level. -! - IF (twq(1) >= 273.15+2.0) THEN - ptyp = 8 ! liquid - icefrac = 0.0 - return - END IF -! - IF (twmax <= twice) THEN - icefrac = 1.0 - ptyp = 1 ! solid - return - END IF -! -! Check to see if we had no success with locating a generating level. -! - IF (k1 == 0) return -! - IF (ptop == pq(k1)) THEN - twtop = twq(k1) - rhtop = rhq(k1) - k2 = k1 - k1 = k1 - 1 - ELSE - k2 = k1 - k1 = k1 - 1 - wgt1 = log(ptop/pq(k2)) / log(pq(k1)/pq(k2)) - wgt2 = 1.0 - wgt1 - twtop = twq(k1) * wgt1 + twq(k2) * wgt2 - rhtop = rhq(k1) * wgt1 + rhq(k2) * wgt2 - END IF -! -! Calculate temp and wet-bulb ranges below precip generating level. - DO L = 1, k1 - twmax = max(twq(l),twmax) - enddo -! -! Gross check for solid precip, initialize ice fraction. -! IF (i.eq.1.and.j.eq.1) WRITE (*,*) 'twmax=',twmax,twice,'twtop=',twtop - - IF (twtop <= twice) THEN - icefrac = 1.0 - IF (twmax <= twmelt) THEN ! gross check for solid precip. - ptyp = 1 ! solid precip - return - END IF - lll = 0 - ELSE - icefrac = 0.0 - lll = 1 - END IF -! -! Loop downward through sounding from highest precip generating level. - 30 CONTINUE -! - IF (icefrac >= 1.0) THEN ! starting as all ice - IF (twq(k1) < twmelt) GO TO 40 ! cannot commence melting - IF (twq(k1) == twtop) GO TO 40 ! both equal twmelt, nothing h - wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) - rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 - dtavg = (twmelt-twq(k1)) * 0.5 - dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(Pq(k1)-Ptop) -! mye=emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - ELSE IF (icefrac <= 0.0) THEN ! starting as all liquid - lll = 1 -! Goto 1020 - IF (twq(k1) > twice) GO TO 40 ! cannot commence freezing - IF (twq(k1) == twtop) THEN - wgt1 = 0.5 - ELSE - wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) - END IF - rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 - dtavg = twmelt - (twq(k1)+twice) * 0.5 - dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(Pq(k1)-Ptop) -! mye = emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - ELSE IF ((twq(k1) <= twmelt).and.(twq(k1) < twmelt)) THEN ! mix - rhavg = (rhq(k1)+rhtop) * 0.5 - dtavg = twmelt - (twq(k1)+twtop) * 0.5 - dpk = log(pq(k1)/ptop) !lin dpk=Pq(k1)-Ptop -! mye = emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - ELSE ! mix where Tw curve crosses twmelt in layer - IF (twq(k1) == twtop) GO TO 40 ! both equal twmelt, nothing h - wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) - wgt2 = 1.0 - wgt1 - rhavg = rhtop + wgt2 * (rhq(k1)-rhtop) * 0.5 - dtavg = (twmelt-twtop) * 0.5 - dpk = wgt2 * log(pq(k1)/ptop) !lin dpk=wgt2*(Pq(k1)-Ptop) -! mye = emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - icefrac = min(1.0,max(icefrac,0.0)) - IF (icefrac <= 0.0) THEN -! Goto 1020 - IF (twq(k1) > twice) GO TO 40 ! cannot commence freezin - wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) - dtavg = twmelt - (twq(k1)+twice) * 0.5 - ELSE - dtavg = (twmelt-twq(k1)) * 0.5 - END IF - rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 - dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(Pq(k1)-Ptop) -! mye = emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - END IF -! - icefrac = min(1.0,max(icefrac,0.0)) - -! IF (i.eq.1.and.j.eq.1) WRITE (*,*) 'NEW ICEFRAC:', icefrac, icefrac -! -! Get next level down if there is one, loop back. - 40 continue - IF (k1 > 1) THEN - twtop = twq(k1) - ptop = pq(k1) - rhtop = rhq(k1) - k1 = k1 - 1 - GO TO 30 - END IF -! -! Determine precip type based on snow fraction and surface wet-bulb. -! - IF (icefrac >= slim) THEN - IF (lll /= 0) THEN - ptyp = 2 ! Ice Pellets JC 9/16/99 - ELSE - ptyp = 1 ! Snow - END IF - ELSE IF (icefrac <= rlim) THEN - IF (twq(1).lt.tz) THEN - ptyp = 4 ! Freezing Precip - ELSE - ptyp = 8 ! Rain - END IF - ELSE - IF (twq(1) < tz) THEN -!GSM not sure what to do when 'mix' is predicted; In previous -!GSM versions of this code for which I had to have an answer, -!GSM I chose sleet. Here, though, since we have 4 other -!GSM algorithms to provide an answer, I will not declare a -!GSM type from the Ramer in this situation and allow the -!GSM other algorithms to make the call. - - ptyp = 0 ! don't know -! ptyp = 5 ! Mix - ELSE -! ptyp = 5 ! Mix - ptyp = 0 ! don't know - END IF - END IF - - RETURN -! - END -! -! -!-------------------------------------------------------------------------- -! REAL*4 FUNCTION mytw(t,td,p) - FUNCTION xmytw(t,td,p) -! - IMPLICIT NONE -! - INTEGER*4 cflag, l -! REAL*4 f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & - REAL f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & - & de, xmytw - DATA f, c0, c1, c2 /0.0006355, 26.66082, 0.0091379024, 6106.3960/ -! -! - xmytw = (t+td) / 2 - IF (td.ge.t) RETURN -! - IF (t.lt.100.0) THEN - k = t + 273.15 - kd = td + 273.15 - IF (kd.ge.k) RETURN - cflag = 1 - ELSE - k = t - kd = td - cflag = 0 - END IF -! - ed = c0 - c1 * kd - c2 / kd - IF (ed.lt.-14.0.or.ed.gt.7.0) RETURN - ed = exp(ed) - ew = c0 - c1 * k - c2 / k - IF (ew.lt.-14.0.or.ew.gt.7.0) RETURN - ew = exp(ew) - fp = p * f - s = (ew-ed) / (k-kd) - kw = (k*fp+kd*s) / (fp+s) -! - DO 10 l = 1, 5 - ew = c0 - c1 * kw - c2 / kw - IF (ew.lt.-14.0.or.ew.gt.7.0) RETURN - ew = exp(ew) - de = fp * (k-kw) + ed - ew - IF (abs(de/ew).lt.1E-5) GO TO 20 - s = ew * (c1-c2/(kw*kw)) - fp - kw = kw - de / s - 10 CONTINUE - 20 CONTINUE -! -! print *, 'kw ', kw - IF (cflag.ne.0) THEN - xmytw = kw - 273.15 - ELSE - xmytw = kw - END IF -! - RETURN - END -! -! -!$$$ Subprogram documentation block -! -! Subprogram: calwxt_bourg Calculate precipitation type (Bourgouin) -! Prgmmr: Baldwin Org: np22 Date: 1999-07-06 -! -! Abstract: This routine computes precipitation type -! using a decision tree approach that uses the so-called -! "energy method" of Bourgouin of AES (Canada) 1992 -! -! Program history log: -! 1999-07-06 M Baldwin -! 1999-09-20 M Baldwin make more consistent with bourgouin (1992) -! 2005-08-24 G Manikin added to wrf post -! 2007-06-19 M Iredell mersenne twister, best practices -! 2008-03-03 G Manikin added checks to prevent stratospheric warming -! episodes from being seen as "warm" layers -! impacting precip type -! -! Usage: call calwxt_bourg(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & -! & iseed,g,pthresh, & -! & t,q,pmid,pint,lmh,prec,zint,ptype) -! Input argument list: -! im integer i dimension -! jm integer j dimension -! jsta_2l integer j dimension start point (including haloes) -! jend_2u integer j dimension end point (including haloes) -! jsta integer j dimension start point (excluding haloes) -! jend integer j dimension end point (excluding haloes) -! lm integer k dimension -! lp1 integer k dimension plus 1 -! iseed integer random number seed -! g real gravity (m/s**2) -! pthresh real precipitation threshold (m) -! t real(im,jsta_2l:jend_2u,lm) mid layer temp (K) -! q real(im,jsta_2l:jend_2u,lm) specific humidity (kg/kg) -! pmid real(im,jsta_2l:jend_2u,lm) mid layer pressure (Pa) -! pint real(im,jsta_2l:jend_2u,lp1) interface pressure (Pa) -! lmh real(im,jsta_2l:jend_2u) max number of layers -! prec real(im,jsta_2l:jend_2u) precipitation (m) -! zint real(im,jsta_2l:jend_2u,lp1) interface height (m) -! Output argument list: -! ptype real(im,jm) instantaneous weather type () -! acts like a 4 bit binary -! 1111 = rain/freezing rain/ice pellets/snow -! where the one's digit is for snow -! the two's digit is for ice pellets -! the four's digit is for freezing rain -! and the eight's digit is for rain -! in other words... -! ptype=1 snow -! ptype=2 ice pellets/mix with ice pellets -! ptype=4 freezing rain/mix with freezing rain -! ptype=8 rain -! -! Modules used: -! mersenne_twister pseudo-random number generator -! -! Subprograms called: -! random_number pseudo-random number generator -! -! Attributes: -! Language: Fortran 90 -! -! Remarks: vertical order of arrays must be layer 1 = top -! and layer lmh = bottom -! -!$$$ - subroutine calwxt_bourg(lm,lp1,rn,g,pthresh, & - & t,q,pmid,pint,prec,zint,ptype) -! use mersenne_twister - implicit none -! -! input: - integer,intent(in):: lm,lp1 -! integer,intent(in):: iseed - real,intent(in):: g,pthresh,rn - real*8,intent(in):: t(lm) - real,intent(in):: q(lm) - real,intent(in):: pmid(lm) - real,intent(in):: pint(lp1) - real,intent(in):: prec - real,intent(in):: zint(lp1) -! -! output: - real,intent(out):: ptype -! - integer ifrzl,iwrml,l,lhiwrm - real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck -! -! initialize weather type array to zero (ie, off). -! we do this since we want ptype to represent the -! instantaneous weather type on return. -! -!!$omp parallel do - - ptype = 0 - -! -! call random_number(rn,iseed) -! -!!$omp parallel do -!!$omp& private(a,tlmhk,iwrml,psfck,lhiwrm,pintk1,pintk2,area1, -!!$omp& areape,dzkl,surfw,r1,r2) - - psfck=pint(lm+1) -! -! skip this point if no precip this time step -! - if (prec.le.pthresh) return -! find the depth of the warm layer based at the surface -! this will be the cut off point between computing -! the surface based warm air and the warm air aloft -! -! -! lowest layer t -! - tlmhk = t(lm) - iwrml = lm + 1 - if (tlmhk.ge.273.15) then - do l = lm, 2, -1 - if (t(l).ge.273.15.and.t(l-1).lt.273.15.and. & - & iwrml.eq.lm+1) iwrml = l - end do - end if -! -! now find the highest above freezing level -! - lhiwrm = lm + 1 - do l = lm, 1, -1 -! gsm added 250 mb check to prevent stratospheric warming situations -! from counting as warm layers aloft - if (t(l).ge.273.15 .and. pmid(l).gt.25000.) lhiwrm = l - end do - -! energy variables -! surfw is the positive energy between the ground -! and the first sub-freezing layer above ground -! areane is the negative energy between the ground -! and the highest layer above ground -! that is above freezing -! areape is the positive energy "aloft" -! which is the warm energy not based at the ground -! (the total warm energy = surfw + areape) -! -! pintk1 is the pressure at the bottom of the layer -! pintk2 is the pressure at the top of the layer -! dzkl is the thickness of the layer -! ifrzl is a flag that tells us if we have hit -! a below freezing layer -! - pintk1 = psfck - ifrzl = 0 - areane = 0.0 - areape = 0.0 - surfw = 0.0 - - do l = lm, 1, -1 - if (ifrzl.eq.0.and.t(l).le.273.15) ifrzl = 1 - pintk2=pint(l) - dzkl=zint(l)-zint(l+1) - area1 = log(t(l)/273.15) * g * dzkl - if (t(l).ge.273.15.and. pmid(l).gt.25000.) then - if (l.lt.iwrml) areape = areape + area1 - if (l.ge.iwrml) surfw = surfw + area1 - else - if (l.gt.lhiwrm) areane = areane + abs(area1) - end if - pintk1 = pintk2 - end do - -! -! decision tree time -! - if (areape.lt.2.0) then -! very little or no positive energy aloft, check for -! positive energy just above the surface to determine rain vs. snow - if (surfw.lt.5.6) then -! not enough positive energy just above the surface -! snow = 1 - ptype = 1 - else if (surfw.gt.13.2) then -! enough positive energy just above the surface -! rain = 8 - ptype = 8 - else -! transition zone, assume equally likely rain/snow -! picking a random number, if <=0.5 snow - if (rn.le.0.5) then -! snow = 1 - ptype = 1 - else -! rain = 8 - ptype = 8 - end if - end if -! - else -! some positive energy aloft, check for enough negative energy -! to freeze and make ice pellets to determine ip vs. zr - if (areane.gt.66.0+0.66*areape) then -! enough negative area to make ip, -! now need to check if there is enough positive energy -! just above the surface to melt ip to make rain - if (surfw.lt.5.6) then -! not enough energy at the surface to melt ip -! ice pellets = 2 - ptype = 2 - else if (surfw.gt.13.2) then -! enough energy at the surface to melt ip -! rain = 8 - ptype = 8 - else -! transition zone, assume equally likely ip/rain -! picking a random number, if <=0.5 ip - if (rn.le.0.5) then -! ice pellets = 2 - ptype = 2 - else -! rain = 8 - ptype = 8 - end if - end if - else if (areane.lt.46.0+0.66*areape) then -! not enough negative energy to refreeze, check surface temp -! to determine rain vs. zr - if (tlmhk.lt.273.15) then -! freezing rain = 4 - ptype = 4 - else -! rain = 8 - ptype = 8 - end if - else -! transition zone, assume equally likely ip/zr -! picking a random number, if <=0.5 ip - if (rn.le.0.5) then -! still need to check positive energy -! just above the surface to melt ip vs. rain - if (surfw.lt.5.6) then -! ice pellets = 2 - ptype = 2 - else if (surfw.gt.13.2) then -! rain = 8 - ptype = 8 - else -! transition zone, assume equally likely ip/rain -! picking a random number, if <=0.5 ip - if (rn.le.0.25) then -! ice pellets = 2 - ptype = 2 - else -! rain = 8 - ptype = 8 - end if - end if - else -! not enough negative energy to refreeze, check surface temp -! to determine rain vs. zr - if (tlmhk.lt.273.15) then -! freezing rain = 4 - ptype = 4 - else -! rain = 8 - ptype = 8 - end if - end if - end if - end if -! end do -! end do - return - end -! -! - SUBROUTINE CALWXT_REVISED(LM,LP1,T,Q,PMID,PINT,PREC, & - PTHRESH,D608,ROG,EPSQ, & - & ZINT,TWET,IWX) -! -! FILE: CALWXT.f -! WRITTEN: 11 NOVEMBER 1993, MICHAEL BALDWIN -! REVISIONS: -! 30 SEPT 1994-SETUP NEW DECISION TREE (M BALDWIN) -! 12 JUNE 1998-CONVERSION TO 2-D (T BLACK) -! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT -! 02-01-15 MIKE BALDWIN - WRF VERSION -! 05-07-07 BINBIN ZHOU - ADD PREC FOR RSM -! 05-08-24 GEOFF MANIKIN - MODIFIED THE AREA REQUIREMENTS -! TO MAKE AN ALTERNATE ALGORITHM -! -! -! ROUTINE TO COMPUTE PRECIPITATION TYPE USING A DECISION TREE -! APPROACH THAT USES VARIABLES SUCH AS INTEGRATED WET BULB TEMP -! BELOW FREEZING AND LOWEST LAYER TEMPERATURE -! -! SEE BALDWIN AND CONTORNO PREPRINT FROM 13TH WEATHER ANALYSIS -! AND FORECASTING CONFERENCE FOR MORE DETAILS -! (OR BALDWIN ET AL, 10TH NWP CONFERENCE PREPRINT) -! -! SINCE THE ORIGINAL VERSION OF THE ALGORITHM HAS A HIGH BIAS -! FOR FREEZING RAIN AND SLEET, THE GOAL IS TO BALANCE THAT BIAS -! WITH A VERSION MORE LIKELY TO PREDICT SNOW -! -! use params_mod -! use ctlblk_mod -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! LIST OF VARIABLES NEEDED -! PARAMETERS: -! D608,ROG,H1,D00 -!HC PARAMETER(D608=0.608,ROG=287.04/9.8,H1=1.0,D00=0.0) -! -! INPUT: -! T,Q,PMID,HTM,LMH,PREC,ZINT - integer,intent(in):: lm,lp1 - REAL,dimension(LM),intent(in) :: Q,PMID - REAL*8,dimension(LM),intent(in) :: T,TWET - REAL,dimension(LP1),intent(in) :: PINT,ZINT - REAL,intent(in) :: PREC,PTHRESH,D608,ROG,EPSQ -! OUTPUT: -! IWX - INSTANTANEOUS WEATHER TYPE. -! ACTS LIKE A 4 BIT BINARY -! 1111 = RAIN/FREEZING RAIN/ICE PELLETS/SNOW -! WHERE THE ONE'S DIGIT IS FOR SNOW -! THE TWO'S DIGIT IS FOR ICE PELLETS -! THE FOUR'S DIGIT IS FOR FREEZING RAIN -! AND THE EIGHT'S DIGIT IS FOR RAIN - integer, intent(out) :: IWX -! INTERNAL: -! - real, parameter :: D00=0.0 - integer KARR,LICEE - real TCOLD,TWARM -! - integer L,LMHK,LICE,IWRML,IFRZL - real PSFCK,TDCHK,A,TDKL,TDPRE,TLMHK,TWRMK,AREAS8,AREAP4,AREA1, & - SURFW,SURFC,DZKL,PINTK1,PINTK2,PM150,QKL,TKL,PKL,AREA0, & - AREAP0 - -! SUBROUTINES CALLED: -! WETBULB -! -! -! INITIALIZE WEATHER TYPE ARRAY TO ZERO (IE, OFF). -! WE DO THIS SINCE WE WANT IWX TO REPRESENT THE -! INSTANTANEOUS WEATHER TYPE ON RETURN. -! -! -! ALLOCATE LOCAL STORAGE -! -! -!!$omp parallel do - IWX = 0 - -!!$omp parallel do -!!$omp& private(a,lmhk,pkl,psfck,qkl,tdchk,tdkl,tdpre,tkl) - - LMHK=LM -! -! SKIP THIS POINT IF NO PRECIP THIS TIME STEP -! - IF (PREC.LE.PTHRESH) GOTO 800 -! -! FIND COLDEST AND WARMEST TEMPS IN SATURATED LAYER BETWEEN -! 70 MB ABOVE GROUND AND 500 MB -! ALSO FIND HIGHEST SATURATED LAYER IN THAT RANGE -! -!meb - PSFCK=PINT(LP1) -!meb - TDCHK=2.0 - 760 TCOLD=T(LMHK) - TWARM=T(LMHK) - LICEE=LMHK -! - DO 775 L=1,LMHK - QKL=Q(L) - QKL=MAX(EPSQ,QKL) - TKL=T(L) - PKL=PMID(L) -! -! SKIP PAST THIS IF THE LAYER IS NOT BETWEEN 70 MB ABOVE GROUND -! AND 500 MB -! - IF (PKL.LT.50000.0.OR.PKL.GT.PSFCK-7000.0) GOTO 775 - A=LOG(QKL*PKL/(6.1078*(0.378*QKL+0.622))) - TDKL=(237.3*A)/(17.269-A)+273.15 - TDPRE=TKL-TDKL - IF (TDPRE.LT.TDCHK.AND.TKL.LT.TCOLD) TCOLD=TKL - IF (TDPRE.LT.TDCHK.AND.TKL.GT.TWARM) TWARM=TKL - IF (TDPRE.LT.TDCHK.AND.L.LT.LICEE) LICEE=L - 775 CONTINUE -! -! IF NO SAT LAYER AT DEW POINT DEP=TDCHK, INCREASE TDCHK -! AND START AGAIN (BUT DON'T MAKE TDCHK > 6) -! - IF (TCOLD.EQ.T(LMHK).AND.TDCHK.LT.6.0) THEN - TDCHK=TDCHK+2.0 - GOTO 760 - ENDIF - 800 CONTINUE -! -! LOWEST LAYER T -! - KARR=0 - IF (PREC.LE.PTHRESH) GOTO 850 - LMHK=LM - TLMHK=T(LMHK) -! -! DECISION TREE TIME -! - IF (TCOLD.GT.269.15) THEN - IF (TLMHK.LE.273.15) THEN -! TURN ON THE FLAG FOR -! FREEZING RAIN = 4 -! IF ITS NOT ON ALREADY -! IZR=MOD(IWX,8)/4 -! IF (IZR.LT.1) IWX=IWX+4 - IWX=IWX+4 - GOTO 850 - ELSE -! TURN ON THE FLAG FOR -! RAIN = 8 -! IF ITS NOT ON ALREADY -! IRAIN=IWX/8 -! IF (IRAIN.LT.1) IWX=IWX+8 - IWX=IWX+8 - GOTO 850 - ENDIF - ENDIF - KARR=1 - 850 CONTINUE -! -!!$omp parallel do -!!$omp& private(area1,areap4,areap0,areas8,dzkl,ifrzl,iwrml,lice, -!!$omp& lmhk,pintk1,pintk2,pm150,psfck,surfc,surfw, -!!$omp& tlmhk,twrmk) - - IF(KARR.GT.0)THEN - LMHK=LM - LICE=LICEE -!meb - PSFCK=PINT(LP1) -!meb - TLMHK=T(LMHK) - TWRMK=TWARM -! -! TWET AREA VARIABLES -! CALCULATE ONLY WHAT IS NEEDED -! FROM GROUND TO 150 MB ABOVE SURFACE -! FROM GROUND TO TCOLD LAYER -! AND FROM GROUND TO 1ST LAYER WHERE WET BULB T < 0.0 -! -! PINTK1 IS THE PRESSURE AT THE BOTTOM OF THE LAYER -! PINTK2 IS THE PRESSURE AT THE TOP OF THE LAYER -! -! AREAP4 IS THE AREA OF TWET ABOVE -4 C BELOW HIGHEST SAT LYR -! AREAP0 IS THE AREA OF TWET ABOVE 0 C BELOW HIGHEST SAT LYR -! - AREAS8=D00 - AREAP4=D00 - AREAP0=D00 - SURFW =D00 - SURFC =D00 - -! - DO 1945 L=LMHK,LICE,-1 - DZKL=ZINT(L)-ZINT(L+1) - AREA1=(TWET(L)-269.15)*DZKL - AREA0=(TWET(L)-273.15)*DZKL - IF (TWET(L).GE.269.15) AREAP4=AREAP4+AREA1 - IF (TWET(L).GE.273.15) AREAP0=AREAP0+AREA0 - 1945 CONTINUE -! -! IF (AREAP4.LT.3000.0) THEN -! TURN ON THE FLAG FOR -! SNOW = 1 -! IF ITS NOT ON ALREADY -! ISNO=MOD(IWX,2) -! IF (ISNO.LT.1) IWX=IWX+1 -! IWX=IWX+1 -! GO TO 1900 -! ENDIF - IF (AREAP0.LT.350.0) THEN -! TURN ON THE FLAG FOR -! SNOW = 1 - IWX=IWX+1 - GOTO 1900 - ENDIF -! -! AREAS8 IS THE NET AREA OF TWET W.R.T. FREEZING IN LOWEST 150MB -! - PINTK1=PSFCK - PM150=PSFCK-15000. -! - DO 1955 L=LMHK,1,-1 - PINTK2=PINT(L) - IF(PINTK1.LT.PM150)GO TO 1950 - DZKL=ZINT(L)-ZINT(L+1) -! -! SUM PARTIAL LAYER IF IN 150 MB AGL LAYER -! - IF(PINTK2.LT.PM150) & - DZKL=T(L)*(Q(L)*D608+1.0)*ROG* & - LOG(PINTK1/PM150) - AREA1=(TWET(L)-273.15)*DZKL - AREAS8=AREAS8+AREA1 - 1950 PINTK1=PINTK2 - 1955 CONTINUE -! -! SURFW IS THE AREA OF TWET ABOVE FREEZING BETWEEN THE GROUND -! AND THE FIRST LAYER ABOVE GROUND BELOW FREEZING -! SURFC IS THE AREA OF TWET BELOW FREEZING BETWEEN THE GROUND -! AND THE WARMEST SAT LAYER -! - IFRZL=0 - IWRML=0 -! - DO 2050 L=LMHK,1,-1 - IF (IFRZL.EQ.0.AND.T(L).LT.273.15) IFRZL=1 - IF (IWRML.EQ.0.AND.T(L).GE.TWRMK) IWRML=1 -! - IF (IWRML.EQ.0.OR.IFRZL.EQ.0) THEN -! if(pmid(l) .lt. 50000.)print*,'twet needed above 500mb' - DZKL=ZINT(L)-ZINT(L+1) - AREA1=(TWET(L)-273.15)*DZKL - IF(IFRZL.EQ.0.AND.TWET(L).GE.273.15)SURFW=SURFW+AREA1 - IF(IWRML.EQ.0.AND.TWET(L).LE.273.15)SURFC=SURFC+AREA1 - ENDIF - 2050 CONTINUE - IF(SURFC.LT.-3000.0.OR. & - & (AREAS8.LT.-3000.0.AND.SURFW.LT.50.0)) THEN -! TURN ON THE FLAG FOR -! ICE PELLETS = 2 -! IF ITS NOT ON ALREADY -! IIP=MOD(IWX,4)/2 -! IF (IIP.LT.1) IWX=IWX+2 - IWX=IWX+2 - GOTO 1900 - ENDIF -! - IF(TLMHK.LT.273.15) THEN -! TURN ON THE FLAG FOR -! FREEZING RAIN = 4 -! IF ITS NOT ON ALREADY -! IZR=MOD(IWX(K),8)/4 -! IF (IZR.LT.1) IWX(K)=IWX(K)+4 - IWX=IWX+4 - ELSE -! TURN ON THE FLAG FOR -! RAIN = 8 -! IF ITS NOT ON ALREADY -! IRAIN=IWX(K)/8 -! IF (IRAIN.LT.1) IWX(K)=IWX(K)+8 - IWX=IWX+8 - ENDIF - ENDIF - 1900 CONTINUE -! print *, 'revised check ', IWX(500,800) - - RETURN - END -! -! - SUBROUTINE CALWXT_EXPLICIT(LM,PTHRESH,TSKIN,PREC,SR,F_RIMEF,IWX) -! -! FILE: CALWXT.f -! WRITTEN: 24 AUGUST 2005, G MANIKIN and B FERRIER -! -! ROUTINE TO COMPUTE PRECIPITATION TYPE USING EXPLICIT FIELDS -! FROM THE MODEL MICROPHYSICS - -! use params_mod -! use ctlblk_mod -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! LIST OF VARIABLES NEEDED -! PARAMETERS: -! -! INPUT: - integer, intent(in):: lm - real,intent(in):: TSKIN, PREC, SR,PTHRESH - REAL,intent(in):: F_RimeF(LM) - integer,intent(out) :: IWX - real SNOW -! real PSFC -! -! ALLOCATE LOCAL STORAGE -! -!!$omp parallel do - IWX = 0 - -!GSM THE RSM IS CURRENTLY INCOMPATIBLE WITH THIS ROUTINE -!GSM ACCORDING TO B FERRIER, THERE MAY BE A WAY TO WRITE -!GSM A VERSION OF THIS ALGORITHM TO WORK WITH THE RSM -!GSM MICROPHYSICS, BUT IT DOESN'T EXIST AT THIS TIME -!!$omp parallel do -!!$omp& private(psfc,tskin) - -! SKIP THIS POINT IF NO PRECIP THIS TIME STEP -! - IF (PREC.LE.PTHRESH) GOTO 800 -! -! A SNOW RATIO LESS THAN 0.5 ELIMINATES SNOW AND SLEET -! USE THE SKIN TEMPERATURE TO DISTINGUISH RAIN FROM FREEZING RAIN -! NOTE THAT 2-M TEMPERATURE MAY BE A BETTER CHOICE IF THE MODEL -! HAS A COLD BIAS FOR SKIN TEMPERATURE -! - IF (SR.LT.0.5) THEN -! SURFACE (SKIN) POTENTIAL TEMPERATURE AND TEMPERATURE. -! PSFC=PMID(LM) -! TSKIN=THS*(PSFC/P1000)**CAPA - - IF (TSKIN.LT.273.15) THEN -! FREEZING RAIN = 4 - IWX=IWX+4 - ELSE -! RAIN = 8 - IWX=IWX+8 - ENDIF - ELSE -! -! DISTINGUISH SNOW FROM SLEET WITH THE RIME FACTOR -! - IF(F_RimeF(LM).GE.10) THEN -! SLEET = 2 - IWX=IWX+2 - ELSE - SNOW = 1 - IWX=IWX+1 - ENDIF - ENDIF - 800 CONTINUE - 810 RETURN - END -! -! - SUBROUTINE CALWXT_DOMINANT(NALG,PREC,PTHRESH,RAIN,FREEZR,SLEET,SNOW, & - & DOMR,DOMZR,DOMIP,DOMS) -! -! WRITTEN: 24 AUGUST 2005, G MANIKIN -! -! THIS ROUTINE TAKES THE PRECIP TYPE SOLUTIONS FROM DIFFERENT -! ALGORITHMS AND SUMS THEM UP TO GIVE A DOMINANT TYPE -! -! use params_mod -! use ctlblk_mod -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none -! -! INPUT: - integer,intent(in) :: NALG - REAL, intent(in) :: PREC,PTHRESH - real,intent(out) :: DOMS,DOMR,DOMZR,DOMIP - real,DIMENSION(NALG),intent(in) :: RAIN,SNOW,SLEET,FREEZR - integer L - real TOTSN,TOTIP,TOTR,TOTZR -!-------------------------------------------------------------------------- -! write(6,*) 'into dominant' -!!$omp parallel do - DOMR = 0. - DOMS = 0. - DOMZR = 0. - DOMIP = 0. -! -!!$omp parallel do -!!$omp& private(totsn,totip,totr,totzr) -! SKIP THIS POINT IF NO PRECIP THIS TIME STEP - IF (PREC.LE.PTHRESH) GOTO 800 - TOTSN = 0. - TOTIP = 0. - TOTR = 0. - TOTZR = 0. -! LOOP OVER THE NUMBER OF DIFFERENT ALGORITHMS THAT ARE USED - DO 820 L = 1, NALG - IF (RAIN(L).GT. 0) THEN - TOTR = TOTR + 1 - GOTO 830 - ENDIF - - IF (SNOW(L).GT. 0) THEN - TOTSN = TOTSN + 1 - GOTO 830 - ENDIF - - IF (SLEET(L).GT. 0) THEN - TOTIP = TOTIP + 1 - GOTO 830 - ENDIF - - IF (FREEZR(L).GT. 0) THEN - TOTZR = TOTZR + 1 - GOTO 830 - ENDIF - 830 CONTINUE - 820 CONTINUE -! print *, 'Calprecip Total Rain, snow, sleet, freeze= ', & -! TOTR,TOTSN,TOTIP,TOTZR - -! TIES ARE BROKEN TO FAVOR THE MOST DANGEROUS FORM OF PRECIP -! FREEZING RAIN > SNOW > SLEET > RAIN - IF (TOTSN .GT. TOTIP) THEN - IF (TOTSN .GT. TOTZR) THEN - IF (TOTSN .GE. TOTR) THEN - DOMS = 1 - GOTO 800 - ELSE - DOMR = 1 - GOTO 800 - ENDIF - ELSE IF (TOTZR .GE. TOTR) THEN - DOMZR = 1 - GOTO 800 - ELSE - DOMR = 1 - GOTO 800 - ENDIF - ELSE IF (TOTIP .GT. TOTZR) THEN - IF (TOTIP .GE. TOTR) THEN - DOMIP = 1 - GOTO 800 - ELSE - DOMR = 1 - GOTO 800 - ENDIF - ELSE IF (TOTZR .GE. TOTR) THEN - DOMZR = 1 - GOTO 800 - ELSE - DOMR = 1 - GOTO 800 - ENDIF - 800 CONTINUE - RETURN - END - - - - - diff --git a/sorc/gfs_bufr.fd/calwxt_gfs_baldwin.f b/sorc/gfs_bufr.fd/calwxt_gfs_baldwin.f deleted file mode 100755 index 217dbbcc0c..0000000000 --- a/sorc/gfs_bufr.fd/calwxt_gfs_baldwin.f +++ /dev/null @@ -1,294 +0,0 @@ - SUBROUTINE CALWXT(T,Q,td,twet,P,PINT,LMH,IWX,nd) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: PROGRAM NAME (up to 20 characters) -C PRGMMR: YOUR NAME ORG: W/NMCXX DATE: YY-MM-DD -C -C ABSTRACT: START ABSTRACT HERE AND INDENT TO COLUMN 5 ON THE -C FOLLOWING LINES. PLEASE PROVIDE A BRIEF DESCRIPTION OF -C WHAT THE SUBPROGRAM DOES. -C -C PROGRAM HISTORY LOG: -C YY-MM-DD ORIGINAL PROGRAMMER'S NAME HERE -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL PROGRAM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... ) -C INPUT ARGUMENT LIST: -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS -C MACHINE: IBM SP -C -C$$$ -C -C FILE: CALWXT.f -C WRITTEN: 11 NOVEMBER 1993, MICHAEL BALDWIN -C REVISIONS: 4 April 94 - 1-d version intended for obs soundings -C 16 Sept 94 - compute all variables for possible -C future decsion tree modifications -C 14 Oct 94 - clean up 1-d version, use new -C decision tree -C -C ROUTINE TO COMPUTE PRECIPITATION TYPE USING A DECISION TREE -C APPROACH THAT USES VARIABLES SUCH AS INTEGRATED WET BULB TEMP -C BELOW FREEZING AND LOWEST LAYER TEMPERATURE -C -C SEE BALDWIN AND CONTORNO PREPRINT FROM 13TH WEATHER ANALYSIS -C AND FORECASTING CONFERENCE FOR MORE DETAILS -C - PARAMETER (LM=99) - PARAMETER (H1M12=1.E-12) -C -C LIST OF VARIABLES NEEDED -C PARAMETERS: -C D608,ROG,H1,D00 - PARAMETER(D608=0.608,ROG=287.04/9.8,H1=1.0,D00=0.0) -C -C INPUT: -C T,Q,td,twet,P,PINT,LMH -C -C T - Mid layer temp (K) -C Q - Mid layer spec hum (g/g) -C TD - Mid layer dew point temp (K) -C TWET - Mid layer wet bulb temp (K) -C P - Mid layer pressure (Pa) (linear average of interfacial -C pressures in log P) -C PINT - Interfacial pressure (Pa) -C LMH - Number of layers -c nd - 0 .. no print 1 .. print -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C NOTE: VERTICAL ORDER OF ARRAYS MUST BE LAYER 1 = TOP -C ---- . -C . -C . -C LAYER LMH = BOTTOM -C (JUST LIKE IN THE ETA MODEL) -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C -C INTERNAL: -C -C -C OUTPUT: -C IWX - INSTANTANEOUS WEATHER TYPE. -C ACTS LIKE A 4 BIT BINARY -C 1111 = RAIN/FREEZING RAIN/ICE PELLETS/SNOW -C WHERE THE ONE'S DIGIT IS FOR SNOW -C THE TWO'S DIGIT IS FOR ICE PELLETS -C THE FOUR'S DIGIT IS FOR FREEZING RAIN -C AND THE EIGHT'S DIGIT IS FOR RAIN -C -C------------------------------------------------------------- -C IN OTHER WORDS... -C -C IWX=1 SNOW -C IWX=2 ICE PELLETS/MIX WITH ICE PELLETS -C IWX=4 FREEZING RAIN/MIX WITH FREEZING RAIN -C IWX=8 RAIN -C------------------------------------------------------------- -C -C -C SUBROUTINES CALLED: -C WETBLB -C -C -C INITIALIZE WEATHER TYPE ARRAY TO ZERO (IE, OFF). -C WE DO THIS SINCE WE WANT IWX TO REPRESENT THE -C INSTANTANEOUS WEATHER TYPE ON RETURN. -C - DIMENSION T(LM+1),Q(LM),P(LM),PINT(LM+1),TWET(LM),TD(LM) -C - IWX = 0 - AREAS8=D00 - AREAN8=D00 - AREAPI=D00 - AREAP4=D00 - SURFW =D00 - SURFC =D00 -C -C NUMBER OF LEVELS -C - LMHK=LMH -C -C COMPUTE DEW POINTS, -C FIND COLDEST TEMP IN SATURATED LAYER BETWEEN -C 70 MB ABOVE GROUND AND 500 MB, -C AND FIND THE HIGHEST SAT LAYER, 'TIS THE ICE NUCL LEVEL. -C -C - PSFCK=PINT(LMHK+1) - TDCHK=2.0 - 1960 TCOLD=T(LMHK) - TWARM=T(LMHK) - LICE=LMHK - DO 1915 L=1,LMHK - QKL=Q(L) - QKL=AMAX1(H1M12,QKL) - TKL=T(L) - PKL=P(L) - tdkl = td(l) -C -C SKIP PAST THIS IF THE LAYER IS NOT BETWEEN 70 MB ABOVE GROUND -C AND 500 MB -C - IF (PKL.LT.50000.0.OR.PKL.GT.PSFCK-7000.0) GOTO 1915 - TDPRE=TKL-TDKL -C -C ALSO FIND THE HIGHEST SAT LAYER-USE FOR AREAPI,AREAP4 -C - IF (TDPRE.LT.TDCHK.AND.P(L).LT.P(LICE)) LICE=L - IF (TDPRE.LT.TDCHK.AND.TKL.GT.TWARM) TWARM=TKL - IF (TDPRE.LT.TDCHK.AND.TKL.LT.TCOLD) TCOLD=TKL - 1915 CONTINUE -C -C IF WE DONT HAVE A LAYER WITH DEW POINT DEP OF TDCHK OR LESS -C INCREASE TDCHK (UP TO 6 MAX) -C - IF (TCOLD.EQ.T(LMHK+1).AND.TDCHK.LT.6.0) THEN - TDCHK=TDCHK+2.0 - GOTO 1960 - ENDIF -C -C LOWEST LAYER T -C - TLMHK=T(LMHK+1) -C -C TWET AREA VARIABLES -C FROM GROUND TO 150 MB ABOVE SURFACE -C FROM GROUND TO TCOLD LAYER -C FROM GROUND TO 1ST LAYER WHERE T < 0.0 -C FROM GROUND TO TWARM LAYER -C -C PINTK1 IS THE PRESSURE AT THE BOTTOM OF THE LAYER -C PINTK2 IS THE PRESSURE AT THE TOP OF THE LAYER -C -C AREAPI IS THE AREA OF TWET ABOVE FREEZING BELOW TCOLD LYR -C AREAP4 IS THE AREA OF TWET ABOVE -4 C BELOW TCOLD LYR -C - PINTK1=PSFCK - DO 1945 L=LMHK,LICE,-1 - PINTK2=PINT(L) - DZKL=T(L)*(Q(L)*D608+H1)*ROG* - 1 ALOG(PINTK1/PINTK2) - AREA1=(TWET(L)-273.15)*DZKL - AREA2=(TWET(L)-269.15)*DZKL - IF (TWET(L).GE.273.15) AREAPI=AREAPI+AREA1 - IF (TWET(L).GE.269.15) AREAP4=AREAP4+AREA2 - PINTK1=PINTK2 - 1945 CONTINUE -C -C AREAS8 IS THE NET AREA OF TWET W.R.T. FREEZING IN LOWEST 150MB -C AREAN8 IS THE NET AREA OF TWET < FREEZING IN LOWEST 150MB -C - PINTK1=PSFCK - PM150=PSFCK-15000. - DO 1955 L=LMHK,1,-1 - PINTK2=PINT(L) - IF (PINTK1.LT.PM150) GOTO 1950 - DZKL=T(L)*(Q(L)*D608+H1)*ROG* - 1 ALOG(PINTK1/PINTK2) -C -C SUM PARTIAL LAYER IF IN 150 MB AGL LAYER -C - IF (PINTK2.LT.PM150) - & DZKL=T(L)*(Q(L)*D608+H1)*ROG* - 1 ALOG(PINTK1/PM150) - AREA1=(TWET(L)-273.15)*DZKL - AREAS8=AREAS8+AREA1 - IF(AREA1.LT.0.) AREAN8=AREAN8+AREA1 - 1950 PINTK1=PINTK2 - 1955 CONTINUE -C -C SURFW IS THE AREA OF TWET ABOVE FREEZING BETWEEN THE GROUND -C AND THE FIRST LAYER ABOVE GROUND BELOW FREEZING -C SURFC IS THE AREA OF TWET BELOW FREEZING BETWEEN THE GROUND -C AND THE TWARM LAYER -C - PINTK1=PSFCK - IFRZL=0 - IWRML=0 - DO 2050 L=LMHK,1,-1 - IF (IFRZL.EQ.0.AND.T(L).LE.273.15) IFRZL=1 - IF (IWRML.EQ.0.AND.T(L).GE.TWARM) IWRML=1 - PINTK2=PINT(L) - DZKL=T(L)*(Q(L)*D608+H1)*ROG* - 1 ALOG(PINTK1/PINTK2) - AREA1=(TWET(L)-273.15)*DZKL - IF (IFRZL.EQ.0) THEN - IF (TWET(L).GE.273.15) SURFW=SURFW+AREA1 - ENDIF - IF (IWRML.EQ.0) THEN - IF (TWET(L).LE.273.15) SURFC=SURFC+AREA1 - ENDIF - PINTK1=PINTK2 - 2050 CONTINUE -C -C DECISION TREE TIME -C - if(nd.eq.1) then - print *, ' tcold =', tcold - print *, ' tlmhk =', tlmhk - print *, ' areap4 =', areap4 - print *, ' areas8 =', areas8 - print *, ' surfw =', surfw - print *, ' surfc =', surfc -c print *, ' temp= ' -c print *, (t(k),k=1,lmhk+1) -c print *, ' tdew =' -c print *, (td(k),k=1,lmhk) -c print *, ' twet =' -c print *, (twet(k),k=1,lmhk) - endif - IF (TCOLD.GT.269.15) THEN - IF (TLMHK.LE.273.15) THEN -C TURN ON THE FLAG FOR -C FREEZING RAIN = 4 - IWX=4 - GOTO 1900 - ELSE -C TURN ON THE FLAG FOR -C RAIN = 8 - IWX=8 - GOTO 1900 - ENDIF - ENDIF -C - IF (AREAP4.LT.3000.0) THEN -C TURN ON THE FLAG FOR -C SNOW = 1 - IWX=1 - GOTO 1900 - ENDIF -C - IF (SURFC.LE.-3000.0.OR. - & (AREAS8.LE.-3000.0.AND.SURFW.LT.50.0)) THEN -C TURN ON THE FLAG FOR -C ICE PELLETS = 2 - IWX=2 - GOTO 1900 - ENDIF - IF (TLMHK.LT.273.15) THEN -C TURN ON THE FLAG FOR -C FREEZING RAIN = 4 - IWX=4 - ELSE -C TURN ON THE FLAG FOR -C RAIN = 8 - IWX=8 - ENDIF - 1900 CONTINUE - RETURN - END diff --git a/sorc/gfs_bufr.fd/calwxt_gfs_ramer.f b/sorc/gfs_bufr.fd/calwxt_gfs_ramer.f deleted file mode 100755 index 1faabf6214..0000000000 --- a/sorc/gfs_bufr.fd/calwxt_gfs_ramer.f +++ /dev/null @@ -1,364 +0,0 @@ -Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -C -C DoPhase is a subroutine written and provided by Jim Ramer at NOAA/FSL -C -C Ramer, J, 1993: An empirical technique for diagnosing precipitation -C type from model output. Preprints, 5th Conf. on Aviation -C Weather Systems, Vienna, VA, Amer. Meteor. Soc., 227-230. -C -Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -C - SUBROUTINE CALWXT1(pq,tq,qq,twq,tdq,nq,lm,ppt,ptyp,trace) -c SUBROUTINE dophase(pq, ! input pressure sounding mb -c + tq, ! input temperature sounding K -c + pq, | input pressure -c + qq, ! input spec humidityfraction -c + twq, ! input wet-bulb temperature -c + nq, ! input number of levels in sounding -c + twq, ! output wet-bulb sounding K -c + icefrac, ! output ice fraction -c + ptyp) ! output(2) phase 2=Rain, 3=Frzg, 4=Solid, -C 6=IP JC 9/16/99 - LOGICAL trace -c PARAMETER (trace = .false.) - PARAMETER (A2=17.2693882,A3=273.16,A4=35.86,PQ0=379.90516) - PARAMETER (G=9.80665,CP=1004.686,RCP=0.2857141,LECP=1572.5) - PARAMETER (twice=266.55,rhprcp=0.80,deltag=1.02,prcpmin=0.3, - * emelt=0.045,rlim=0.04,slim=0.85) - PARAMETER (twmelt=273.15,tz=273.15,efac=1.0,PTHRES=0.25) -c pthres is in unit of mm and is equivalent to .01 inch -C - INTEGER*4 i, k1, lll, k2, toodry, iflag, nq -C - INTEGER ptyp -C - REAL rcp, flg, flag, xxx, pq(lm), tq(lm), twq(lm), rhq(lm), mye, - * qq(lm), icefrac, tqtmp(lm), pqtmp(lm), rhqtmp(lm) - * ,twtmp(lm),qqtmp(lm),tdqtmp(lm),tdq(lm) -C - COMMON /flagflg/ flag, flg - DATA iflag / -9/ -C -C Initialize. - IF (trace) print *, '******* NEW STATION ******' - IF (trace) print *, 'Twmelt,Twice,rhprcp,Emelt' - IF (trace) print *, twmelt, twice, rhprcp, emelt - icefrac = flag - ptyp = 0 -c IF (PPT.LE.PTHRES) RETURN -C -C GSM compute RH, convert pressure to mb, and reverse order - - DO 88 i = 1, nq - LEV=NQ-I+1 -c QC=PQ0/PQ(I) * EXP(A2*(TQ(I)-A3)/(TQ(I)-A4)) - call svp(qc,es,pq(i),tq(i)) - RHQTMP(LEV)=QQ(I)/QC - PQTMP(LEV)=PQ(I)/100. - TQTMP(LEV)=TQ(I) - TWTMP(LEV)=TWQ(I) - QQTMP(LEV)=QQ(I) - TDQTMP(LEV)=TDQ(I) - 88 CONTINUE - - do 92 i=1,nq - TQ(I)=TQTMP(I) - PQ(I)=PQTMP(I) - RHQ(I)=RHQTMP(I) - TWQ(I)=TWTMP(I) - QQ(I)=QQTMP(I) - TDQ(I)=TDQTMP(I) - 92 continue - - -C See if there was too little precip reported. -C -CCC RATE RESTRICTION REMOVED BY JOHN CORTINAS 3/16/99 -C -C Construct wet-bulb sounding, locate generating level. - twmax = -999.0 - rhmax = 0.0 - k1 = 0 ! top of precip generating layer - k2 = 0 ! layer of maximum rh -C - IF (trace) WRITE (20,*) 'rhq(1)', rhq(1) - IF (rhq(1).lt.rhprcp) THEN - toodry = 1 - ELSE - toodry = 0 - END IF -C -C toodry=((Rhq(1).lt.rhprcp).and.1) - pbot = pq(1) - DO 10 i = 1, nq -c xxx = tdofesat(esat(tq(i))*rhq(i)) -c call tdew(xxx,tq(i),qq(i),pq(i)*100.) - xxx = tdq(i) - IF (trace) print *, 'T,Rh,Td,P,nq ', tq(i), rhq(i), xxx, - + pq(i), nq -c twq(i) = xmytw(tq(i),xxx,pq(i)) - IF (trace) print *, 'Twq(i),i ', twq(i), i - twmax = amax1(twq(i),twmax) - IF (trace) print *, 'Tw,Rh,P ', twq(i) - 273.15, rhq(i), - + pq(i) - IF (pq(i).ge.400.0) THEN - IF (rhq(i).gt.rhmax) THEN - rhmax = rhq(i) - k2 = i - IF (trace) print *, 'rhmax,k2,i', rhmax, k2, i - END IF -C - IF (i.ne.1) THEN - IF (trace) print *, 'ME: toodry,i', toodry, i - IF (rhq(i).ge.rhprcp.or.toodry.eq.0) THEN - IF (toodry.ne.0) THEN - dpdrh = alog(pq(i)/pq(i-1)) / (rhq(i)- - + rhq(i-1)) - pbot = exp(alog(pq(i))+(rhprcp-rhq(i))*dpdrh) -C -Clin dpdrh=(Pq(i)-Pq(i-1))/(Rhq(i)-Rhq(i-1)) -Clin pbot=Pq(i)+(rhprcp-Rhq(i))*dpdrh - ptw = pq(i) - toodry = 0 - IF (trace) print *, 'dpdrh,pbot,rhprcp-rhq - +(i),i,ptw, toodry', dpdrh, pbot, rhprcp - rhq(i), i, ptw, - + toodry - ELSE IF (rhq(i).ge.rhprcp) THEN - ptw = pq(i) - IF (trace) print *, 'HERE1: ptw,toodry', - + ptw, toodry - ELSE - toodry = 1 - dpdrh = alog(pq(i)/pq(i-1)) / (rhq(i)- - + rhq(i-1)) - ptw = exp(alog(pq(i))+(rhprcp-rhq(i))*dpdrh) - IF (trace) print *, - + 'HERE2:dpdrh,pbot,i,ptw,toodry', dpdrh, - + pbot, i, ptw, toodry -Clin dpdrh=(Pq(i)-Pq(i-1))/(Rhq(i)-Rhq(i-1)) -Clin ptw=Pq(i)+(rhprcp-Rhq(i))*dpdrh -C - END IF -C - IF (trace) print *, 'HERE3:pbot,ptw,deltag', - + pbot, ptw, deltag - IF (pbot/ptw.ge.deltag) THEN -Clin If (pbot-ptw.lt.deltag) Goto 2003 - k1 = i - ptop = ptw - END IF - END IF - END IF - END IF -C - 10 CONTINUE -C -C Gross checks for liquid and solid precip which dont require generating level. -C -c print *, 'twq1 ', twq(1) - IF (twq(1).ge.273.15+2.0) THEN - ptyp = 8 ! liquid - IF (trace) PRINT *, 'liquid' - icefrac = 0.0 - RETURN - END IF -C - print *, 'twmax ', twmax - IF (twmax.le.twice) THEN - icefrac = 1.0 - ptyp = 1 ! solid - RETURN - END IF -C -C Check to see if we had no success with locating a generating level. -C - IF (trace) print *, 'HERE6: k1,ptyp', k1, ptyp - IF (k1.eq.0) THEN - rate = flag - RETURN - END IF -C - IF (ptop.eq.pq(k1)) THEN - twtop = twq(k1) - rhtop = rhq(k1) - k2 = k1 - k1 = k1 - 1 - ELSE - k2 = k1 - k1 = k1 - 1 - wgt1 = alog(ptop/pq(k2)) / alog(pq(k1)/pq(k2)) -Clin wgt1=(ptop-Pq(k2))/(Pq(k1)-Pq(k2)) - wgt2 = 1.0 - wgt1 - twtop = twq(k1) * wgt1 + twq(k2) * wgt2 - rhtop = rhq(k1) * wgt1 + rhq(k2) * wgt2 - END IF -C - IF (trace) print *, - + 'HERE7: ptop,k1,pq(k1),twtop,rhtop,k2,wgt1, wgt2', ptop, - + k1, pq(k1), twtop, rhtop, k2, wgt1, wgt2 -C -C Calculate temp and wet-bulb ranges below precip generating level. - DO 20 i = 1, k1 - twmax = amax1(twq(i),twmax) - 20 CONTINUE -C -C Gross check for solid precip, initialize ice fraction. - IF (trace) print *, twmax - IF (twtop.le.twice) THEN - icefrac = 1.0 - IF (twmax.le.twmelt) THEN ! gross check for solid precip. - IF (trace) PRINT *, 'solid' - ptyp = 1 ! solid precip - RETURN - END IF - lll = 0 - ELSE - icefrac = 0.0 - lll = 1 - END IF -C -C Loop downward through sounding from highest precip generating level. - 30 CONTINUE -C - IF (trace) PRINT *, ptop, twtop - 273.15, icefrac - IF (trace) print *, 'P,Tw,frac,twq(k1)', ptop, twtop - 273.15, - + icefrac, twq(k1) - IF (icefrac.ge.1.0) THEN ! starting as all ice - IF (trace) print *, 'ICEFRAC=1', icefrac - print *, 'twq twmwelt twtop ', twq(k1), twmelt, twtop - IF (twq(k1).lt.twmelt) GO TO 40 ! cannot commence melting - IF (twq(k1).eq.twtop) GO TO 40 ! both equal twmelt, nothing h - wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) - rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) / 2 - dtavg = (twmelt-twq(k1)) / 2 - dpk = wgt1 * alog(pq(k1)/ptop) !lin dpk=wgt1*(Pq(k1)-Ptop) -C mye=emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - IF (trace) print *, - + 'HERE8: wgt1,rhavg,dtavg,dpk,mye,icefrac', wgt1, rhavg, - + dtavg, dpk, mye, icefrac - ELSE IF (icefrac.le.0.0) THEN ! starting as all liquid - IF (trace) print *, 'HERE9: twtop,twq(k1),k1,lll', twtop, - + twq(k1), k1, lll - lll = 1 -C If (Twq(k1).le.Twice) icefrac=1.0 ! autoconvert -C Goto 1020 - IF (twq(k1).gt.twice) GO TO 40 ! cannot commence freezing - IF (twq(k1).eq.twtop) THEN - wgt1 = 0.5 - ELSE - wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) - END IF - rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) / 2 - dtavg = twmelt - (twq(k1)+twice) / 2 - dpk = wgt1 * alog(pq(k1)/ptop) !lin dpk=wgt1*(Pq(k1)-Ptop) -C mye=emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - IF (trace) print *, 'HERE10: wgt1,rhtop,rhq(k1),dtavg', - + wgt1, rhtop, rhq(k1), dtavg - ELSE IF ((twq(k1).le.twmelt).and.(twq(k1).lt.twmelt)) THEN ! mix - rhavg = (rhq(k1)+rhtop) / 2 - dtavg = twmelt - (twq(k1)+twtop) / 2 - dpk = alog(pq(k1)/ptop) !lin dpk=Pq(k1)-Ptop -C mye=emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - - IF (trace) print *, 'HERE11: twq(K1),twtop', twq(k1), - + twtop - ELSE ! mix where Tw curve crosses twmelt in layer - IF (twq(k1).eq.twtop) GO TO 40 ! both equal twmelt, nothing h - wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) - wgt2 = 1.0 - wgt1 - rhavg = rhtop + wgt2 * (rhq(k1)-rhtop) / 2 - dtavg = (twmelt-twtop) / 2 - dpk = wgt2 * alog(pq(k1)/ptop) !lin dpk=wgt2*(Pq(k1)-Ptop) -C mye=emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - icefrac = amin1(1.0,amax1(icefrac,0.0)) - IF (trace) print *, 'HERE12: twq(k1),twtop,icefrac,wgt1,wg - +t2,rhavg,rhtop,rhq(k1),dtavg,k1', twq(k1), twtop, icefrac, wgt1, - + wgt2, rhavg, rhtop, rhq(k1), dtavg, k1 - IF (icefrac.le.0.0) THEN -C If (Twq(k1).le.Twice) icefrac=1.0 ! autoconvert -C Goto 1020 - IF (twq(k1).gt.twice) GO TO 40 ! cannot commence freezin - wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) - dtavg = twmelt - (twq(k1)+twice) / 2 - IF (trace) WRITE (20,*) 'IN IF' - ELSE - dtavg = (twmelt-twq(k1)) / 2 - IF (trace) WRITE (20,*) 'IN ELSE' - END IF - IF (trace) print *, 'NEW ICE FRAC CALC' - rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) / 2 - dpk = wgt1 * alog(pq(k1)/ptop) !lin dpk=wgt1*(Pq(k1)-Ptop) -C mye=emelt*(1.0-(1.0-Rhavg)*efac) - mye = emelt * rhavg ** efac - icefrac = icefrac + dpk * dtavg / mye - IF (trace) print *, 'HERE13: icefrac,k1,dtavg,rhavg', - + icefrac, k1, dtavg, rhavg - END IF -C - icefrac = amin1(1.0,amax1(icefrac,0.0)) - IF (trace) print *, 'NEW ICEFRAC:', icefrac, icefrac -C -C Get next level down if there is one, loop back. - 40 IF (k1.gt.1) THEN - IF (trace) WRITE (20,*) 'LOOPING BACK' - twtop = twq(k1) - ptop = pq(k1) - rhtop = rhq(k1) - k1 = k1 - 1 - GO TO 30 - END IF -C -C -C Determine precip type based on snow fraction and surface wet-bulb. -C If (trace) Print *,Pq(k1),Twq(k1)-273.15,icefrac -C - IF (trace) print *, 'P,Tw,frac,lll', pq(k1), twq(k2) - 273.15, - + icefrac, lll -C -c print *, 'icefrac ', icefrac - IF (icefrac.ge.slim) THEN - IF (lll.ne.0) THEN - ptyp = 2 ! Ice Pellets JC 9/16/99 - IF (trace) print *, 'frozen' - ELSE - ptyp = 1 ! Snow - print *, 'snow' - IF (trace) print *, 'snow' - END IF - ELSE IF (icefrac.le.rlim) THEN - IF (twq(1).lt.tz) THEN - print *, 'aha! frz' - ptyp = 4 ! Freezing Precip - IF (trace) print *, 'freezing' - ELSE - ptyp = 8 ! Rain - print *, 'rain' - IF (trace) print *, 'liquid' - END IF - ELSE - IF (trace) print *, 'Mix' - IF (twq(1).lt.tz) THEN - IF (trace) print *, 'freezing' -cGSM not sure what to do when 'mix' is predicted; I chose sleet as -cGSK a shaky best option - - ptyp = 2 ! Ice Pellets -c ptyp = 5 ! Mix - ELSE -c ptyp = 5 ! Mix - ptyp = 2 ! Ice Pellets - END IF - END IF - IF (trace) print *, "Returned ptyp is:ptyp,lll ", ptyp, lll - IF (trace) print *, "Returned icefrac is: ", icefrac - RETURN -C - END diff --git a/sorc/gfs_bufr.fd/funcphys.f b/sorc/gfs_bufr.fd/funcphys.f deleted file mode 100755 index fd30d1568f..0000000000 --- a/sorc/gfs_bufr.fd/funcphys.f +++ /dev/null @@ -1,2899 +0,0 @@ -!------------------------------------------------------------------------------- -module funcphys -!$$$ Module Documentation Block -! -! Module: funcphys API for basic thermodynamic physics -! Author: Iredell Org: W/NX23 Date: 1999-03-01 -! -! Abstract: This module provides an Application Program Interface -! for computing basic thermodynamic physics functions, in particular -! (1) saturation vapor pressure as a function of temperature, -! (2) dewpoint temperature as a function of vapor pressure, -! (3) equivalent potential temperature as a function of temperature -! and scaled pressure to the kappa power, -! (4) temperature and specific humidity along a moist adiabat -! as functions of equivalent potential temperature and -! scaled pressure to the kappa power, -! (5) scaled pressure to the kappa power as a function of pressure, and -! (6) temperature at the lifting condensation level as a function -! of temperature and dewpoint depression. -! The entry points required to set up lookup tables start with a "g". -! All the other entry points are functions starting with an "f" or -! are subroutines starting with an "s". These other functions and -! subroutines are elemental; that is, they return a scalar if they -! are passed only scalars, but they return an array if they are passed -! an array. These other functions and subroutines can be inlined, too. -! -! Program History Log: -! 1999-03-01 Mark Iredell -! 1999-10-15 Mark Iredell SI unit for pressure (Pascals) -! 2001-02-26 Mark Iredell Ice phase changes of Hong and Moorthi -! -! Public Variables: -! krealfp Integer parameter kind or length of reals (=kind_phys) -! -! Public Subprograms: -! gpvsl Compute saturation vapor pressure over liquid table -! -! fpvsl Elementally compute saturation vapor pressure over liquid -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! fpvslq Elementally compute saturation vapor pressure over liquid -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! fpvslx Elementally compute saturation vapor pressure over liquid -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! gpvsi Compute saturation vapor pressure over ice table -! -! fpvsi Elementally compute saturation vapor pressure over ice -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! fpvsiq Elementally compute saturation vapor pressure over ice -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! fpvsix Elementally compute saturation vapor pressure over ice -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! gpvs Compute saturation vapor pressure table -! -! fpvs Elementally compute saturation vapor pressure -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! fpvsq Elementally compute saturation vapor pressure -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! fpvsx Elementally compute saturation vapor pressure -! function result Real(krealfp) saturation vapor pressure in Pascals -! t Real(krealfp) temperature in Kelvin -! -! gtdpl Compute dewpoint temperature over liquid table -! -! ftdpl Elementally compute dewpoint temperature over liquid -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdplq Elementally compute dewpoint temperature over liquid -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdplx Elementally compute dewpoint temperature over liquid -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdplxg Elementally compute dewpoint temperature over liquid -! function result Real(krealfp) dewpoint temperature in Kelvin -! t Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! gtdpi Compute dewpoint temperature table over ice -! -! ftdpi Elementally compute dewpoint temperature over ice -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdpiq Elementally compute dewpoint temperature over ice -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdpix Elementally compute dewpoint temperature over ice -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdpixg Elementally compute dewpoint temperature over ice -! function result Real(krealfp) dewpoint temperature in Kelvin -! t Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! gtdp Compute dewpoint temperature table -! -! ftdp Elementally compute dewpoint temperature -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdpq Elementally compute dewpoint temperature -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdpx Elementally compute dewpoint temperature -! function result Real(krealfp) dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! ftdpxg Elementally compute dewpoint temperature -! function result Real(krealfp) dewpoint temperature in Kelvin -! t Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! gthe Compute equivalent potential temperature table -! -! fthe Elementally compute equivalent potential temperature -! function result Real(krealfp) equivalent potential temperature in Kelvin -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! ftheq Elementally compute equivalent potential temperature -! function result Real(krealfp) equivalent potential temperature in Kelvin -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! fthex Elementally compute equivalent potential temperature -! function result Real(krealfp) equivalent potential temperature in Kelvin -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! gtma Compute moist adiabat tables -! -! stma Elementally compute moist adiabat temperature and moisture -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! stmaq Elementally compute moist adiabat temperature and moisture -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! stmax Elementally compute moist adiabat temperature and moisture -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! stmaxg Elementally compute moist adiabat temperature and moisture -! tg Real(krealfp) guess parcel temperature in Kelvin -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! gpkap Compute pressure to the kappa table -! -! fpkap Elementally raise pressure to the kappa power. -! function result Real(krealfp) p over 1e5 Pa to the kappa power -! p Real(krealfp) pressure in Pascals -! -! fpkapq Elementally raise pressure to the kappa power. -! function result Real(krealfp) p over 1e5 Pa to the kappa power -! p Real(krealfp) pressure in Pascals -! -! fpkapo Elementally raise pressure to the kappa power. -! function result Real(krealfp) p over 1e5 Pa to the kappa power -! p Real(krealfp) surface pressure in Pascals -! -! fpkapx Elementally raise pressure to the kappa power. -! function result Real(krealfp) p over 1e5 Pa to the kappa power -! p Real(krealfp) pressure in Pascals -! -! grkap Compute pressure to the 1/kappa table -! -! frkap Elementally raise pressure to the 1/kappa power. -! function result Real(krealfp) pressure in Pascals -! pkap Real(krealfp) p over 1e5 Pa to the 1/kappa power -! -! frkapq Elementally raise pressure to the kappa power. -! function result Real(krealfp) pressure in Pascals -! pkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! frkapx Elementally raise pressure to the kappa power. -! function result Real(krealfp) pressure in Pascals -! pkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! gtlcl Compute LCL temperature table -! -! ftlcl Elementally compute LCL temperature. -! function result Real(krealfp) temperature at the LCL in Kelvin -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! ftlclq Elementally compute LCL temperature. -! function result Real(krealfp) temperature at the LCL in Kelvin -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! ftlclo Elementally compute LCL temperature. -! function result Real(krealfp) temperature at the LCL in Kelvin -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! ftlclx Elementally compute LCL temperature. -! function result Real(krealfp) temperature at the LCL in Kelvin -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! gfuncphys Compute all physics function tables -! -! Attributes: -! Language: Fortran 90 -! -!$$$ - use machine,only:kind_phys - use physcons - implicit none - private -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Variables -! integer,public,parameter:: krealfp=selected_real_kind(15,45) - integer,public,parameter:: krealfp=kind_phys -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Private Variables - real(krealfp),parameter:: psatb=con_psat*1.e-5 - integer,parameter:: nxpvsl=7501 - real(krealfp) c1xpvsl,c2xpvsl,tbpvsl(nxpvsl) - integer,parameter:: nxpvsi=7501 - real(krealfp) c1xpvsi,c2xpvsi,tbpvsi(nxpvsi) - integer,parameter:: nxpvs=7501 - real(krealfp) c1xpvs,c2xpvs,tbpvs(nxpvs) - integer,parameter:: nxtdpl=5001 - real(krealfp) c1xtdpl,c2xtdpl,tbtdpl(nxtdpl) - integer,parameter:: nxtdpi=5001 - real(krealfp) c1xtdpi,c2xtdpi,tbtdpi(nxtdpi) - integer,parameter:: nxtdp=5001 - real(krealfp) c1xtdp,c2xtdp,tbtdp(nxtdp) - integer,parameter:: nxthe=241,nythe=151 - real(krealfp) c1xthe,c2xthe,c1ythe,c2ythe,tbthe(nxthe,nythe) - integer,parameter:: nxma=151,nyma=121 - real(krealfp) c1xma,c2xma,c1yma,c2yma,tbtma(nxma,nyma),tbqma(nxma,nyma) -! integer,parameter:: nxpkap=5501 - integer,parameter:: nxpkap=11001 - real(krealfp) c1xpkap,c2xpkap,tbpkap(nxpkap) - integer,parameter:: nxrkap=5501 - real(krealfp) c1xrkap,c2xrkap,tbrkap(nxrkap) - integer,parameter:: nxtlcl=151,nytlcl=61 - real(krealfp) c1xtlcl,c2xtlcl,c1ytlcl,c2ytlcl,tbtlcl(nxtlcl,nytlcl) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Subprograms - public gpvsl,fpvsl,fpvslq,fpvslx - public gpvsi,fpvsi,fpvsiq,fpvsix - public gpvs,fpvs,fpvsq,fpvsx - public gtdpl,ftdpl,ftdplq,ftdplx,ftdplxg - public gtdpi,ftdpi,ftdpiq,ftdpix,ftdpixg - public gtdp,ftdp,ftdpq,ftdpx,ftdpxg - public gthe,fthe,ftheq,fthex - public gtma,stma,stmaq,stmax,stmaxg - public gpkap,fpkap,fpkapq,fpkapo,fpkapx - public grkap,frkap,frkapq,frkapx - public gtlcl,ftlcl,ftlclq,ftlclo,ftlclx - public gfuncphys -contains -!------------------------------------------------------------------------------- - subroutine gpvsl -!$$$ Subprogram Documentation Block -! -! Subprogram: gpvsl Compute saturation vapor pressure table over liquid -! Author: N Phillips W/NMC2X2 Date: 30 dec 82 -! -! Abstract: Computes saturation vapor pressure table as a function of -! temperature for the table lookup function fpvsl. -! Exact saturation vapor pressures are calculated in subprogram fpvslx. -! The current implementation computes a table with a length -! of 7501 for temperatures ranging from 180. to 330. Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call gpvsl -! -! Subprograms called: -! (fpvslx) inlinable function to compute saturation vapor pressure -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=180.0_krealfp - xmax=330.0_krealfp - xinc=(xmax-xmin)/(nxpvsl-1) -! c1xpvsl=1.-xmin/xinc - c2xpvsl=1./xinc - c1xpvsl=1.-xmin*c2xpvsl - do jx=1,nxpvsl - x=xmin+(jx-1)*xinc - t=x - tbpvsl(jx)=fpvslx(t) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fpvsl(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsl Compute saturation vapor pressure over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A linear interpolation is done between values in a lookup table -! computed in gpvsl. See documentation for fpvslx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 6 decimal places. -! On the Cray, fpvsl is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: pvsl=fpvsl(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsl Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsl - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) - jx=min(xj,nxpvsl-1._krealfp) - fpvsl=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvslq(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvslq Compute saturation vapor pressure over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A quadratic interpolation is done between values in a lookup table -! computed in gpvsl. See documentation for fpvslx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 9 decimal places. -! On the Cray, fpvslq is about 3 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! -! Usage: pvsl=fpvslq(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvslq Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvslq - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) - jx=min(max(nint(xj),2),nxpvsl-1) - dxj=xj-jx - fj1=tbpvsl(jx-1) - fj2=tbpvsl(jx) - fj3=tbpvsl(jx+1) - fpvslq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvslx(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvslx Compute saturation vapor pressure over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute saturation vapor pressure from temperature. -! The water model assumes a perfect gas, constant specific heats -! for gas and liquid, and neglects the volume of the liquid. -! The model does account for the variation of the latent heat -! of condensation with temperature. The ice option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: pvsl=fpvslx(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvslx Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvslx - real(krealfp),intent(in):: t - real(krealfp),parameter:: dldt=con_cvap-con_cliq - real(krealfp),parameter:: heat=con_hvap - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) - real(krealfp) tr -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/t - fpvslx=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gpvsi -!$$$ Subprogram Documentation Block -! -! Subprogram: gpvsi Compute saturation vapor pressure table over ice -! Author: N Phillips W/NMC2X2 Date: 30 dec 82 -! -! Abstract: Computes saturation vapor pressure table as a function of -! temperature for the table lookup function fpvsi. -! Exact saturation vapor pressures are calculated in subprogram fpvsix. -! The current implementation computes a table with a length -! of 7501 for temperatures ranging from 180. to 330. Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: call gpvsi -! -! Subprograms called: -! (fpvsix) inlinable function to compute saturation vapor pressure -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=180.0_krealfp - xmax=330.0_krealfp - xinc=(xmax-xmin)/(nxpvsi-1) -! c1xpvsi=1.-xmin/xinc - c2xpvsi=1./xinc - c1xpvsi=1.-xmin*c2xpvsi - do jx=1,nxpvsi - x=xmin+(jx-1)*xinc - t=x - tbpvsi(jx)=fpvsix(t) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fpvsi(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsi Compute saturation vapor pressure over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A linear interpolation is done between values in a lookup table -! computed in gpvsi. See documentation for fpvsix for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 6 decimal places. -! On the Cray, fpvsi is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvsi=fpvsi(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsi Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsi - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) - jx=min(xj,nxpvsi-1._krealfp) - fpvsi=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvsiq(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsiq Compute saturation vapor pressure over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A quadratic interpolation is done between values in a lookup table -! computed in gpvsi. See documentation for fpvsix for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 9 decimal places. -! On the Cray, fpvsiq is about 3 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvsi=fpvsiq(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsiq Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsiq - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) - jx=min(max(nint(xj),2),nxpvsi-1) - dxj=xj-jx - fj1=tbpvsi(jx-1) - fj2=tbpvsi(jx) - fj3=tbpvsi(jx+1) - fpvsiq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvsix(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsix Compute saturation vapor pressure over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute saturation vapor pressure from temperature. -! The water model assumes a perfect gas, constant specific heats -! for gas and ice, and neglects the volume of the ice. -! The model does account for the variation of the latent heat -! of condensation with temperature. The liquid option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvsi=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvsi=fpvsix(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsix Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsix - real(krealfp),intent(in):: t - real(krealfp),parameter:: dldt=con_cvap-con_csol - real(krealfp),parameter:: heat=con_hvap+con_hfus - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) - real(krealfp) tr -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/t - fpvsix=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gpvs -!$$$ Subprogram Documentation Block -! -! Subprogram: gpvs Compute saturation vapor pressure table -! Author: N Phillips W/NMC2X2 Date: 30 dec 82 -! -! Abstract: Computes saturation vapor pressure table as a function of -! temperature for the table lookup function fpvs. -! Exact saturation vapor pressures are calculated in subprogram fpvsx. -! The current implementation computes a table with a length -! of 7501 for temperatures ranging from 180. to 330. Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: call gpvs -! -! Subprograms called: -! (fpvsx) inlinable function to compute saturation vapor pressure -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=180.0_krealfp - xmax=330.0_krealfp - xinc=(xmax-xmin)/(nxpvs-1) -! c1xpvs=1.-xmin/xinc - c2xpvs=1./xinc - c1xpvs=1.-xmin*c2xpvs - do jx=1,nxpvs - x=xmin+(jx-1)*xinc - t=x - tbpvs(jx)=fpvsx(t) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fpvs(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvs Compute saturation vapor pressure -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A linear interpolation is done between values in a lookup table -! computed in gpvs. See documentation for fpvsx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 6 decimal places. -! On the Cray, fpvs is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvs=fpvs(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvs Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvs - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp)) - jx=min(xj,nxpvs-1._krealfp) - fpvs=tbpvs(jx)+(xj-jx)*(tbpvs(jx+1)-tbpvs(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvsq(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsq Compute saturation vapor pressure -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A quadratic interpolation is done between values in a lookup table -! computed in gpvs. See documentation for fpvsx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 9 decimal places. -! On the Cray, fpvsq is about 3 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvs=fpvsq(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsq Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsq - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp)) - jx=min(max(nint(xj),2),nxpvs-1) - dxj=xj-jx - fj1=tbpvs(jx-1) - fj2=tbpvs(jx) - fj3=tbpvs(jx+1) - fpvsq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvsx(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsx Compute saturation vapor pressure -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute saturation vapor pressure from temperature. -! The saturation vapor pressure over either liquid and ice is computed -! over liquid for temperatures above the triple point, -! over ice for temperatures 20 degress below the triple point, -! and a linear combination of the two for temperatures in between. -! The water model assumes a perfect gas, constant specific heats -! for gas, liquid and ice, and neglects the volume of the condensate. -! The model does account for the variation of the latent heat -! of condensation and sublimation with temperature. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! The reference for this computation is Emanuel(1994), pages 116-117. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvs=fpvsx(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsx Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsx - real(krealfp),intent(in):: t - real(krealfp),parameter:: tliq=con_ttp - real(krealfp),parameter:: tice=con_ttp-20.0 - real(krealfp),parameter:: dldtl=con_cvap-con_cliq - real(krealfp),parameter:: heatl=con_hvap - real(krealfp),parameter:: xponal=-dldtl/con_rv - real(krealfp),parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) - real(krealfp),parameter:: dldti=con_cvap-con_csol - real(krealfp),parameter:: heati=con_hvap+con_hfus - real(krealfp),parameter:: xponai=-dldti/con_rv - real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) - real(krealfp) tr,w,pvl,pvi -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/t - if(t.ge.tliq) then - fpvsx=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) - elseif(t.lt.tice) then - fpvsx=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) - else - w=(t-tice)/(tliq-tice) - pvl=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) - pvi=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) - fpvsx=w*pvl+(1.-w)*pvi - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtdpl -!$$$ Subprogram Documentation Block -! -! Subprogram: gtdpl Compute dewpoint temperature over liquid table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature table as a function of -! vapor pressure for inlinable function ftdpl. -! Exact dewpoint temperatures are calculated in subprogram ftdplxg. -! The current implementation computes a table with a length -! of 5001 for vapor pressures ranging from 1 to 10001 Pascals -! giving a dewpoint temperature range of 208 to 319 Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call gtdpl -! -! Subprograms called: -! (ftdplxg) inlinable function to compute dewpoint temperature over liquid -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,t,x,pv -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=1 - xmax=10001 - xinc=(xmax-xmin)/(nxtdpl-1) - c1xtdpl=1.-xmin/xinc - c2xtdpl=1./xinc - t=208.0 - do jx=1,nxtdpl - x=xmin+(jx-1)*xinc - pv=x - t=ftdplxg(t,pv) - tbtdpl(jx)=t - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function ftdpl(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpl Compute dewpoint temperature over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A linear interpolation is done between values in a lookup table -! computed in gtdpl. See documentation for ftdplxg for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.0005 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdpl is about 75 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: tdpl=ftdpl(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpl Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpl - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp)) - jx=min(xj,nxtdpl-1._krealfp) - ftdpl=tbtdpl(jx)+(xj-jx)*(tbtdpl(jx+1)-tbtdpl(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdplq(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdplq Compute dewpoint temperature over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A quadratic interpolation is done between values in a lookup table -! computed in gtdpl. see documentation for ftdplxg for details. -! Input values outside table range are reset to table extrema. -! the interpolation accuracy is better than 0.00001 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdplq is about 60 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! -! Usage: tdpl=ftdplq(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdplq Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdplq - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp)) - jx=min(max(nint(xj),2),nxtdpl-1) - dxj=xj-jx - fj1=tbtdpl(jx-1) - fj2=tbtdpl(jx) - fj3=tbtdpl(jx+1) - ftdplq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdplx(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdplx Compute dewpoint temperature over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: exactly compute dewpoint temperature from vapor pressure. -! An approximate dewpoint temperature for function ftdplxg -! is obtained using ftdpl so gtdpl must be already called. -! See documentation for ftdplxg for details. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: tdpl=ftdplx(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdplx Real(krealfp) dewpoint temperature in Kelvin -! -! Subprograms called: -! (ftdpl) inlinable function to compute dewpoint temperature over liquid -! (ftdplxg) inlinable function to compute dewpoint temperature over liquid -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdplx - real(krealfp),intent(in):: pv - real(krealfp) tg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tg=ftdpl(pv) - ftdplx=ftdplxg(tg,pv) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdplxg(tg,pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdplxg Compute dewpoint temperature over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute dewpoint temperature from vapor pressure. -! A guess dewpoint temperature must be provided. -! The water model assumes a perfect gas, constant specific heats -! for gas and liquid, and neglects the volume of the liquid. -! The model does account for the variation of the latent heat -! of condensation with temperature. The ice option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvs=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! The formula is inverted by iterating Newtonian approximations -! for each pvs until t is found to within 1.e-6 Kelvin. -! This function can be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: tdpl=ftdplxg(tg,pv) -! -! Input argument list: -! tg Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdplxg Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdplxg - real(krealfp),intent(in):: tg,pv - real(krealfp),parameter:: terrm=1.e-6 - real(krealfp),parameter:: dldt=con_cvap-con_cliq - real(krealfp),parameter:: heat=con_hvap - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) - real(krealfp) t,tr,pvt,el,dpvt,terr - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg - do i=1,100 - tr=con_ttp/t - pvt=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) - el=heat+dldt*(t-con_ttp) - dpvt=el*pvt/(con_rv*t**2) - terr=(pvt-pv)/dpvt - t=t-terr - if(abs(terr).le.terrm) exit - enddo - ftdplxg=t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtdpi -!$$$ Subprogram Documentation Block -! -! Subprogram: gtdpi Compute dewpoint temperature over ice table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature table as a function of -! vapor pressure for inlinable function ftdpi. -! Exact dewpoint temperatures are calculated in subprogram ftdpixg. -! The current implementation computes a table with a length -! of 5001 for vapor pressures ranging from 0.1 to 1000.1 Pascals -! giving a dewpoint temperature range of 197 to 279 Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: call gtdpi -! -! Subprograms called: -! (ftdpixg) inlinable function to compute dewpoint temperature over ice -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,t,x,pv -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=0.1 - xmax=1000.1 - xinc=(xmax-xmin)/(nxtdpi-1) - c1xtdpi=1.-xmin/xinc - c2xtdpi=1./xinc - t=197.0 - do jx=1,nxtdpi - x=xmin+(jx-1)*xinc - pv=x - t=ftdpixg(t,pv) - tbtdpi(jx)=t - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function ftdpi(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpi Compute dewpoint temperature over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A linear interpolation is done between values in a lookup table -! computed in gtdpi. See documentation for ftdpixg for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.0005 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdpi is about 75 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdpi=ftdpi(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpi Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpi - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp)) - jx=min(xj,nxtdpi-1._krealfp) - ftdpi=tbtdpi(jx)+(xj-jx)*(tbtdpi(jx+1)-tbtdpi(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpiq(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpiq Compute dewpoint temperature over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A quadratic interpolation is done between values in a lookup table -! computed in gtdpi. see documentation for ftdpixg for details. -! Input values outside table range are reset to table extrema. -! the interpolation accuracy is better than 0.00001 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdpiq is about 60 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdpi=ftdpiq(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpiq Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpiq - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp)) - jx=min(max(nint(xj),2),nxtdpi-1) - dxj=xj-jx - fj1=tbtdpi(jx-1) - fj2=tbtdpi(jx) - fj3=tbtdpi(jx+1) - ftdpiq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpix(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpix Compute dewpoint temperature over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: exactly compute dewpoint temperature from vapor pressure. -! An approximate dewpoint temperature for function ftdpixg -! is obtained using ftdpi so gtdpi must be already called. -! See documentation for ftdpixg for details. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdpi=ftdpix(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpix Real(krealfp) dewpoint temperature in Kelvin -! -! Subprograms called: -! (ftdpi) inlinable function to compute dewpoint temperature over ice -! (ftdpixg) inlinable function to compute dewpoint temperature over ice -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpix - real(krealfp),intent(in):: pv - real(krealfp) tg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tg=ftdpi(pv) - ftdpix=ftdpixg(tg,pv) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpixg(tg,pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpixg Compute dewpoint temperature over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute dewpoint temperature from vapor pressure. -! A guess dewpoint temperature must be provided. -! The water model assumes a perfect gas, constant specific heats -! for gas and ice, and neglects the volume of the ice. -! The model does account for the variation of the latent heat -! of sublimation with temperature. The liquid option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvs=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! The formula is inverted by iterating Newtonian approximations -! for each pvs until t is found to within 1.e-6 Kelvin. -! This function can be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdpi=ftdpixg(tg,pv) -! -! Input argument list: -! tg Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpixg Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpixg - real(krealfp),intent(in):: tg,pv - real(krealfp),parameter:: terrm=1.e-6 - real(krealfp),parameter:: dldt=con_cvap-con_csol - real(krealfp),parameter:: heat=con_hvap+con_hfus - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) - real(krealfp) t,tr,pvt,el,dpvt,terr - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg - do i=1,100 - tr=con_ttp/t - pvt=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) - el=heat+dldt*(t-con_ttp) - dpvt=el*pvt/(con_rv*t**2) - terr=(pvt-pv)/dpvt - t=t-terr - if(abs(terr).le.terrm) exit - enddo - ftdpixg=t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtdp -!$$$ Subprogram Documentation Block -! -! Subprogram: gtdp Compute dewpoint temperature table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature table as a function of -! vapor pressure for inlinable function ftdp. -! Exact dewpoint temperatures are calculated in subprogram ftdpxg. -! The current implementation computes a table with a length -! of 5001 for vapor pressures ranging from 0.5 to 1000.5 Pascals -! giving a dewpoint temperature range of 208 to 319 Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: call gtdp -! -! Subprograms called: -! (ftdpxg) inlinable function to compute dewpoint temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,t,x,pv -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=0.5 - xmax=10000.5 - xinc=(xmax-xmin)/(nxtdp-1) - c1xtdp=1.-xmin/xinc - c2xtdp=1./xinc - t=208.0 - do jx=1,nxtdp - x=xmin+(jx-1)*xinc - pv=x - t=ftdpxg(t,pv) - tbtdp(jx)=t - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function ftdp(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdp Compute dewpoint temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A linear interpolation is done between values in a lookup table -! computed in gtdp. See documentation for ftdpxg for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.0005 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdp is about 75 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdp=ftdp(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdp Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdp - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdp+c2xtdp*pv,1._krealfp),real(nxtdp,krealfp)) - jx=min(xj,nxtdp-1._krealfp) - ftdp=tbtdp(jx)+(xj-jx)*(tbtdp(jx+1)-tbtdp(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpq(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpq Compute dewpoint temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A quadratic interpolation is done between values in a lookup table -! computed in gtdp. see documentation for ftdpxg for details. -! Input values outside table range are reset to table extrema. -! the interpolation accuracy is better than 0.00001 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdpq is about 60 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdp=ftdpq(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpq Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpq - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdp+c2xtdp*pv,1._krealfp),real(nxtdp,krealfp)) - jx=min(max(nint(xj),2),nxtdp-1) - dxj=xj-jx - fj1=tbtdp(jx-1) - fj2=tbtdp(jx) - fj3=tbtdp(jx+1) - ftdpq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpx(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpx Compute dewpoint temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: exactly compute dewpoint temperature from vapor pressure. -! An approximate dewpoint temperature for function ftdpxg -! is obtained using ftdp so gtdp must be already called. -! See documentation for ftdpxg for details. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdp=ftdpx(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpx Real(krealfp) dewpoint temperature in Kelvin -! -! Subprograms called: -! (ftdp) inlinable function to compute dewpoint temperature -! (ftdpxg) inlinable function to compute dewpoint temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpx - real(krealfp),intent(in):: pv - real(krealfp) tg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tg=ftdp(pv) - ftdpx=ftdpxg(tg,pv) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpxg(tg,pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpxg Compute dewpoint temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute dewpoint temperature from vapor pressure. -! A guess dewpoint temperature must be provided. -! The saturation vapor pressure over either liquid and ice is computed -! over liquid for temperatures above the triple point, -! over ice for temperatures 20 degress below the triple point, -! and a linear combination of the two for temperatures in between. -! The water model assumes a perfect gas, constant specific heats -! for gas, liquid and ice, and neglects the volume of the condensate. -! The model does account for the variation of the latent heat -! of condensation and sublimation with temperature. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! The reference for this decision is Emanuel(1994), pages 116-117. -! The formula is inverted by iterating Newtonian approximations -! for each pvs until t is found to within 1.e-6 Kelvin. -! This function can be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdp=ftdpxg(tg,pv) -! -! Input argument list: -! tg Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpxg Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpxg - real(krealfp),intent(in):: tg,pv - real(krealfp),parameter:: terrm=1.e-6 - real(krealfp),parameter:: tliq=con_ttp - real(krealfp),parameter:: tice=con_ttp-20.0 - real(krealfp),parameter:: dldtl=con_cvap-con_cliq - real(krealfp),parameter:: heatl=con_hvap - real(krealfp),parameter:: xponal=-dldtl/con_rv - real(krealfp),parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) - real(krealfp),parameter:: dldti=con_cvap-con_csol - real(krealfp),parameter:: heati=con_hvap+con_hfus - real(krealfp),parameter:: xponai=-dldti/con_rv - real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) - real(krealfp) t,tr,w,pvtl,pvti,pvt,ell,eli,el,dpvt,terr - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg - do i=1,100 - tr=con_ttp/t - if(t.ge.tliq) then - pvt=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) - el=heatl+dldtl*(t-con_ttp) - dpvt=el*pvt/(con_rv*t**2) - elseif(t.lt.tice) then - pvt=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) - el=heati+dldti*(t-con_ttp) - dpvt=el*pvt/(con_rv*t**2) - else - w=(t-tice)/(tliq-tice) - pvtl=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) - pvti=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) - pvt=w*pvtl+(1.-w)*pvti - ell=heatl+dldtl*(t-con_ttp) - eli=heati+dldti*(t-con_ttp) - dpvt=(w*ell*pvtl+(1.-w)*eli*pvti)/(con_rv*t**2) - endif - terr=(pvt-pv)/dpvt - t=t-terr - if(abs(terr).le.terrm) exit - enddo - ftdpxg=t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gthe -!$$$ Subprogram Documentation Block -! -! Subprogram: gthe Compute equivalent potential temperature table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute equivalent potential temperature table -! as a function of LCL temperature and pressure over 1e5 Pa -! to the kappa power for function fthe. -! Equivalent potential temperatures are calculated in subprogram fthex -! the current implementation computes a table with a first dimension -! of 241 for temperatures ranging from 183.16 to 303.16 Kelvin -! and a second dimension of 151 for pressure over 1e5 Pa -! to the kappa power ranging from 0.04**rocp to 1.10**rocp. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call gthe -! -! Subprograms called: -! (fthex) inlinable function to compute equiv. pot. temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx,jy - real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,pk,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=con_ttp-90._krealfp - xmax=con_ttp+30._krealfp - ymin=0.04_krealfp**con_rocp - ymax=1.10_krealfp**con_rocp - xinc=(xmax-xmin)/(nxthe-1) - c1xthe=1.-xmin/xinc - c2xthe=1./xinc - yinc=(ymax-ymin)/(nythe-1) - c1ythe=1.-ymin/yinc - c2ythe=1./yinc - do jy=1,nythe - y=ymin+(jy-1)*yinc - pk=y - do jx=1,nxthe - x=xmin+(jx-1)*xinc - t=x - tbthe(jx,jy)=fthex(t,pk) - enddo - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fthe(t,pk) -!$$$ Subprogram Documentation Block -! -! Subprogram: fthe Compute equivalent potential temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute equivalent potential temperature at the LCL -! from temperature and pressure over 1e5 Pa to the kappa power. -! A bilinear interpolation is done between values in a lookup table -! computed in gthe. see documentation for fthex for details. -! Input values outside table range are reset to table extrema, -! except zero is returned for too cold or high LCLs. -! The interpolation accuracy is better than 0.01 Kelvin. -! On the Cray, fthe is almost 6 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: the=fthe(t,pk) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! fthe Real(krealfp) equivalent potential temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fthe - real(krealfp),intent(in):: t,pk - integer jx,jy - real(krealfp) xj,yj,ftx1,ftx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(c1xthe+c2xthe*t,real(nxthe,krealfp)) - yj=min(c1ythe+c2ythe*pk,real(nythe,krealfp)) - if(xj.ge.1..and.yj.ge.1.) then - jx=min(xj,nxthe-1._krealfp) - jy=min(yj,nythe-1._krealfp) - ftx1=tbthe(jx,jy)+(xj-jx)*(tbthe(jx+1,jy)-tbthe(jx,jy)) - ftx2=tbthe(jx,jy+1)+(xj-jx)*(tbthe(jx+1,jy+1)-tbthe(jx,jy+1)) - fthe=ftx1+(yj-jy)*(ftx2-ftx1) - else - fthe=0. - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftheq(t,pk) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftheq Compute equivalent potential temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute equivalent potential temperature at the LCL -! from temperature and pressure over 1e5 Pa to the kappa power. -! A biquadratic interpolation is done between values in a lookup table -! computed in gthe. see documentation for fthex for details. -! Input values outside table range are reset to table extrema, -! except zero is returned for too cold or high LCLs. -! The interpolation accuracy is better than 0.0002 Kelvin. -! On the Cray, ftheq is almost 3 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! -! Usage: the=ftheq(t,pk) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! ftheq Real(krealfp) equivalent potential temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftheq - real(krealfp),intent(in):: t,pk - integer jx,jy - real(krealfp) xj,yj,dxj,dyj - real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 - real(krealfp) ftx1,ftx2,ftx3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(c1xthe+c2xthe*t,real(nxthe,krealfp)) - yj=min(c1ythe+c2ythe*pk,real(nythe,krealfp)) - if(xj.ge.1..and.yj.ge.1.) then - jx=min(max(nint(xj),2),nxthe-1) - jy=min(max(nint(yj),2),nythe-1) - dxj=xj-jx - dyj=yj-jy - ft11=tbthe(jx-1,jy-1) - ft12=tbthe(jx-1,jy) - ft13=tbthe(jx-1,jy+1) - ft21=tbthe(jx,jy-1) - ft22=tbthe(jx,jy) - ft23=tbthe(jx,jy+1) - ft31=tbthe(jx+1,jy-1) - ft32=tbthe(jx+1,jy) - ft33=tbthe(jx+1,jy+1) - ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 - ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 - ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 - ftheq=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 - else - ftheq=0. - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- -! elemental function fthex(t,pk) - function fthex(t,pk) -!$$$ Subprogram Documentation Block -! -! Subprogram: fthex Compute equivalent potential temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute equivalent potential temperature at the LCL -! from temperature and pressure over 1e5 Pa to the kappa power. -! Equivalent potential temperature is constant for a saturated parcel -! rising adiabatically up a moist adiabat when the heat and mass -! of the condensed water are neglected. Ice is also neglected. -! The formula for equivalent potential temperature (Holton) is -! the=t*(pd**(-rocp))*exp(el*eps*pv/(cp*t*pd)) -! where t is the temperature, pv is the saturated vapor pressure, -! pd is the dry pressure p-pv, el is the temperature dependent -! latent heat of condensation hvap+dldt*(t-ttp), and other values -! are physical constants defined in parameter statements in the code. -! Zero is returned if the input values make saturation impossible. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: the=fthex(t,pk) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! fthex Real(krealfp) equivalent potential temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fthex - real(krealfp),intent(in):: t,pk - real(krealfp) p,tr,pv,pd,el,expo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - p=pk**con_cpor - tr=con_ttp/t - pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) - pd=p-pv - if(pd.gt.pv) then - el=con_hvap+con_dldt*(t-con_ttp) - expo=el*con_eps*pv/(con_cp*t*pd) - fthex=t*pd**(-con_rocp)*exp(expo) - else - fthex=0. - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtma -!$$$ Subprogram Documentation Block -! -! Subprogram: gtma Compute moist adiabat tables -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature and specific humidity tables -! as a function of equivalent potential temperature and -! pressure over 1e5 Pa to the kappa power for subprogram stma. -! Exact parcel temperatures are calculated in subprogram stmaxg. -! The current implementation computes a table with a first dimension -! of 151 for equivalent potential temperatures ranging from 200 to 500 -! Kelvin and a second dimension of 121 for pressure over 1e5 Pa -! to the kappa power ranging from 0.01**rocp to 1.10**rocp. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call gtma -! -! Subprograms called: -! (stmaxg) inlinable subprogram to compute parcel temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx,jy - real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,pk,the,t,q,tg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=200._krealfp - xmax=500._krealfp - ymin=0.01_krealfp**con_rocp - ymax=1.10_krealfp**con_rocp - xinc=(xmax-xmin)/(nxma-1) - c1xma=1.-xmin/xinc - c2xma=1./xinc - yinc=(ymax-ymin)/(nyma-1) - c1yma=1.-ymin/yinc - c2yma=1./yinc - do jy=1,nyma - y=ymin+(jy-1)*yinc - pk=y - tg=xmin*y - do jx=1,nxma - x=xmin+(jx-1)*xinc - the=x - call stmaxg(tg,the,pk,t,q) - tbtma(jx,jy)=t - tbqma(jx,jy)=q - tg=t - enddo - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental subroutine stma(the,pk,tma,qma) -!$$$ Subprogram Documentation Block -! -! Subprogram: stma Compute moist adiabat temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature and specific humidity of a parcel -! lifted up a moist adiabat from equivalent potential temperature -! at the LCL and pressure over 1e5 Pa to the kappa power. -! Bilinear interpolations are done between values in a lookup table -! computed in gtma. See documentation for stmaxg for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.01 Kelvin -! and 5.e-6 kg/kg for temperature and humidity, respectively. -! On the Cray, stma is about 35 times faster than exact calculation. -! This subprogram should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call stma(the,pk,tma,qma) -! -! Input argument list: -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp),intent(in):: the,pk - real(krealfp),intent(out):: tma,qma - integer jx,jy - real(krealfp) xj,yj,ftx1,ftx2,qx1,qx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xma+c2xma*the,1._krealfp),real(nxma,krealfp)) - yj=min(max(c1yma+c2yma*pk,1._krealfp),real(nyma,krealfp)) - jx=min(xj,nxma-1._krealfp) - jy=min(yj,nyma-1._krealfp) - ftx1=tbtma(jx,jy)+(xj-jx)*(tbtma(jx+1,jy)-tbtma(jx,jy)) - ftx2=tbtma(jx,jy+1)+(xj-jx)*(tbtma(jx+1,jy+1)-tbtma(jx,jy+1)) - tma=ftx1+(yj-jy)*(ftx2-ftx1) - qx1=tbqma(jx,jy)+(xj-jx)*(tbqma(jx+1,jy)-tbqma(jx,jy)) - qx2=tbqma(jx,jy+1)+(xj-jx)*(tbqma(jx+1,jy+1)-tbqma(jx,jy+1)) - qma=qx1+(yj-jy)*(qx2-qx1) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental subroutine stmaq(the,pk,tma,qma) -!$$$ Subprogram Documentation Block -! -! Subprogram: stmaq Compute moist adiabat temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature and specific humidity of a parcel -! lifted up a moist adiabat from equivalent potential temperature -! at the LCL and pressure over 1e5 Pa to the kappa power. -! Biquadratic interpolations are done between values in a lookup table -! computed in gtma. See documentation for stmaxg for details. -! Input values outside table range are reset to table extrema. -! the interpolation accuracy is better than 0.0005 Kelvin -! and 1.e-7 kg/kg for temperature and humidity, respectively. -! On the Cray, stmaq is about 25 times faster than exact calculation. -! This subprogram should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! -! Usage: call stmaq(the,pk,tma,qma) -! -! Input argument list: -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! tmaq Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp),intent(in):: the,pk - real(krealfp),intent(out):: tma,qma - integer jx,jy - real(krealfp) xj,yj,dxj,dyj - real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 - real(krealfp) ftx1,ftx2,ftx3 - real(krealfp) q11,q12,q13,q21,q22,q23,q31,q32,q33,qx1,qx2,qx3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xma+c2xma*the,1._krealfp),real(nxma,krealfp)) - yj=min(max(c1yma+c2yma*pk,1._krealfp),real(nyma,krealfp)) - jx=min(max(nint(xj),2),nxma-1) - jy=min(max(nint(yj),2),nyma-1) - dxj=xj-jx - dyj=yj-jy - ft11=tbtma(jx-1,jy-1) - ft12=tbtma(jx-1,jy) - ft13=tbtma(jx-1,jy+1) - ft21=tbtma(jx,jy-1) - ft22=tbtma(jx,jy) - ft23=tbtma(jx,jy+1) - ft31=tbtma(jx+1,jy-1) - ft32=tbtma(jx+1,jy) - ft33=tbtma(jx+1,jy+1) - ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 - ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 - ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 - tma=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 - q11=tbqma(jx-1,jy-1) - q12=tbqma(jx-1,jy) - q13=tbqma(jx-1,jy+1) - q21=tbqma(jx,jy-1) - q22=tbqma(jx,jy) - q23=tbqma(jx,jy+1) - q31=tbqma(jx+1,jy-1) - q32=tbqma(jx+1,jy) - q33=tbqma(jx+1,jy+1) - qx1=(((q31+q11)/2-q21)*dxj+(q31-q11)/2)*dxj+q21 - qx2=(((q32+q12)/2-q22)*dxj+(q32-q12)/2)*dxj+q22 - qx3=(((q33+q13)/2-q23)*dxj+(q33-q13)/2)*dxj+q23 - qma=(((qx3+qx1)/2-qx2)*dyj+(qx3-qx1)/2)*dyj+qx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental subroutine stmax(the,pk,tma,qma) -!$$$ Subprogram Documentation Block -! -! Subprogram: stmax Compute moist adiabat temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute temperature and humidity of a parcel -! lifted up a moist adiabat from equivalent potential temperature -! at the LCL and pressure over 1e5 Pa to the kappa power. -! An approximate parcel temperature for subprogram stmaxg -! is obtained using stma so gtma must be already called. -! See documentation for stmaxg for details. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: call stmax(the,pk,tma,qma) -! -! Input argument list: -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! Subprograms called: -! (stma) inlinable subprogram to compute parcel temperature -! (stmaxg) inlinable subprogram to compute parcel temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp),intent(in):: the,pk - real(krealfp),intent(out):: tma,qma - real(krealfp) tg,qg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call stma(the,pk,tg,qg) - call stmaxg(tg,the,pk,tma,qma) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental subroutine stmaxg(tg,the,pk,tma,qma) -!$$$ Subprogram Documentation Block -! -! Subprogram: stmaxg Compute moist adiabat temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: exactly compute temperature and humidity of a parcel -! lifted up a moist adiabat from equivalent potential temperature -! at the LCL and pressure over 1e5 Pa to the kappa power. -! A guess parcel temperature must be provided. -! Equivalent potential temperature is constant for a saturated parcel -! rising adiabatically up a moist adiabat when the heat and mass -! of the condensed water are neglected. Ice is also neglected. -! The formula for equivalent potential temperature (Holton) is -! the=t*(pd**(-rocp))*exp(el*eps*pv/(cp*t*pd)) -! where t is the temperature, pv is the saturated vapor pressure, -! pd is the dry pressure p-pv, el is the temperature dependent -! latent heat of condensation hvap+dldt*(t-ttp), and other values -! are physical constants defined in parameter statements in the code. -! The formula is inverted by iterating Newtonian approximations -! for each the and p until t is found to within 1.e-4 Kelvin. -! The specific humidity is then computed from pv and pd. -! This subprogram can be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: call stmaxg(tg,the,pk,tma,qma) -! -! Input argument list: -! tg Real(krealfp) guess parcel temperature in Kelvin -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp),intent(in):: tg,the,pk - real(krealfp),intent(out):: tma,qma - real(krealfp),parameter:: terrm=1.e-4 - real(krealfp) t,p,tr,pv,pd,el,expo,thet,dthet,terr - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg - p=pk**con_cpor - do i=1,100 - tr=con_ttp/t - pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) - pd=p-pv - el=con_hvap+con_dldt*(t-con_ttp) - expo=el*con_eps*pv/(con_cp*t*pd) - thet=t*pd**(-con_rocp)*exp(expo) - dthet=thet/t*(1.+expo*(con_dldt*t/el+el*p/(con_rv*t*pd))) - terr=(thet-the)/dthet - t=t-terr - if(abs(terr).le.terrm) exit - enddo - tma=t - tr=con_ttp/t - pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) - pd=p-pv - qma=con_eps*pv/(pd+con_eps*pv) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine gpkap -!$$$ Subprogram documentation block -! -! Subprogram: gpkap Compute coefficients for p**kappa -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: Computes pressure to the kappa table as a function of pressure -! for the table lookup function fpkap. -! Exact pressure to the kappa values are calculated in subprogram fpkapx. -! The current implementation computes a table with a length -! of 5501 for pressures ranging up to 110000 Pascals. -! -! Program History Log: -! 94-12-30 Iredell -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: call gpkap -! -! Subprograms called: -! fpkapx function to compute exact pressure to the kappa -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,p -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=0._krealfp - xmax=110000._krealfp - xinc=(xmax-xmin)/(nxpkap-1) - c1xpkap=1.-xmin/xinc - c2xpkap=1./xinc - do jx=1,nxpkap - x=xmin+(jx-1)*xinc - p=x - tbpkap(jx)=fpkapx(p) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fpkap(p) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpkap raise pressure to the kappa power. -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Raise pressure over 1e5 Pa to the kappa power. -! A linear interpolation is done between values in a lookup table -! computed in gpkap. See documentation for fpkapx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy ranges from 9 decimal places -! at 100000 Pascals to 5 decimal places at 1000 Pascals. -! On the Cray, fpkap is over 5 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: pkap=fpkap(p) -! -! Input argument list: -! p Real(krealfp) pressure in Pascals -! -! Output argument list: -! fpkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpkap - real(krealfp),intent(in):: p - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpkap+c2xpkap*p,1._krealfp),real(nxpkap,krealfp)) - jx=min(xj,nxpkap-1._krealfp) - fpkap=tbpkap(jx)+(xj-jx)*(tbpkap(jx+1)-tbpkap(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpkapq(p) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpkapq raise pressure to the kappa power. -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Raise pressure over 1e5 Pa to the kappa power. -! A quadratic interpolation is done between values in a lookup table -! computed in gpkap. see documentation for fpkapx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy ranges from 12 decimal places -! at 100000 Pascals to 7 decimal places at 1000 Pascals. -! On the Cray, fpkap is over 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: pkap=fpkapq(p) -! -! Input argument list: -! p Real(krealfp) pressure in Pascals -! -! Output argument list: -! fpkapq Real(krealfp) p over 1e5 Pa to the kappa power -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpkapq - real(krealfp),intent(in):: p - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpkap+c2xpkap*p,1._krealfp),real(nxpkap,krealfp)) - jx=min(max(nint(xj),2),nxpkap-1) - dxj=xj-jx - fj1=tbpkap(jx-1) - fj2=tbpkap(jx) - fj3=tbpkap(jx+1) - fpkapq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - function fpkapo(p) -!$$$ Subprogram documentation block -! -! Subprogram: fpkapo raise surface pressure to the kappa power. -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: Raise surface pressure over 1e5 Pa to the kappa power -! using a rational weighted chebyshev approximation. -! The numerator is of order 2 and the denominator is of order 4. -! The pressure range is 40000-110000 Pa and kappa is defined in fpkapx. -! The accuracy of this approximation is almost 8 decimal places. -! On the Cray, fpkap is over 10 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! -! Usage: pkap=fpkapo(p) -! -! Input argument list: -! p Real(krealfp) surface pressure in Pascals -! p should be in the range 40000 to 110000 -! -! Output argument list: -! fpkapo Real(krealfp) p over 1e5 Pa to the kappa power -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpkapo - real(krealfp),intent(in):: p - integer,parameter:: nnpk=2,ndpk=4 - real(krealfp):: cnpk(0:nnpk)=(/3.13198449e-1,5.78544829e-2,& - 8.35491871e-4/) - real(krealfp):: cdpk(0:ndpk)=(/1.,8.15968401e-2,5.72839518e-4,& - -4.86959812e-7,5.24459889e-10/) - integer n - real(krealfp) pkpa,fnpk,fdpk -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - pkpa=p*1.e-3_krealfp - fnpk=cnpk(nnpk) - do n=nnpk-1,0,-1 - fnpk=pkpa*fnpk+cnpk(n) - enddo - fdpk=cdpk(ndpk) - do n=ndpk-1,0,-1 - fdpk=pkpa*fdpk+cdpk(n) - enddo - fpkapo=fnpk/fdpk -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpkapx(p) -!$$$ Subprogram documentation block -! -! Subprogram: fpkapx raise pressure to the kappa power. -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: raise pressure over 1e5 Pa to the kappa power. -! Kappa is equal to rd/cp where rd and cp are physical constants. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 94-12-30 Iredell made into inlinable function -! 1999-03-01 Iredell f90 module -! -! Usage: pkap=fpkapx(p) -! -! Input argument list: -! p Real(krealfp) pressure in Pascals -! -! Output argument list: -! fpkapx Real(krealfp) p over 1e5 Pa to the kappa power -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpkapx - real(krealfp),intent(in):: p -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - fpkapx=(p/1.e5_krealfp)**con_rocp -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine grkap -!$$$ Subprogram documentation block -! -! Subprogram: grkap Compute coefficients for p**(1/kappa) -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: Computes pressure to the 1/kappa table as a function of pressure -! for the table lookup function frkap. -! Exact pressure to the 1/kappa values are calculated in subprogram frkapx. -! The current implementation computes a table with a length -! of 5501 for pressures ranging up to 110000 Pascals. -! -! Program History Log: -! 94-12-30 Iredell -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: call grkap -! -! Subprograms called: -! frkapx function to compute exact pressure to the 1/kappa -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,p -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=0._krealfp - xmax=fpkapx(110000._krealfp) - xinc=(xmax-xmin)/(nxrkap-1) - c1xrkap=1.-xmin/xinc - c2xrkap=1./xinc - do jx=1,nxrkap - x=xmin+(jx-1)*xinc - p=x - tbrkap(jx)=frkapx(p) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function frkap(pkap) -!$$$ Subprogram Documentation Block -! -! Subprogram: frkap raise pressure to the 1/kappa power. -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Raise pressure over 1e5 Pa to the 1/kappa power. -! A linear interpolation is done between values in a lookup table -! computed in grkap. See documentation for frkapx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 7 decimal places. -! On the IBM, fpkap is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: p=frkap(pkap) -! -! Input argument list: -! pkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! Output argument list: -! frkap Real(krealfp) pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) frkap - real(krealfp),intent(in):: pkap - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xrkap+c2xrkap*pkap,1._krealfp),real(nxrkap,krealfp)) - jx=min(xj,nxrkap-1._krealfp) - frkap=tbrkap(jx)+(xj-jx)*(tbrkap(jx+1)-tbrkap(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function frkapq(pkap) -!$$$ Subprogram Documentation Block -! -! Subprogram: frkapq raise pressure to the 1/kappa power. -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Raise pressure over 1e5 Pa to the 1/kappa power. -! A quadratic interpolation is done between values in a lookup table -! computed in grkap. see documentation for frkapx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 11 decimal places. -! On the IBM, fpkap is almost 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: p=frkapq(pkap) -! -! Input argument list: -! pkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! Output argument list: -! frkapq Real(krealfp) pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) frkapq - real(krealfp),intent(in):: pkap - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xrkap+c2xrkap*pkap,1._krealfp),real(nxrkap,krealfp)) - jx=min(max(nint(xj),2),nxrkap-1) - dxj=xj-jx - fj1=tbrkap(jx-1) - fj2=tbrkap(jx) - fj3=tbrkap(jx+1) - frkapq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function frkapx(pkap) -!$$$ Subprogram documentation block -! -! Subprogram: frkapx raise pressure to the 1/kappa power. -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: raise pressure over 1e5 Pa to the 1/kappa power. -! Kappa is equal to rd/cp where rd and cp are physical constants. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 94-12-30 Iredell made into inlinable function -! 1999-03-01 Iredell f90 module -! -! Usage: p=frkapx(pkap) -! -! Input argument list: -! pkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! Output argument list: -! frkapx Real(krealfp) pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) frkapx - real(krealfp),intent(in):: pkap -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - frkapx=pkap**(1/con_rocp)*1.e5_krealfp -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtlcl -!$$$ Subprogram Documentation Block -! -! Subprogram: gtlcl Compute equivalent potential temperature table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute lifting condensation level temperature table -! as a function of temperature and dewpoint depression for function ftlcl. -! Lifting condensation level temperature is calculated in subprogram ftlclx -! The current implementation computes a table with a first dimension -! of 151 for temperatures ranging from 180.0 to 330.0 Kelvin -! and a second dimension of 61 for dewpoint depression ranging from -! 0 to 60 Kelvin. -! -! Program History Log: -! 1999-03-01 Iredell f90 module -! -! Usage: call gtlcl -! -! Subprograms called: -! (ftlclx) inlinable function to compute LCL temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx,jy - real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,tdpd,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=180._krealfp - xmax=330._krealfp - ymin=0._krealfp - ymax=60._krealfp - xinc=(xmax-xmin)/(nxtlcl-1) - c1xtlcl=1.-xmin/xinc - c2xtlcl=1./xinc - yinc=(ymax-ymin)/(nytlcl-1) - c1ytlcl=1.-ymin/yinc - c2ytlcl=1./yinc - do jy=1,nytlcl - y=ymin+(jy-1)*yinc - tdpd=y - do jx=1,nxtlcl - x=xmin+(jx-1)*xinc - t=x - tbtlcl(jx,jy)=ftlclx(t,tdpd) - enddo - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function ftlcl(t,tdpd) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftlcl Compute LCL temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature at the lifting condensation level -! from temperature and dewpoint depression. -! A bilinear interpolation is done between values in a lookup table -! computed in gtlcl. See documentation for ftlclx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.0005 Kelvin. -! On the Cray, ftlcl is ? times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 1999-03-01 Iredell f90 module -! -! Usage: tlcl=ftlcl(t,tdpd) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! Output argument list: -! ftlcl Real(krealfp) temperature at the LCL in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftlcl - real(krealfp),intent(in):: t,tdpd - integer jx,jy - real(krealfp) xj,yj,ftx1,ftx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtlcl+c2xtlcl*t,1._krealfp),real(nxtlcl,krealfp)) - yj=min(max(c1ytlcl+c2ytlcl*tdpd,1._krealfp),real(nytlcl,krealfp)) - jx=min(xj,nxtlcl-1._krealfp) - jy=min(yj,nytlcl-1._krealfp) - ftx1=tbtlcl(jx,jy)+(xj-jx)*(tbtlcl(jx+1,jy)-tbtlcl(jx,jy)) - ftx2=tbtlcl(jx,jy+1)+(xj-jx)*(tbtlcl(jx+1,jy+1)-tbtlcl(jx,jy+1)) - ftlcl=ftx1+(yj-jy)*(ftx2-ftx1) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftlclq(t,tdpd) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftlclq Compute LCL temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature at the lifting condensation level -! from temperature and dewpoint depression. -! A biquadratic interpolation is done between values in a lookup table -! computed in gtlcl. see documentation for ftlclx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.000003 Kelvin. -! On the Cray, ftlclq is ? times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 1999-03-01 Iredell f90 module -! -! Usage: tlcl=ftlclq(t,tdpd) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! Output argument list: -! ftlcl Real(krealfp) temperature at the LCL in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftlclq - real(krealfp),intent(in):: t,tdpd - integer jx,jy - real(krealfp) xj,yj,dxj,dyj - real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 - real(krealfp) ftx1,ftx2,ftx3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtlcl+c2xtlcl*t,1._krealfp),real(nxtlcl,krealfp)) - yj=min(max(c1ytlcl+c2ytlcl*tdpd,1._krealfp),real(nytlcl,krealfp)) - jx=min(max(nint(xj),2),nxtlcl-1) - jy=min(max(nint(yj),2),nytlcl-1) - dxj=xj-jx - dyj=yj-jy - ft11=tbtlcl(jx-1,jy-1) - ft12=tbtlcl(jx-1,jy) - ft13=tbtlcl(jx-1,jy+1) - ft21=tbtlcl(jx,jy-1) - ft22=tbtlcl(jx,jy) - ft23=tbtlcl(jx,jy+1) - ft31=tbtlcl(jx+1,jy-1) - ft32=tbtlcl(jx+1,jy) - ft33=tbtlcl(jx+1,jy+1) - ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 - ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 - ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 - ftlclq=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - function ftlclo(t,tdpd) -!$$$ Subprogram documentation block -! -! Subprogram: ftlclo Compute LCL temperature. -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: Compute temperature at the lifting condensation level -! from temperature and dewpoint depression. the formula used is -! a polynomial taken from Phillips mstadb routine which empirically -! approximates the original exact implicit relationship. -! (This kind of approximation is customary (inman, 1969), but -! the original source for this particular one is not yet known. -MI) -! Its accuracy is about 0.03 Kelvin for a dewpoint depression of 30. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 1999-03-01 Iredell f90 module -! -! Usage: tlcl=ftlclo(t,tdpd) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! Output argument list: -! ftlclo Real(krealfp) temperature at the LCL in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftlclo - real(krealfp),intent(in):: t,tdpd - real(krealfp),parameter:: clcl1= 0.954442e+0,clcl2= 0.967772e-3,& - clcl3=-0.710321e-3,clcl4=-0.270742e-5 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ftlclo=t-tdpd*(clcl1+clcl2*t+tdpd*(clcl3+clcl4*t)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftlclx(t,tdpd) -!$$$ Subprogram documentation block -! -! Subprogram: ftlclx Compute LCL temperature. -! Author: Iredell org: w/NMC2X2 Date: 25 March 1999 -! -! Abstract: Compute temperature at the lifting condensation level -! from temperature and dewpoint depression. A parcel lifted -! adiabatically becomes saturated at the lifting condensation level. -! The water model assumes a perfect gas, constant specific heats -! for gas and liquid, and neglects the volume of the liquid. -! The model does account for the variation of the latent heat -! of condensation with temperature. The ice option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formulas -! pvlcl=con_psat*(trlcl**xa)*exp(xb*(1.-trlcl)) -! pvdew=con_psat*(trdew**xa)*exp(xb*(1.-trdew)) -! where pvlcl is the saturated parcel vapor pressure at the LCL, -! pvdew is the unsaturated parcel vapor pressure initially, -! trlcl is ttp/tlcl and trdew is ttp/tdew. The adiabatic lifting -! of the parcel is represented by the following formula -! pvdew=pvlcl*(t/tlcl)**(1/kappa) -! This formula is inverted by iterating Newtonian approximations -! until tlcl is found to within 1.e-6 Kelvin. Note that the minimum -! returned temperature is 180 Kelvin. -! -! Program History Log: -! 1999-03-25 Iredell -! -! Usage: tlcl=ftlclx(t,tdpd) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! Output argument list: -! ftlclx Real(krealfp) temperature at the LCL in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftlclx - real(krealfp),intent(in):: t,tdpd - real(krealfp),parameter:: terrm=1.e-4,tlmin=180.,tlminx=tlmin-5. - real(krealfp) tr,pvdew,tlcl,ta,pvlcl,el,dpvlcl,terr - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/(t-tdpd) - pvdew=con_psat*(tr**con_xpona)*exp(con_xponb*(1.-tr)) - tlcl=t-tdpd - do i=1,100 - tr=con_ttp/tlcl - ta=t/tlcl - pvlcl=con_psat*(tr**con_xpona)*exp(con_xponb*(1.-tr))*ta**(1/con_rocp) - el=con_hvap+con_dldt*(tlcl-con_ttp) - dpvlcl=(el/(con_rv*t**2)+1/(con_rocp*tlcl))*pvlcl - terr=(pvlcl-pvdew)/dpvlcl - tlcl=tlcl-terr - if(abs(terr).le.terrm.or.tlcl.lt.tlminx) exit - enddo - ftlclx=max(tlcl,tlmin) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gfuncphys -!$$$ Subprogram Documentation Block -! -! Subprogram: gfuncphys Compute all physics function tables -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute all physics function tables. Lookup tables are -! set up for computing saturation vapor pressure, dewpoint temperature, -! equivalent potential temperature, moist adiabatic temperature and humidity, -! pressure to the kappa, and lifting condensation level temperature. -! -! Program History Log: -! 1999-03-01 Iredell f90 module -! -! Usage: call gfuncphys -! -! Subprograms called: -! gpvsl compute saturation vapor pressure over liquid table -! gpvsi compute saturation vapor pressure over ice table -! gpvs compute saturation vapor pressure table -! gtdpl compute dewpoint temperature over liquid table -! gtdpi compute dewpoint temperature over ice table -! gtdp compute dewpoint temperature table -! gthe compute equivalent potential temperature table -! gtma compute moist adiabat tables -! gpkap compute pressure to the kappa table -! grkap compute pressure to the 1/kappa table -! gtlcl compute LCL temperature table -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call gpvsl - call gpvsi - call gpvs - call gtdpl - call gtdpi - call gtdp - call gthe - call gtma - call gpkap - call grkap - call gtlcl -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- -end module diff --git a/sorc/gfs_bufr.fd/gfsbufr.f b/sorc/gfs_bufr.fd/gfsbufr.f deleted file mode 100755 index e6e3d06517..0000000000 --- a/sorc/gfs_bufr.fd/gfsbufr.f +++ /dev/null @@ -1,276 +0,0 @@ - program meteormrf -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C -C MAIN PROGRAM: METEOMRF -C PRGMMR: PAN ORG: NP23 DATE: 1999-07-21 -C -C ABSTRACT: Creates BUFR meteogram files for the AVN and MRF. -C -C PROGRAM HISTORY LOG: -C 99-07-21 Hualu Pan -C 16-09-27 HUIYA CHUANG MODIFY TO READ GFS NEMS OUTPUT ON GRID SPACE -C 16-10-15 HUIYA CHUANG: CONSOLIDATE TO READ FLUX FIELDS IN THIS -C PACKAGE TOO AND THIS SPEEDS UP BFS BUFR BY 3X -C 17-02-27 GUANG PING LOU: CHANGE MODEL OUTPUT READ-IN TO HOURLY -C TO 120 HOURS AND 3 HOURLY TO 180 HOURS. -C 19-07-16 GUANG PING LOU: CHANGE FROM NEMSIO TO GRIB2. -C -C -C USAGE: -C INPUT FILES: -C FTxxF001 - UNITS 11 THRU 49 -C PARM - UNIT 5 (STANDARD READ) -C -C OUTPUT FILES: (INCLUDING SCRATCH FILES) -C FTxxF001 - UNITS 51 THRU 79 -C FTxxF001 - UNIT 6 (STANDARD PRINTFILE) -C -C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES) -C UNIQUE: - ROUTINES THAT ACCOMPANY SOURCE FOR COMPILE -C LIBRARY: -C W3LIB - -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN -C =NNNN - TROUBLE OR SPECIAL FLAG - SPECIFY NATURE -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS -C MACHINE: IBM SP -C -C$$$ - use netcdf - use mpi - use nemsio_module - use sigio_module - implicit none -!! include 'mpif.h' - integer,parameter:: nsta=3000 - integer,parameter:: ifile=11 - integer,parameter:: levso=64 - integer(sigio_intkind):: irets - type(nemsio_gfile) :: gfile - integer ncfsig, nsig - integer istat(nsta), idate(4), jdate - integer :: levs,nstart,nend,nint,nsfc,levsi,im,jm - integer :: npoint,np,ist,is,iret,lss,nss,nf,nsk,nfile - integer :: ielev - integer :: lsfc - real :: alat,alon,rla,rlo - real :: wrkd(1),dummy - real rlat(nsta), rlon(nsta), elevstn(nsta) - integer iidum(nsta),jjdum(nsta) - integer nint1, nend1, nint3, nend3, np1 - integer landwater(nsta) - character*1 ns, ew - character*4 t3 - character*4 cstat(nsta) - character*32 desc - character*150 dird, fnsig - logical f00, makebufr - CHARACTER*150 FILESEQ - CHARACTER*8 SBSET - LOGICAL SEQFLG(4) - CHARACTER*80 CLIST(4) - INTEGER NPP(4) - CHARACTER*8 SEQNAM(4) - integer ierr, mrank, msize,ntask - integer n0, ntot - integer :: error, ncid, id_var,dimid - character(len=10) :: dim_nam - character(len=6) :: fformat - !added from Cory - integer :: iope, ionproc - integer, allocatable :: iocomms(:) -C - DATA SBSET / 'ABCD1234' / -C - DATA SEQFLG / .FALSE., .TRUE., .FALSE., .FALSE. / -C - DATA SEQNAM / 'HEADR', 'PROFILE', 'CLS1' ,'D10M' / -c DATA SEQNAM / 'HEADR', 'PRES TMDB UWND VWND SPFH OMEG', -c & 'CLS1' ,'D10M' / -C - namelist /nammet/ levs, makebufr, dird, - & nstart, nend, nint, nend1, nint1, - & nint3, nsfc, f00, fformat, np1 - - call mpi_init(ierr) - call mpi_comm_rank(MPI_COMM_WORLD,mrank,ierr) - call mpi_comm_size(MPI_COMM_WORLD,msize,ierr) - if(mrank.eq.0) then - CALL W3TAGB('METEOMRF',1999,0202,0087,'NP23') - endif - open(5,file='gfsparm') - read(5,nammet) - write(6,nammet) - npoint = 0 - 99 FORMAT (I6, F6.2,A1, F7.2,A1,1X,A4,1X,I2, A28, I4) - do np = 1, nsta+2 - read(8,99,end=200) IST,ALAT,NS,ALON,EW,T3,lsfc,DESC,IELEV -CC print*," IST,ALAT,NS,ALON,EW,T3,lsfc,DESC,IELEV= " -CC print*, IST,ALAT,NS,ALON,EW,T3,lsfc,DESC,IELEV - if(alat.lt.95.) then - npoint = npoint + 1 - RLA = 9999. - IF (NS .EQ. 'N') RLA = ALAT - IF (NS .EQ. 'S') RLA = -ALAT - RLO = 9999. - IF (EW .EQ. 'E') RLO = ALON - IF (EW .EQ. 'W') RLO = -ALON - rlat(npoint) = rla - rlon(npoint) = rlo - istat(npoint) = ist - cstat(npoint) = T3 - elevstn(npoint) = ielev - - if(lsfc .le. 9) then - landwater(npoint) = 2 !!nearest - else if(lsfc .le. 19) then - landwater(npoint) = 1 !!land - else if(lsfc .ge. 20) then - landwater(npoint) = 0 !!water - endif - endif - enddo - 200 continue - if(npoint.le.0) then - print *, ' station list file is empty, abort program' - call abort - elseif(npoint.gt.nsta) then - print *, ' number of station exceeds nsta, abort program' - call abort - endif -! print*,'npoint= ', npoint -! print*,'np,IST,idum,jdum,rlat(np),rlon(np)= ' - if(np1 == 0) then - do np = 1, npoint - read(7,98) IST, iidum(np), jjdum(np), ALAT, ALON - enddo - endif - 98 FORMAT (3I6, 2F9.2) - if (mrank.eq.0.and.makebufr) then - REWIND 1 - READ (1,100) SBSET - 100 FORMAT ( ////// 2X, A8 ) - PRINT 120, SBSET - 120 FORMAT ( ' SBSET=#', A8, '#' ) - REWIND 1 -C -C READ PARM NAMES AND NUMBER OF PARM NAMES FROM BUFR TABLE. - DO IS = 1,4 - CALL BFRHDR ( 1, SEQNAM(IS), SEQFLG(IS), - X CLIST(IS), NPP(IS), IRET ) - IF ( IRET .NE. 0 ) THEN - PRINT*, ' CALL BFRHDR IRET=', IRET - ENDIF - ENDDO - lss = len ( dird ) - DO WHILE ( dird (lss:lss) .eq. ' ' ) - lss = lss - 1 - END DO -C - endif - nsig = 11 - nss = nstart + nint - if(f00) nss = nstart -c do nf = nss, nend, nint - ntot = (nend - nss) / nint + 1 - ntask = mrank/(float(msize)/float(ntot)) - nf = ntask * nint + nss - print*,'n0 ntot nint nss mrank msize' - print*, n0,ntot,nint,nss,mrank,msize - print*,'nf, ntask= ', nf, ntask - if(nf .le. nend1) then - nfile = 21 + (nf / nint1) - else - nfile = 21 + (nend1/nint1) + (nf-nend1)/nint3 - endif - print*, 'nf,nint,nfile = ',nf,nint,nfile - if(nf.le.nend) then - if(nf.lt.10) then - fnsig = 'sigf0' - write(fnsig(6:6),'(i1)') nf - ncfsig = 6 - elseif(nf.lt.100) then - fnsig = 'sigf' - write(fnsig(5:6),'(i2)') nf - ncfsig = 6 - else - fnsig = 'sigf' - write(fnsig(5:7),'(i3)') nf - ncfsig = 7 - endif - print *, 'Opening file : ',fnsig - -!! read in either nemsio or NetCDF files - if (fformat == 'netcdf') then - error=nf90_open(trim(fnsig),nf90_nowrite,ncid) - error=nf90_inq_dimid(ncid,"grid_xt",dimid) - error=nf90_inquire_dimension(ncid,dimid,dim_nam,im) - error=nf90_inq_dimid(ncid,"grid_yt",dimid) - error=nf90_inquire_dimension(ncid,dimid,dim_nam,jm) - error=nf90_inq_dimid(ncid,"pfull",dimid) - error=nf90_inquire_dimension(ncid,dimid,dim_nam,levsi) - error=nf90_close(ncid) - print*,'NetCDF file im,jm,lm= ',im,jm,levs,levsi - - else - call nemsio_init(iret=irets) - print *,'nemsio_init, iret=',irets - call nemsio_open(gfile,trim(fnsig),'read',iret=irets) - if ( irets /= 0 ) then - print*,"fail to open nems atmos file";stop - endif - - call nemsio_getfilehead(gfile,iret=irets - & ,dimx=im,dimy=jm,dimz=levsi) - if( irets /= 0 ) then - print*,'error finding model dimensions '; stop - endif - print*,'nemsio file im,jm,lm= ',im,jm,levsi - call nemsio_close(gfile,iret=irets) - endif - allocate (iocomms(0:ntot)) - if (fformat == 'netcdf') then - print*,'iocomms= ', iocomms - call mpi_comm_split(MPI_COMM_WORLD,ntask,0,iocomms(ntask),ierr) - call mpi_comm_rank(iocomms(ntask), iope, ierr) - call mpi_comm_size(iocomms(ntask), ionproc, ierr) - - call meteorg(npoint,rlat,rlon,istat,cstat,elevstn, - & nf,nfile,fnsig,jdate,idate, - & levsi,im,jm,nsfc, - & landwater,nend1, nint1, nint3, iidum,jjdum,np1, - & fformat,iocomms(ntask),iope,ionproc) - call mpi_barrier(iocomms(ntask), ierr) - call mpi_comm_free(iocomms(ntask), ierr) - else -!! For nemsio input - call meteorg(npoint,rlat,rlon,istat,cstat,elevstn, - & nf,nfile,fnsig,jdate,idate, - & levs,im,jm,nsfc, - & landwater,nend1, nint1, nint3, iidum,jjdum,np1, - & fformat,iocomms(ntask),iope,ionproc) - endif - endif - call mpi_barrier(mpi_comm_world,ierr) - call mpi_finalize(ierr) - if(mrank.eq.0) then - print *, ' starting to make bufr files' - print *, ' makebufr= ', makebufr - print *, 'nint1,nend1,nint3,nend= ',nint1,nend1,nint3,nend -!! idate = 0 7 1 2019 -!! jdate = 2019070100 - - if(makebufr) then - nend3 = nend - call buff(nint1,nend1,nint3,nend3, - & npoint,idate,jdate,levso, - & dird,lss,istat,sbset,seqflg,clist,npp,wrkd) - CALL W3TAGE('METEOMRF') - endif - endif - end diff --git a/sorc/gfs_bufr.fd/gslp.f b/sorc/gfs_bufr.fd/gslp.f deleted file mode 100755 index 5b0eca1f51..0000000000 --- a/sorc/gfs_bufr.fd/gslp.f +++ /dev/null @@ -1,92 +0,0 @@ -!$$$ Subprogram documentation block -! -! Subprogram: gslp Compute sea level pressure as in the GFS -! Prgmmr: Iredell Org: np23 Date: 1999-10-18 -! -! Abstract: This subprogram computes sea level pressure from profile data -! using the Shuell method in the GFS. -! -! Program history log: -! 1999-10-18 Mark Iredell -! -! Usage: call gslp(km,hs,ps,p,t,sh,prmsl,h,ho) -! Input argument list: -! km integer number of levels -! hs real surface height (m) -! ps real surface pressure (Pa) -! p real (km) profile pressures (Pa) -! t real (km) profile temperatures (K) -! sh real (km) profile specific humidities (kg/kg) -! Output argument list: -! prmsl real sea level pressure (Pa) -! h real integer-layer height (m) -! ho real integer-layer height at 1000hPa and 500hPa (m) -! -! Modules used: -! physcons physical constants -! -! Attributes: -! Language: Fortran 90 -! -!$$$ -subroutine gslp(km,hs,ps,p,t,sh,prmsl,h,ho) - use physcons - implicit none - integer,intent(in):: km - real,intent(in):: hs,ps - real,intent(in),dimension(km):: p,t,sh - real,intent(out):: prmsl - real,intent(out),dimension(km):: h - real,intent(out),dimension(2):: ho - real,parameter:: gammam=-6.5e-3,zshul=75.,tvshul=290.66 - real,parameter:: pm1=1.e5,tm1=287.45,hm1=113.,hm2=5572.,& - fslp=con_g*(hm2-hm1)/(con_rd*tm1) - integer k,i - real aps,ap(km),tv(km) - real apo(2) - real tvu,tvd,gammas,part - real hfac -! compute model heights - aps=log(ps) - ap(1)=log(p(1)) - tv(1)=t(1)*(1+con_fvirt*sh(1)) - h(1)=hs-con_rog*tv(1)*(ap(1)-aps) - do k=2,km - ap(k)=log(p(k)) - tv(k)=t(k)*(1+con_fvirt*sh(k)) - h(k)=h(k-1)-con_rog*0.5*(tv(k-1)+tv(k))*(ap(k)-ap(k-1)) - enddo -! compute 1000 and 500 mb heights - apo(1)=log(1000.e2) - apo(2)=log(500.e2) - do i=1,2 - if(aps.lt.apo(i)) then - tvu=tv(1) - if(h(1).gt.zshul) then - tvd=tvu-gammam*h(1) - if(tvd.gt.tvshul) then - if(tvu.gt.tvshul) then - tvd=tvshul-5.e-3*(tvu-tvshul)**2 - else - tvd=tvshul - endif - endif - gammas=(tvu-tvd)/h(1) - else - gammas=0. - endif - part=con_rog*(apo(i)-ap(1)) - ho(i)=h(1)-tvu*part/(1.+0.5*gammas*part) - else - do k=1,km - if(ap(k).lt.apo(i)) then - ho(i)=h(k)-con_rog*tv(k)*(apo(i)-ap(k)) - exit - endif - enddo - endif - enddo -! compute sea level pressure - hfac=ho(1)/(ho(2)-ho(1)) - prmsl=pm1*exp(fslp*hfac) -end subroutine diff --git a/sorc/gfs_bufr.fd/lcl.f b/sorc/gfs_bufr.fd/lcl.f deleted file mode 100755 index 5fa4c4719e..0000000000 --- a/sorc/gfs_bufr.fd/lcl.f +++ /dev/null @@ -1,45 +0,0 @@ - SUBROUTINE LCL(TLCL,PLCL,T,P,Q) -C -C LIFTING CONDENSATION LEVEL ROUTINE -C - REAL L0, KAPPA - parameter (dtdp=4.5e-4,kappa=.286,g=9.81) - parameter (cp=1004.6,cl=4185.5,cpv=1846.0) - parameter (rv=461.5,l0=2.500e6,t0=273.16,es0=610.78) - parameter (cps=2106.0,hfus=3.3358e5,rd=287.05) - parameter (fact1=(CPV - CL) / RV,fact1i=(cps-cl)/rv) - parameter (fact2=(L0 + (CL - CPV) * T0) / RV) - parameter (fact2i=(L0 + hfus + (CL - cps) * T0) / RV) - parameter (fact3=1. / T0,eps=rd/rv,tmix=t0-20.) - DESDT(ES,T) = ES * (FACT1 / T + FACT2 / T ** 2) - DESDTi(ES,T) = ES * (FACT1i / T + FACT2i / T ** 2) - ITER = 0 - CALL TDEW(TG,T,Q,P) - 5 CALL SVP(QS,ES,P,TG) - DES = DESDT(ES,TG) - if(tg.ge.t0) then - des = desdt(es,tg) - elseif(tg.lt.tmix) then - des = desdti(es,tg) - else - w = (tg - tmix) / (t0 - tmix) - des = w * desdt(es,tg) + (1.-w) * desdti(es,tg) - endif - FT = P * (TG / T) ** KAPPA - DFT = KAPPA * FT / TG - GT = (EPS + Q * (1. - EPS)) * ES - Q * FT - DGT = (EPS + Q * (1. - EPS)) * DES - Q * DFT - DTG = GT / DGT -c WRITE(6,*) ' ITER, DTG =', ITER, DTG - TG = TG - DTG - IF(ABS(DTG).LT..1) GOTO 10 - ITER = ITER + 1 - IF(ITER.GT.30) THEN - WRITE(6,*) ' LCL ITERATION DIVERGES' - STOP 'ABEND 101' - ENDIF - GOTO 5 - 10 TLCL = TG - PLCL = P * (TLCL / T) ** KAPPA - RETURN - END diff --git a/sorc/gfs_bufr.fd/machine.f b/sorc/gfs_bufr.fd/machine.f deleted file mode 100755 index bec00028ad..0000000000 --- a/sorc/gfs_bufr.fd/machine.f +++ /dev/null @@ -1,15 +0,0 @@ - MODULE MACHINE - - IMPLICIT NONE - SAVE -! Machine dependant constants - integer kind_io4,kind_io8,kind_phys,kind_rad - parameter (kind_rad = selected_real_kind(13,60)) ! the '60' maps to 64-bit real - parameter (kind_phys = selected_real_kind(13,60)) ! the '60' maps to 64-bit real - parameter (kind_io4 = 4) -! parameter (kind_io8 = 8) - parameter (kind_io8 = 4) - integer kint_mpi - parameter (kint_mpi = 4) - - END MODULE MACHINE diff --git a/sorc/gfs_bufr.fd/makefile_module b/sorc/gfs_bufr.fd/makefile_module deleted file mode 100755 index d9d5374a7a..0000000000 --- a/sorc/gfs_bufr.fd/makefile_module +++ /dev/null @@ -1,79 +0,0 @@ -##################################################################################### -# gfs_bufr using module compile standard -# # 11/08/2019 guang.ping.lou@noaa.gov: Create NetCDF version -# ##################################################################################### -# set -eux -# - -FC = $(myFC) $(myFCFLAGS) -CPP = $(myCPP) $(myCPPFLAGS) - -FFLAGS = -I$(NETCDF_INCLUDES) \ - -I$(NEMSIO_INC) \ - -I$(SIGIO_INC) \ - -I$(W3EMC_INC4) - -LIBS = -L$(NETCDF_LIBRARIES) -lnetcdff -lnetcdf \ - -L$(HDF5_LIBRARIES) -lhdf5_hl -lhdf5 -lz \ - $(NEMSIO_LIB) \ - $(W3EMC_LIB4) \ - $(W3NCO_LIB4) \ - $(BUFR_LIB4) \ - $(BACIO_LIB4) \ - $(SP_LIB4) \ - $(SIGIO_LIB) - -SRCM = gfsbufr.f -OBJS = physcons.o funcphys.o meteorg.o bfrhdr.o newsig1.o terp3.o\ - bfrize.o vintg.o buff.o rsearch.o \ - svp.o calpreciptype.o lcl.o mstadb.o tdew.o\ - machine.o gslp.o modstuff1.o read_nemsio.o read_netcdf_p.o - -CMD = ../../exec/gfs_bufr - -$(CMD): $(SRCM) $(OBJS) - $(FC) $(FFLAGS) $(SRCM) $(OBJS) $(LIBS) -o $(CMD) - -machine.o: machine.f - $(FC) $(FFLAGS) -free -c machine.f -physcons.o: physcons.f machine.o - $(FC) $(FFLAGS) -free -c physcons.f -funcphys.o: funcphys.f physcons.o - $(FC) $(FFLAGS) -free -c funcphys.f -gslp.o: gslp.f - $(FC) $(FFLAGS) -free -c gslp.f -modstuff1.o: modstuff1.f - $(FC) $(INC) $(FFLAGS) -free -c modstuff1.f -meteorg.o: meteorg.f physcons.o funcphys.o - $(FC) $(INC) $(FFLAGS) -c meteorg.f -read_netcdf_p.o: read_netcdf_p.f - $(FC) $(INC) $(FFLAGS) -c read_netcdf_p.f -read_nemsio.o: read_nemsio.f - $(FC) $(INC) $(FFLAGS) -c read_nemsio.f -bfrhdr.o: bfrhdr.f - $(FC) $(FFLAGS) -c bfrhdr.f -newsig1.o: newsig1.f - $(FC) $(FFLAGS) -c newsig1.f -terp3.o: terp3.f - $(FC) $(FFLAGS) -c terp3.f -bfrize.o: bfrize.f - $(FC) $(FFLAGS) -c bfrize.f -vintg.o: vintg.f - $(FC) $(FFLAGS) -c vintg.f -buff.o: buff.f - $(FC) $(FFLAGS) -c buff.f -rsearch.o: rsearch.f - $(FC) $(FFLAGS) -c rsearch.f -svp.o: svp.f - $(FC) $(FFLAGS) -c svp.f -calpreciptype.o: calpreciptype.f physcons.o funcphys.o - $(FC) $(FFLAGS) -FR -c calpreciptype.f -lcl.o: lcl.f - $(FC) $(FFLAGS) -c lcl.f -mstadb.o: mstadb.f - $(FC) $(FFLAGS) -c mstadb.f -tdew.o: tdew.f - $(FC) $(FFLAGS) -c tdew.f - -clean: - /bin/rm -f $(OBJS) *.mod gfs_bufr diff --git a/sorc/gfs_bufr.fd/meteorg.f b/sorc/gfs_bufr.fd/meteorg.f deleted file mode 100755 index 6b7c2c7db4..0000000000 --- a/sorc/gfs_bufr.fd/meteorg.f +++ /dev/null @@ -1,1326 +0,0 @@ - subroutine meteorg(npoint,rlat,rlon,istat,cstat,elevstn, - & nf,nfile,fnsig,jdate,idate, - & levs,im,jm,kdim, - & landwater,nend1,nint1,nint3,iidum,jjdum,np1, - & fformat,iocomms,iope,ionproc) - -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . . -! SUBPROGRAM: meteorg -! PRGMMR: HUALU PAN ORG: W/NMC23 DATE: 1999-07-21 -! -! ABSTRACT: Creates BUFR meteogram files for the AVN and MRF. -! -! PROGRAM HISTORY LOG: -! 1999-07-21 HUALU PAN -! 2007-02-02 FANGLIN YANG EXPAND FOR HYBRID COORDINATES USING SIGIO -! 2009-07-24 FANGLIN YANG CHANGE OUTPUT PRESSURE TO INTEGER-LAYER -! PRESSURE (line 290) -! CORRECT THE TEMPERATURE ADJUSTMENT (line 238) -! 2014-03-27 DANA CARLIS UNIFY CODE WITH GFS FORECAST MODEL PRECIP -! TYPE CALCULATION -! 2016-09-27 HUIYA CHUANG MODIFY TO READ GFS NEMS OUTPUT ON GRID SPACE -! 2017-02-27 GUANG PING LOU CHANGE OUTPUT PRECIPITATION TO HOURLY AMOUNT -! TO 120 HOURS AND 3 HOURLY TO 180 HOURS. -! 2018-02-01 GUANG PING LOU INGEST FV3GFS NEMSIO ACCUMULATED PRECIPITATION -! AND RECALCULATE HOURLY AND 3 HOURLY OUTPUT DEPENDING -! ON LOGICAL VALUE OF precip_accu. -! 2018-02-08 GUANG PING LOU ADDED READING IN AND USING DZDT AS VERTICAL VELOCITY -! 2018-02-16 GUANG PING LOU ADDED READING IN AND USING MODEL DELP AND DELZ -! 2018-02-21 GUANG PING LOU THIS VERSION IS BACKWARD COMPATIBLE TO GFS MODEL -! 2018-03-27 GUANG PING LOU CHANGE STATION ELEVATION CORRECTION LAPSE RATE FROM 0.01 TO 0.0065 -! 2018-03-28 GUANG PING LOU GENERALIZE TIME INTERVAL -! 2019-07-08 GUANG PING LOU ADDED STATION CHARACTER IDS -! 2019-10-08 GUANG PING LOU MODIFY TO READ IN NetCDF FILES. RETAIN NEMSIO -! RELATED CALLS AND CLEAN UP THE CODE. -! 2020-04-24 GUANG PING LOU Clean up code and remove station height -! adjustment -! -! USAGE: CALL PROGRAM meteorg -! INPUT: -! npoint - number of points -! rlat(npint) - latitude -! rlon(npoint) - longtitude -! istat(npoint) - station id -! elevstn(npoint) - station elevation (m) -! nf - forecast cycle -! fnsig - sigma file name -! idate(4) - date -! levs - input vertical layers -! kdim - sfc file dimension -! -! OUTPUT: -! nfile - output data file channel -! jdate - date YYYYMMDDHH -! -! ATTRIBUTES: -! LANGUAGE: -! MACHINE: IBM SP -! -!$$$ - use netcdf - use nemsio_module - use sigio_module - use physcons - use mersenne_twister - use funcphys - implicit none - include 'mpif.h' - type(nemsio_gfile) :: gfile - type(nemsio_gfile) :: ffile - type(nemsio_gfile) :: ffile2 - integer :: nfile,npoint,levs,kdim - integer :: nfile1 - integer :: i,j,im,jm,kk,idum,jdum,idvc,idsl -! idsl Integer(sigio_intkind) semi-lagrangian id -! idvc Integer(sigio_intkind) vertical coordinate id -! (=1 for sigma, =2 for ec-hybrid, =3 for ncep hybrid) - integer,parameter :: nvcoord=2 - integer,parameter :: levso=64 - integer :: idate(4),nij,nflx2,np,k,l,nf,nfhour,np1 - integer :: idate_nems(7) - integer :: iret,jdate,leveta,lm,lp1 - character*150 :: fnsig,fngrib -!! real*8 :: data(6*levs+25) - real*8 :: data2(6*levso+25) - real*8 :: rstat1 - character*8 :: cstat1 - character*4 :: cstat(npoint) - real :: fhour,pp,ppn,qs,qsn,esn,es,psfc,ppi,dtemp,nd - real :: t,q,u,v,td,tlcl,plcl,qw,tw,xlat,xlon - integer,dimension(npoint):: landwater - integer,dimension(im,jm):: lwmask - real,dimension(im,jm):: apcp, cpcp - real,dimension(npoint,2+levs*3):: grids - real,dimension(npoint) :: rlat,rlon,pmsl,ps,psn,elevstn - real,dimension(1) :: psone - real,dimension(im*jm) :: dum1d,dum1d2 - real,dimension(im,jm) :: gdlat, hgt, gdlon - real,dimension(im,jm,15) :: dum2d - real,dimension(im,jm,levs) :: t3d, q3d, uh, vh,omega3d - real,dimension(im,jm,levs) :: delpz - real,dimension(im,jm,levs+1) :: pint, zint - real,dimension(npoint,levs) :: gridu,gridv,omega,qnew,zp - real,dimension(npoint,levs) :: p1,pd3,ttnew - real,dimension(npoint,levs) :: z1 - real,dimension(npoint,levs+1) :: pi3 - real :: zp2(2) - real,dimension(kdim,npoint) :: sfc - real,dimension(1,levs+1) :: prsi,phii - real,dimension(1,levs) :: gt0,gq0,prsl,phy_f3d - real :: PREC,TSKIN,SR,randomno(1,2) - real :: DOMR,DOMZR,DOMIP,DOMS - real :: vcoord(levs+1,nvcoord),vdummy(levs+1) - real :: vcoordnems(levs+1,3,2) - real :: rdum - integer :: n3dfercld,iseedl - integer :: istat(npoint) - logical :: trace -!! logical, parameter :: debugprint=.true. - logical, parameter :: debugprint=.false. - character lprecip_accu*3 - real, parameter :: ERAD=6.371E6 - real, parameter :: DTR=3.1415926/180. - real :: ap - integer :: nf1, fint - integer :: nend1, nint1, nint3 - character*150 :: fngrib2 - integer recn_dpres,recn_delz,recn_dzdt - integer :: jrec - equivalence (cstat1,rstat1) - integer iidum(npoint),jjdum(npoint) - integer :: error, ncid, ncid2, id_var,dimid - character(len=100) :: long_name - character(len=6) :: fformat - integer,dimension(8) :: clocking - character(10) :: date - character(12) :: time - character(7) :: zone - character(3) :: Zreverse - character(20) :: VarName,LayName - integer iocomms,iope,ionproc - - nij = 12 -!! nflx = 6 * levs - nflx2 = 6 * levso - recn_dpres = 0 - recn_delz = 0 - recn_dzdt = 0 - jrec = 0 - lprecip_accu='yes' - - idvc=2 - idsl=1 -!read in NetCDF file header info - print*,"fformat= ", fformat -! print*,'meteorg.f, idum,jdum= ' -! do np = 1, npoint -! print*, iidum(np), jjdum(np) -! enddo - - if(fformat .eq. "netcdf") then - print*,'iocomms inside meteorg.f=', iocomms - error=nf90_open(trim(fnsig),ior(nf90_nowrite,nf90_mpiio), - & ncid,comm=iocomms, info = mpi_info_null) - error=nf90_get_att(ncid,nf90_global,"ak",vdummy) - do k = 1, levs+1 - vcoord(k,1)=vdummy(levs-k+1) - enddo - error=nf90_get_att(ncid,nf90_global,"bk",vdummy) - do k = 1, levs+1 - vcoord(k,2)=vdummy(levs-k+1) - enddo - error=nf90_inq_varid(ncid, "time", id_var) - error=nf90_get_var(ncid, id_var, nfhour) - print*, "nfhour:",nfhour - error=nf90_get_att(ncid,id_var,"units",long_name) -!! print*,'time units',' -- ',trim(long_name) - read(long_name(13:16),"(i4)")idate(4) - read(long_name(18:19),"(i2)")idate(2) - read(long_name(21:22),"(i2)")idate(3) - read(long_name(24:25),"(i2)")idate(1) - fhour=float(nfhour) - print*,'date= ', idate - jdate = idate(4)*1000000 + idate(2)*10000+ - & idate(3)*100 + idate(1) - print *, 'jdate = ', jdate - error=nf90_inq_varid(ncid, "lon", id_var) - error=nf90_get_var(ncid, id_var, gdlon) - error=nf90_inq_varid(ncid, "lat", id_var) - error=nf90_get_var(ncid, id_var, gdlat) -!!end read NetCDF hearder info, read nemsio below if necessary - else - - call nemsio_open(gfile,trim(fnsig),'read',iret=iret) - call nemsio_getfilehead(gfile,iret=iret - + ,idate=idate_nems(1:7),nfhour=nfhour - + ,idvc=idvc,idsl=idsl,lat=dum1d,lon=dum1d2 - + ,vcoord=vcoordnems) - - do k=1,levs+1 - vcoord(k,1)=vcoordnems(k,1,1) - vcoord(k,2)=vcoordnems(k,2,1) - end do - idate(1)=idate_nems(4) - idate(2)=idate_nems(2) - idate(3)=idate_nems(3) - idate(4)=idate_nems(1) - fhour=float(nfhour) - print *, ' processing forecast hour ', fhour - print *, ' idate =', idate - jdate = idate(4)*1000000 + idate(2)*10000+ - & idate(3)*100 + idate(1) - print *, 'jdate = ', jdate - print *, 'Total number of stations = ', npoint - ap = 0.0 - do j=1,jm - do i=1,im - gdlat(i,j)=dum1d((j-1)*im+i) - gdlon(i,j)=dum1d2((j-1)*im+i) - end do - end do - - endif !end read in nemsio hearder - - if(debugprint) then - do k=1,levs+1 - print*,'vcoord(k,1)= ', k, vcoord(k,1) - end do - do k=1,levs+1 - print*,'vcoord(k,2)= ', k, vcoord(k,2) - end do - print*,'sample lat= ',gdlat(im/5,jm/4) - + ,gdlat(im/5,jm/3),gdlat(im/5,jm/2) - print*,'sample lon= ',gdlon(im/5,jm/4) - + ,gdlon(im/5,jm/3),gdlon(im/5,jm/2) - endif -! topography - if (fformat == 'netcdf') then - VarName='hgtsfc' - Zreverse='yes' - call read_netcdf_p(ncid,im,jm,1,VarName,hgt,Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'surface hgt not found' - else - VarName='hgt' - LayName='sfc' - call read_nemsio(gfile,im,jm,1,VarName,LayName,hgt, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'surface hgt not found' - endif - if(debugprint)print*,'sample sfc h= ',hgt(im/5,jm/4) - + ,hgt(im/5,jm/3),hgt(im/5,jm/2) - -! surface pressure (Pa) - if (fformat == 'netcdf') then - VarName='pressfc' - Zreverse='yes' - call read_netcdf_p(ncid,im,jm,1,VarName,pint(:,:,1), - & Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'surface pressure not found' - else - VarName='pres' - LayName='sfc' - call read_nemsio(gfile,im,jm,1,VarName, - & LayName,pint(:,:,1),error) - if (error /= 0) print*,'surface pressure not found' - endif - if(debugprint)print*,'sample sfc P= ',pint(im/2,jm/4,1), - + pint(im/2,jm/3,1),pint(im/2,jm/2,1) - -! temperature using NetCDF - if (fformat == 'netcdf') then - VarName='tmp' - Zreverse='yes' - call read_netcdf_p(ncid,im,jm,levs,VarName,t3d,Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'temp not found' - else - VarName='tmp' - LayName='mid layer' - call read_nemsio(gfile,im,jm,levs,VarName,LayName,t3d,error) - if (error /= 0) print*,'temp not found' - endif - if(debugprint) then - print*,'sample T at lev=1 to levs ' - do k = 1, levs - print*,k, t3d(im/2,jm/3,k) - enddo - endif -! specific humidity - if (fformat == 'netcdf') then - VarName='spfh' - Zreverse='yes' - call read_netcdf_p(ncid,im,jm,levs,VarName,q3d,Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'spfh not found' - else - VarName='spfh' - LayName='mid layer' - call read_nemsio(gfile,im,jm,levs,VarName,LayName,q3d,error) - if (error /= 0) print*,'spfh not found' - endif - if(debugprint) then - print*,'sample Q at lev=1 to levs ' - do k = 1, levs - print*,k, q3d(im/2,jm/3,k) - enddo - endif -! U wind - if (fformat == 'netcdf') then - VarName='ugrd' - Zreverse='yes' - call read_netcdf_p(ncid,im,jm,levs,VarName,uh,Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'ugrd not found' - else - VarName='ugrd' - LayName='mid layer' - call read_nemsio(gfile,im,jm,levs,VarName,LayName,uh,error) - if (error /= 0) print*,'ugrd not found' - endif - if(debugprint) then - print*,'sample U at lev=1 to levs ' - do k = 1, levs - print*,k, uh(im/2,jm/3,k) - enddo - endif -! V wind - if (fformat == 'netcdf') then - VarName='vgrd' - Zreverse='yes' - call read_netcdf_p(ncid,im,jm,levs,VarName,vh,Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'vgrd not found' - else - VarName='vgrd' - LayName='mid layer' - call read_nemsio(gfile,im,jm,levs,VarName,LayName,vh,error) - if (error /= 0) print*,'vgrd not found' - endif - if(debugprint) then - print*,'sample V at lev=1 to levs ' - do k = 1, levs - print*,k, vh(im/2,jm/3,k) - enddo - endif -! dzdt !added by Guang Ping Lou for FV3GFS - if (fformat == 'netcdf') then - VarName='dzdt' - Zreverse='yes' - call read_netcdf_p(ncid,im,jm,levs,VarName,omega3d,Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'dzdt not found' - else - VarName='dzdt' - LayName='mid layer' - call read_nemsio(gfile,im,jm,levs,VarName,LayName, - & omega3d,error) - if (error /= 0) print*,'dzdt not found' - endif - if(debugprint) then - print*,'sample dzdt at lev=1 to levs ' - do k = 1, levs - print*,k, omega3d(im/2,jm/3,k) - enddo - endif -! dpres !added by Guang Ping Lou for FV3GFS (interface pressure delta) - if (fformat == 'netcdf') then - VarName='dpres' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,levs,VarName,delpz,Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'dpres not found' - else - VarName='dpres' - LayName='mid layer' - call read_nemsio(gfile,im,jm,levs,VarName,LayName, - & delpz,error) - if (error /= 0) print*,'dpres not found' - endif - if(debugprint) then - print*,'sample delp at lev=1 to levs ' - do k = 1, levs - print*,k, delpz(im/2,jm/3,k) - enddo - endif -! compute interface pressure - if(recn_dpres == -9999) then - do k=2,levs+1 - do j=1,jm - do i=1,im - pint(i,j,k)=vcoord(k,1) - + +vcoord(k,2)*pint(i,j,1) - end do - end do - end do - else -! compute pint using dpres from top down if DZDT is used - if (fformat == 'netcdf') then - do j=1,jm - do i=1,im - pint(i,j,levs+1) = delpz(i,j,1) - end do - end do - do k=levs,2,-1 - kk=levs-k+2 - do j=1,jm - do i=1,im - pint(i,j,k) = pint(i,j,k+1) + delpz(i,j,kk) - end do - end do - end do - else - do k=2,levs+1 - do j=1,jm - do i=1,im - pint(i,j,k) = pint(i,j,k-1) - delpz(i,j,k-1) - end do - end do - end do - endif - if(debugprint) then - print*,'sample interface pressure pint at lev =1 to levs ' - do k = 1, levs+1 - print*,k, pint(im/2,jm/3,k),pint(im/3,jm/8,k) - enddo - endif - endif -! delz !added by Guang Ping Lou for FV3GFS ("height thickness" with unit "meters" bottom up) - if (fformat == 'netcdf') then - VarName='delz' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,levs,VarName,delpz,Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'delz not found' - else - VarName='delz' - LayName='mid layer' - call read_nemsio(gfile,im,jm,levs,VarName,LayName,delpz,error) - if (error /= 0) print*,'delz not found' - endif - if(debugprint) then - print*,'sample delz at lev=1 to levs ' - do k = 1, levs - print*,k, delpz(im/2,jm/3,k) - enddo - endif - -! compute interface height (meter) - if(recn_delz == -9999) then - print*, 'using calculated height' - else -! compute zint using delz from bot up if DZDT is used - if (fformat == 'netcdf') then - do j=1,jm - do i=1,im - zint(i,j,1) = 0.0 - end do - end do - do k=2,levs+1 - kk=levs-k+1 - do j=1,jm - do i=1,im - zint(i,j,k) = zint(i,j,k-1) - delpz(i,j,kk) - end do - end do - end do - else - do k=2,levs+1 - do j=1,jm - do i=1,im - zint(i,j,k) = zint(i,j,k-1) + delpz(i,j,k-1) - end do - end do - end do - endif - if(debugprint) then - print*,'sample interface height zint at lev =1 to levs ' - do k = 1, levs+1 - print*,k, zint(im/2,jm/3,k),zint(im/3,jm/8,k) - enddo - endif - endif - -! close up this NetCDF file - error=nf90_close(ncid) - -! Now open up NetCDF surface files - if ( nf .le. nend1 ) then - nf1 = nf - nint1 - else - nf1 = nf - nint3 - endif - if ( nf == 0 ) nf1=0 - if(nf==0) then - fngrib='flxf00' - elseif(nf.lt.10) then - fngrib='flxf0' - write(fngrib(6:6),'(i1)') nf - elseif(nf.lt.100) then - fngrib='flxf' - write(fngrib(5:6),'(i2)') nf - else - fngrib='flxf' - write(fngrib(5:7),'(i3)') nf - endif - if(nf1==0) then - fngrib2='flxf00' - elseif(nf1.lt.10) then - fngrib2='flxf0' - write(fngrib2(6:6),'(i1)') nf1 - elseif(nf1.lt.100) then - fngrib2='flxf' - write(fngrib2(5:6),'(i2)') nf1 - else - fngrib2='flxf' - write(fngrib2(5:7),'(i3)') nf1 - endif - if (fformat == 'netcdf') then - error=nf90_open(trim(fngrib),nf90_nowrite,ncid) -!open T-nint below - error=nf90_open(trim(fngrib2),nf90_nowrite,ncid2) - if(error /= 0)print*,'file not open',trim(fngrib), trim(fngrib2) - else - call nemsio_open(ffile,trim(fngrib),'read',iret=error) - call nemsio_open(ffile2,trim(fngrib2),'read',iret=error) - if(error /= 0)print*,'file not open',trim(fngrib), trim(fngrib2) - endif -! land water mask - if (fformat == 'netcdf') then - VarName='land' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName,lwmask,Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'lwmask not found' - else - VarName='land' - LayName='sfc' - call read_nemsio(ffile,im,jm,1,VarName,LayName,lwmask,error) - if (error /= 0) print*,'lwmask not found' - endif - if(debugprint) - + print*,'sample land mask= ',lwmask(im/2,jm/4), - + lwmask(im/2,jm/3) - -! surface T - if (fformat == 'netcdf') then - VarName='tmpsfc' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName,dum2d(:,:,1), - & Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'tmpsfc not found' - else - VarName='tmp' - LayName='sfc' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - & dum2d(:,:,1),error) - if (error /= 0) print*,'tmpsfc not found' - endif - if(debugprint) - + print*,'sample sfc T= ',dum2d(im/2,jm/4,1),dum2d(im/2,jm/3,1), - + dum2d(im/2,jm/2,1) -! 2m T - if (fformat == 'netcdf') then - VarName='tmp2m' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName,dum2d(:,:,2), - & Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'tmp2m not found' - else - VarName='tmp' - LayName='2 m above gnd' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - + dum2d(:,:,2),error) - if (error /= 0) print*,'tmp2m not found' - endif - if(debugprint) - + print*,'sample 2m T= ',dum2d(im/2,jm/4,2),dum2d(im/2,jm/3,2), - + dum2d(im/2,jm/2,2) - -! 2m Q - if (fformat == 'netcdf') then - VarName='spfh2m' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName,dum2d(:,:,3), - & Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'spfh2m not found' - else - VarName='spfh' - LayName='2 m above gnd' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - + dum2d(:,:,3),error) - if (error /= 0) print*,'spfh2m not found' - endif - if(debugprint) - + print*,'sample 2m Q= ',dum2d(im/2,jm/4,3),dum2d(im/2,jm/3,3), - + dum2d(im/2,jm/2,3) - -! U10 - if (fformat == 'netcdf') then - VarName='ugrd10m' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName,dum2d(:,:,4), - & Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'ugrd10m not found' - else - VarName='ugrd' - LayName='10 m above gnd' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - + dum2d(:,:,4),error) - if (error /= 0) print*,'ugrd10m not found' - endif - -! V10 - if (fformat == 'netcdf') then - VarName='vgrd10m' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName,dum2d(:,:,5), - & Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'vgrd10m not found' - else - VarName='vgrd' - LayName='10 m above gnd' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - + dum2d(:,:,5),error) - if (error /= 0) print*,'vgrd10m not found' - endif - -! soil T - if (fformat == 'netcdf') then - VarName='soilt1' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName,dum2d(:,:,6), - & Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'soilt1 not found' - else - VarName='tmp' - LayName='0-10 cm down' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - + dum2d(:,:,6),error) - if (error /= 0) print*,'soil T not found' - endif - if(debugprint) - + print*,'sample soil T= ',dum2d(im/2,jm/4,6),dum2d(im/2,jm/3,6), - + dum2d(im/2,jm/2,6) - -! snow depth - if (fformat == 'netcdf') then - VarName='snod' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName,dum2d(:,:,7), - & Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'snod not found' - else - VarName='snod' - LayName='sfc' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - + dum2d(:,:,7),error) - if (error /= 0) print*,'snod not found' - endif - -! evaporation -!instantaneous surface latent heat net flux - if (fformat == 'netcdf') then - VarName='lhtfl' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName,dum2d(:,:,8), - & Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'lhtfl not found' - else - VarName='lhtfl' - LayName='sfc' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - + dum2d(:,:,8),error) - if (error /= 0) print*,'lhtfl not found' - endif - if(debugprint) - + print*,'evaporation latent heat net flux= ', - + dum2d(im/2,jm/4,8),dum2d(im/2,jm/3,8) - if(debugprint) - + print*,'evaporation latent heat net flux stn 000692)= ', - + dum2d(2239,441,8) - -! total precip - if ( nf .le. nend1 ) then - fint = nint1 - else - fint = nint3 - endif -! for accumulated precipitation: - if (fformat == 'netcdf') then - VarName='prate_ave' - Zreverse='no' -!! call read_netcdf_p(ncid,im,jm,1,VarName,apcp,Zreverse,error) !current hour - call read_netcdf_p(ncid,im,jm,1,VarName,apcp,Zreverse, - & iope,ionproc,iocomms,error) -!! call read_netcdf_p(ncid2,im,jm,1,VarName,cpcp,Zreverse,error) !earlier hour - call read_netcdf_p(ncid2,im,jm,1,VarName,cpcp,Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'prate_ave not found' - else - VarName='prate_ave' - LayName='sfc' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - + apcp,error) - call read_nemsio(ffile2,im,jm,1,VarName,LayName, - + cpcp,error) - if (error /= 0) print*,'prate_ave2 not found' - endif - if(debugprint) - & print*,'sample fhour ,3= ', fhour, - & '1sample precip rate= ',apcp(im/2,jm/3),cpcp(im/2,jm/3) - ap=fhour-fint - do j=1,jm - do i=1,im - dum2d(i,j,9) =(apcp(i,j)*fhour-cpcp(i,j)*ap)*3600.0 - end do - end do - - if(debugprint) - & print*,'sample fhour ,5= ', fhour, - & 'sample total precip= ',dum2d(im/2,jm/4,9), - + dum2d(im/2,jm/3,9),dum2d(im/2,jm/2,9) - -! convective precip - if (fformat == 'netcdf') then - VarName='cprat_ave' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName,apcp,Zreverse, - & iope,ionproc,iocomms,error) - call read_netcdf_p(ncid2,im,jm,1,VarName,cpcp,Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'cprat_ave not found' - else - VarName='cprat_ave' - LayName='sfc' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - + apcp,error) - call read_nemsio(ffile2,im,jm,1,VarName,LayName, - + cpcp,error) - if (error /= 0) print*,'cprat_ave2 not found' - endif - ap=fhour-fint - do j=1,jm - do i=1,im - dum2d(i,j,10)=(apcp(i,j)*fhour-cpcp(i,j)*ap)*3600.0 - & - end do - end do - -! water equi - if (fformat == 'netcdf') then - VarName='weasd' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName,dum2d(:,:,11), - & Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'weasd not found' - else - VarName='weasd' - LayName='sfc' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - + dum2d(:,:,11),error) - if (error /= 0) print*,'weasd not found' - endif - -! low cloud fraction - if (fformat == 'netcdf') then - VarName='tcdc_avelcl' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName, - & dum2d(:,:,12),Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'tcdc_avelcl not found' - else - VarName='tcdc_ave' - LayName='low cld lay' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - + dum2d(:,:,12),error) - if (error /= 0) print*,'low cld lay not found' - endif - -! mid cloud fraction - if (fformat == 'netcdf') then - VarName='tcdc_avemcl' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName, - & dum2d(:,:,13),Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'tcdc_avemcl not found' - else - VarName='tcdc_ave' - LayName='mid cld lay' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - + dum2d(:,:,13),error) - if (error /= 0) print*,'mid cld lay not found' - endif - -! high cloud fraction - if (fformat == 'netcdf') then - VarName='tcdc_avehcl' - Zreverse='no' - call read_netcdf_p(ncid,im,jm,1,VarName, - & dum2d(:,:,14),Zreverse, - & iope,ionproc,iocomms,error) - if (error /= 0) print*,'tcdc_avehcl not found' - else - VarName='tcdc_ave' - LayName='high cld lay' - call read_nemsio(ffile,im,jm,1,VarName,LayName, - + dum2d(:,:,14),error) - if (error /= 0) print*,'high cld lay not found' - endif - - if(debugprint) - + print*,'sample high cloud frac= ',dum2d(im/2,jm/4,14), - + dum2d(im/2,jm/3,14),dum2d(im/2,jm/2,14) - - if (fformat == 'netcdf') then - error=nf90_close(ncid) - error=nf90_close(ncid2) - else - call nemsio_close(ffile,iret=error) - call nemsio_close(ffile2,iret=error) - endif - call date_and_time(date,time,zone,clocking) -! print *,'10reading surface data end= ', clocking - print *,'10date, time, zone',date, time, zone -! -! get the nearest neighbor i,j from the table -! - do np=1, npoint -! use read in predetermined i,j - if (np1==0) then - idum=iidum(np) - jdum=jjdum(np) - - else -! find nearest neighbor - rdum=rlon(np) - if(rdum<0.)rdum=rdum+360. - - do j=1,jm-1 - do i=1,im-1 - if((rdum>=gdlon(i,j) .and. rdum<=gdlon(i+1,j)) .and. - + (rlat(np)<=gdlat(i,j).and.rlat(np)>=gdlat(i,j+1)) ) then - if(landwater(np) == 2)then - idum=i - jdum=j - exit - else if(landwater(np) == lwmask(i,j))then - idum=i - jdum=j !1 - exit - else if(landwater(np) == lwmask(i+1,j))then - idum=i+1 - jdum=j ! 2 - exit - else if(landwater(np) == lwmask(i-1,j))then - idum=i-1 - jdum=j ! 3 - exit - else if(landwater(np) == lwmask(i,j+1))then - idum=i - jdum=j+1 ! 4 - exit - else if(landwater(np) == lwmask(i,j-1))then - idum=i - jdum=j-1 ! 5 - exit - else if(landwater(np) == lwmask(i+1,j-1))then - idum=i+1 - jdum=j-1 ! 6 - exit - else if(landwater(np) == lwmask(i+1,j+1))then - idum=i+1 - jdum=j+1 ! 7 - exit - else if(landwater(np) == lwmask(i-1,j+1))then - idum=i-1 - jdum=j+1 ! 8 - exit - else if(landwater(np) == lwmask(i-1,j-1))then - idum=i-1 - jdum=j-1 ! 9 - exit - else if(landwater(np) == lwmask(i,j+2))then - idum=i - jdum=j+2 ! 10 - exit - else if(landwater(np) == lwmask(i+2,j))then - idum=i+2 - jdum=j !11 - exit - else if(landwater(np) == lwmask(i,j-2))then - idum=i - jdum=j-2 ! 12 - exit - else if(landwater(np) == lwmask(i-2,j))then - idum=i-2 - jdum=j !13 - exit - else if(landwater(np) == lwmask(i-2,j+1))then - idum=i-2 - jdum=j+1 ! 14 - exit - else if(landwater(np) == lwmask(i-1,j+2))then - idum=i-1 - jdum=j+2 !15 - exit - else if(landwater(np) == lwmask(i+1,j+2))then - idum=i+1 - jdum=j+2 !16 - exit - else if(landwater(np) == lwmask(i+2,j+1))then - idum=i+2 - jdum=j+1 !17 - exit - else if(landwater(np) == lwmask(i+2,j-1))then - idum=i+2 - jdum=j-1 !18 - exit - else if(landwater(np) == lwmask(i+1,j-2))then - idum=i+1 - jdum=j-2 !19 - exit - else if(landwater(np) == lwmask(i-1,j-2))then - idum=i-1 - jdum=j-2 !20 - exit - else if(landwater(np) == lwmask(i-2,j-1))then - idum=i-2 - jdum=j-1 !21 - exit - else if(landwater(np) == lwmask(i-2,j-2))then - idum=i-2 - jdum=j-2 !22 - exit - else if(landwater(np) == lwmask(i+2,j-2))then - idum=i+2 - jdum=j-2 !23 - exit - else if(landwater(np) == lwmask(i+2,j+2))then - idum=i+2 - jdum=j+2 !24 - exit - else if(landwater(np) == lwmask(i-2,j+2))then - idum=i-2 - jdum=j+2 !25 - exit - else if(landwater(np) == lwmask(i+3,j))then - idum=i+3 - jdum=j !26 - exit - else if(landwater(np) == lwmask(i-3,j))then - idum=i-3 - jdum=j !27 - exit - else if(landwater(np) == lwmask(i,j+3))then - idum=i - jdum=j+3 !28 - exit - else if(landwater(np) == lwmask(i,j-3))then - idum=i - jdum=j-3 !29 - exit - else -CC print*,'no matching land sea mask np,landwater,i,j,mask= ' -CC print*, np,landwater(np),i,j,lwmask(i,j) -CC print*, ' So it takes i,j ' - idum=i - jdum=j - exit - end if - end if - end do - end do - - idum=max0(min0(idum,im),1) - jdum=max0(min0(jdum,jm),1) - endif !! read in i,j ends here - if (fhour==0.0) then - if(debugprint) then - write(nij,98) np,idum,jdum,rlat(np),rlon(np) - 98 FORMAT (3I6, 2F9.2) - if(elevstn(np)==-999.) elevstn(np)=hgt(idum,jdum) - write(9,99) np,rlat(np),rlon(np),elevstn(np),hgt(idum,jdum) - 99 FORMAT (I6, 4F9.2) - if(np==1 .or.np==100)print*,'nearest neighbor for station ',np - + ,idum,jdum,rlon(np),rlat(np),lwmask(i,j),landwater(np) - endif - endif - - grids(np,1)=hgt(idum,jdum) - grids(np,2)=pint(idum,jdum,1) - - sfc(5,np)=dum2d(idum,jdum,1) - sfc(6,np)=dum2d(idum,jdum,6) - sfc(17,np)=dum2d(idum,jdum,8) - sfc(12,np)=dum2d(idum,jdum,9) - sfc(11,np)=dum2d(idum,jdum,10) - sfc(10,np)=dum2d(idum,jdum,11) - sfc(27,np)=dum2d(idum,jdum,12) - sfc(26,np)=dum2d(idum,jdum,13) - sfc(25,np)=dum2d(idum,jdum,14) - sfc(34,np)=dum2d(idum,jdum,4) - sfc(35,np)=dum2d(idum,jdum,5) - sfc(30,np)=dum2d(idum,jdum,2) - sfc(31,np)=dum2d(idum,jdum,3) - -CC There may be cases where convective precip is greater than total precip -CC due to rounding and interpolation errors, correct it here -G.P. Lou: - if(sfc(11,np) .gt. sfc(12,np)) sfc(11,np)=sfc(12,np) - - do k=1,levs - grids(np,k+2)=t3d(idum,jdum,k) - grids(np,k+2+levs)=q3d(idum,jdum,k) - grids(np,k+2+2*levs)=omega3d(idum,jdum,k) - gridu(np,k)=uh(idum,jdum,k) - gridv(np,k)=vh(idum,jdum,k) - p1(np,k)=pint(idum,jdum,k+1) - z1(np,k)=zint(idum,jdum,k+1) -!! p1(np,k)=0.5*(pint(idum,jdum,k)+pint(idum,jdum,k+1)) -!! z1(np,k)=0.5*(zint(idum,jdum,k)+zint(idum,jdum,k+1)) - - end do - end do - - print*,'finish finding nearest neighbor for each station' - - do np = 1, npoint -! !ps in kPa - ps(np) = grids(np,2)/1000. !! surface pressure - enddo - -! -! ----------------- -! Put topo(1),surf press(2),vir temp(3:66),and specifi hum(67:130) in grids -! for each station -!! if(recn_dzdt == 0 ) then !!DZDT - do k = 1, levs - do np = 1, npoint - omega(np,k) = grids(np,2+levs*2+k) - enddo - enddo - if(debugprint) - + print*,'sample (omega) dzdt ', (omega(3,k),k=1,levs) -! -! move surface pressure to the station surface from the model surface -! - do np = 1, npoint -! -! when the station elevation information in the table says missing, -! use the model elevation -! -! print *, "elevstn = ", elevstn(np) - if(elevstn(np)==-999.) elevstn(np) = grids(np,1) - psn(np) = ps(np) - psone = ps(np) - call sigio_modpr(1,1,levs,nvcoord,idvc, - & idsl,vcoord,iret, - & ps=psone*1000,pd=pd3(np,1:levs)) - grids(np,2) = log(psn(np)) - if(np==11)print*,'station H,grud H,psn,ps,new pm', - & elevstn(np),grids(np,1),psn(np),ps(np) - if(np==11)print*,'pd3= ', pd3(np,1:levs) - enddo -! -!! test removing height adjustments - print*, 'do not do height adjustments' -! -! get sea-level pressure (Pa) and layer geopotential height -! - do k = 1, levs - do np = 1, npoint - ttnew(np,k) = grids(np,k+2) - qnew(np,k) = grids(np,k+levs+2) - enddo - enddo - - do np=1,npoint -!! call gslp(levs,elevstn(np),ps(np)*1000, - call gslp(levs,grids(np,1),ps(np)*1000, - & p1(np,1:levs),ttnew(np,1:levs),qnew(np,1:levs), - & pmsl(np),zp(np,1:levs),zp2(1:2)) - enddo - print *, 'call gslp pmsl= ', (pmsl(np),np=1,20) - if(recn_delz == -9999) then - print*, 'using calculated height ' - else - print*, 'using model height m' - do k = 1, levs - do np=1, npoint - zp(np,k) = z1(np,k) - enddo - enddo - endif - print*,'finish computing MSLP' - print*,'finish computing zp ', (zp(11,k),k=1,levs) - print*,'finish computing zp2(11-12) ', zp2(11),zp2(12) -! -! prepare buffer data -! - if(iope == 0) then - do np = 1, npoint - pi3(np,1)=psn(np)*1000 - do k=1,levs - pi3(np,k+1)=pi3(np,k)-pd3(np,k) !layer pressure (Pa) - enddo -!! ==ivalence (cstat1,rstat1) - cstat1=cstat(np) -!! data(1) = ifix(fhour+.2) * 3600 ! FORECAST TIME (SEC) -!! data(2) = istat(np) ! STATION NUMBER -!! data(3) = rstat1 ! STATION CHARACTER ID -!! data(4) = rlat(np) ! LATITUDE (DEG N) -!! data(5) = rlon(np) ! LONGITUDE (DEG E) -!! data(6) = elevstn(np) ! STATION ELEVATION (M) - data2(1) = ifix(fhour+.2) * 3600 ! FORECAST TIME (SEC) - data2(2) = istat(np) ! STATION NUMBER - data2(3) = rstat1 ! STATION CHARACTER ID - data2(4) = rlat(np) ! LATITUDE (DEG N) - data2(5) = rlon(np) ! LONGITUDE (DEG E) - data2(6) = elevstn(np) ! STATION ELEVATION (M) - psfc = 10. * psn(np) ! convert to MB - leveta = 1 - do k = 1, levs - kk= k/2 + 1 -! -! look for the layer above 500 mb for precip type computation -! - if(pi3(np,k).ge.50000.) leveta = k - ppi = pi3(np,k) - t = grids(np,k+2) - q = max(1.e-8,grids(np,2+k+levs)) - u = gridu(np,k) - v = gridv(np,k) -!! data((k-1)*6+7) = p1(np,k) ! PRESSURE (PA) at integer layer -!! data((k-1)*6+8) = t ! TEMPERATURE (K) -!! data((k-1)*6+9) = u ! U WIND (M/S) -!! data((k-1)*6+10) = v ! V WIND (M/S) -!! data((k-1)*6+11) = q ! HUMIDITY (KG/KG) -!! data((k-1)*6+12) = omega(np,k)*100. ! Omega (pa/sec) !changed to dzdt(cm/s) if available - if (mod(k,2)>0) then - data2((kk-1)*6+7) = p1(np,k) - data2((kk-1)*6+8) = t - data2((kk-1)*6+9) = u - data2((kk-1)*6+10) = v - data2((kk-1)*6+11) = q - data2((kk-1)*6+12) = omega(np,k)*100. - endif -!changed to dzdt(cm/s) if available - enddo -! -! process surface flux file fields -! -!! data(8+nflx) = psfc * 100. ! SURFACE PRESSURE (PA) -!! data(7+nflx) = pmsl(np) - data2(8+nflx2) = psfc * 100. ! SURFACE PRESSURE (PA) - data2(7+nflx2) = pmsl(np) -!! dtemp = .0065 * (grids(np,1) - elevstn(np)) -!! dtemp = .0100 * (grids(np,1) - elevstn(np)) -!! sfc(37,np) = data(6+nflx) * .01 -!! sfc(37,np) = data(7+nflx) * .01 -!! sfc(39,np) = zp2(2) !500 hPa height - sfc(37,np) = data2(7+nflx2) * .01 - sfc(39,np) = zp2(2) !500 hPa height -! -! do height correction if there is no snow or if the temp is less than 0 -! G.P.LOU: -! It was decided that no corrctions were needed due to higher model -! resolution. -! -! if(sfc(10,np)==0.) then -! sfc(30,np) = sfc(30,np) + dtemp -! sfc(5,np) = sfc(5,np) + dtemp -! endif -! if(sfc(10,np).gt.0..and.sfc(5,np).lt.273.16) then -! sfc(5,np) = sfc(5,np) + dtemp -! if(sfc(5,np).gt.273.16) then -! dtemp = sfc(5,np) - 273.16 -! sfc(5,np) = 273.16 -! endif -! sfc(30,np) = sfc(30,np) + dtemp -! endif -! -!G.P. Lou 20200501: -!convert instantaneous surface latent heat net flux to surface -!evapolation 1 W m-2 = 0.0864 MJ m-2 day-1 -! and 1 mm day-1 = 2.45 MJ m-2 day-1 -! equivament to 0.0864/2.54 = 0.035265 -! equivament to 2.54/0.0864 = 28.3565 - if(debugprint) - + print*,'evaporation (stn 000692)= ',sfc(17,np) -!! data(9+nflx) = sfc(5,np) ! tsfc (K) -!! data(10+nflx) = sfc(6,np) ! 10cm soil temp (K) -!!! data(11+nflx) = sfc(17,np)/28.3565 ! evaporation (kg/m**2) from (W m-2) -!! data(11+nflx) = sfc(17,np)*0.035265 ! evaporation (kg/m**2) from (W m-2) -!! data(12+nflx) = sfc(12,np) ! total precip (m) -!! data(13+nflx) = sfc(11,np) ! convective precip (m) -!! data(14+nflx) = sfc(10,np) ! water equi. snow (m) -!! data(15+nflx) = sfc(27,np) ! low cloud (%) -!! data(16+nflx) = sfc(26,np) ! mid cloud -!! data(17+nflx) = sfc(25,np) ! high cloud -!! data(18+nflx) = sfc(34,np) ! U10 (m/s) -!! data(19+nflx) = sfc(35,np) ! V10 (m/s) -!! data(20+nflx) = sfc(30,np) ! T2 (K) -!! data(21+nflx) = sfc(31,np) ! Q2 (K) - -!! data(22+nflx) = 0. -!! data(23+nflx) = 0. -!! data(24+nflx) = 0. -!! data(25+nflx) = 0. -!! create 64 level bufr files - data2(9+nflx2) = sfc(5,np) ! tsfc (K) - data2(10+nflx2) = sfc(6,np) ! 10cm soil temp (K) -!! data2(11+nflx2) = sfc(17,np)/28.3565 ! evaporation (kg/m**2) from (W m-2) - data2(11+nflx2) = sfc(17,np)*0.035265 ! evaporation (kg/m**2) from (W m-2) - data2(12+nflx2) = sfc(12,np) ! total precip (m) - data2(13+nflx2) = sfc(11,np) ! convective precip (m) - data2(14+nflx2) = sfc(10,np) ! water equi. snow (m) - data2(15+nflx2) = sfc(27,np) ! low cloud (%) - data2(16+nflx2) = sfc(26,np) ! mid cloud - data2(17+nflx2) = sfc(25,np) ! high cloud - data2(18+nflx2) = sfc(34,np) ! U10 (m/s) - data2(19+nflx2) = sfc(35,np) ! V10 (m/s) - data2(20+nflx2) = sfc(30,np) ! T2 (K) - data2(21+nflx2) = sfc(31,np) ! Q2 (K) - - data2(22+nflx2) = 0. - data2(23+nflx2) = 0. - data2(24+nflx2) = 0. - data2(25+nflx2) = 0. - nd = 0 - trace = .false. - DOMS=0. - DOMR=0. - DOMIP=0. - DOMZR=0. - if(np==1.or.np==2) nd = 1 - if(np==1.or.np==2) trace = .true. - - if(sfc(12,np).gt.0.) then !check for precip then calc precip type - do k = 1, leveta+1 - pp = p1(np,k) - ppi = pi3(np,k) - t = grids(np,k+2) - q = max(0.,grids(np,2+k+levs)) - u = gridu(np,k) - v = gridv(np,k) - if(q.gt.1.e-6.and.pp.ge.20000.) then - call tdew(td,t,q,pp) - call lcl(tlcl,plcl,t,pp,q) - call mstadb(qw,tw,pp,q,tlcl,plcl) - else - td = t - 30. - tw = t - 30. - endif -! Calpreciptype input variables - gt0(1,k)= t - gq0(1,k) = q - prsl(1,k) = pp - prsi(1,k)=ppi - phii(1,k)=zp(np,k) !height in meters - enddo -! Use GFS routine calpreciptype.f to calculate precip type - xlat=rlat(np) - xlon=rlon(np) - lm=leveta - lp1=leveta+1 -!! PREC=data(12+nflx) - PREC=data2(12+nflx2) - n3dfercld=1 !if =3 then use Ferriers Explicit Precip Type - TSKIN=1. !used in Ferriers Explicit Precip Scheme - SR=1. !used in Ferriers Explicit Precip Scheme - iseedl=jdate - call random_setseed(iseedl) - call random_number(randomno) - call calpreciptype(1,1,1,1,lm,lp1,randomno,xlat,xlon, !input - & gt0,gq0,prsl,prsi,PREC,phii,n3dfercld,TSKIN,SR,phy_f3d, !input - & DOMR,DOMZR,DOMIP,DOMS) ! Output vars - endif -!! data(nflx + 22) = DOMS -!! data(nflx + 23) = DOMIP -!! data(nflx + 24) = DOMZR -!! data(nflx + 25) = DOMR - data2(nflx2 + 22) = DOMS - data2(nflx2 + 23) = DOMIP - data2(nflx2 + 24) = DOMZR - data2(nflx2 + 25) = DOMR - if(np==1.or.np==100) then - print *, ' surface fields for hour', nf, 'np =', np - print *, (data2(l+nflx2),l=1,25) - print *, ' temperature sounding' - print 6101, (data2((k-1)*6+8),k=1,levso) - print *, ' omega sounding' - print *, (data2((k-1)*6+12),k=1,levso) - endif -C print *, 'in meteorg nfile1= ', nfile1 -!! write(nfile) data - write(nfile) data2 - enddo !End loop over stations np - endif - call date_and_time(date,time,zone,clocking) -! print *,'13reading write data end= ', clocking - print *,'13date, time, zone',date, time, zone - print *, 'in meteorg nf,nfile,nfhour= ', nf,nfile,nfhour - print *, 'Finished writing bufr data file' - 6101 format(2x,6f12.3) - 6102 format(2x,6f12.5) - 6103 format(2x,6f12.5) -! - close(unit=nfile) - return - 910 print *, ' error reading surface flux file' - end - -!----------------------------------------------------------------------- diff --git a/sorc/gfs_bufr.fd/modstuff1.f b/sorc/gfs_bufr.fd/modstuff1.f deleted file mode 100755 index 95d4138334..0000000000 --- a/sorc/gfs_bufr.fd/modstuff1.f +++ /dev/null @@ -1,75 +0,0 @@ - subroutine modstuff(km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,& - pd,pm,om) -! pd,pi,pm,aps,apm,os,om,px,py) -!$$$ Subprogram documentation block -! -! Subprogram: modstuff Compute model coordinate dependent functions -! Prgmmr: Iredell Org: np23 Date: 1999-10-18 -! -! Abstract: This subprogram computes fields which depend on the model coordinate -! such as pressure thickness and vertical velocity. -! -! Program history log: -! 1999-10-18 Mark Iredell -! -! Usage: call modstuff(km,idvc,idsl,nvcoord,vcoord,ps,psx,psy,d,u,v,& -! pd,pi,pm,aps,apm,os,om,px,py) -! Input argument list: -! km integer number of levels -! idvc integer vertical coordinate id (1 for sigma and 2 for hybrid) -! idsl integer type of sigma structure (1 for phillips or 2 for mean) -! nvcoord integer number of vertical coordinates -! vcoord real (km+1,nvcoord) vertical coordinates -! ps real surface pressure (Pa) -! psx real log surface pressure x-gradient (1/m) -! psy real log surface pressure y-gradient (1/m) -! d real (km) wind divergence (1/s) -! u real (km) x-component wind (m/s) -! v real (km) y-component wind (m/s) -! Output argument list: -! pd real (km) pressure thickness (Pa) -! pi real (km+1) interface pressure (Pa) -! pm real (km) mid-layer pressure (Pa) -! aps real log surface pressure () -! apm real (km+1) log mid-layer pressure () -! os real (km) surface pressure tendency (Pa/s) -! om real (km) vertical velocity (Pa/s) -! px real (km) mid-layer pressure x-gradient (Pa/m) -! py real (km) mid-layer pressure y-gradient (Pa/m) -! -! Attributes: -! Language: Fortran 90 -! -!$$$ - use sigio_module - implicit none - integer,intent(in):: km,idvc,idsl,nvcoord - real,intent(in):: vcoord(km+1,nvcoord) - real,intent(in):: ps,psx,psy - real,intent(in):: u(km),v(km),d(km) - real,intent(out) :: pd(km),pm(km),om(km) - real aps,apm(km),os,pi(km+1),px(km),py(km) - real dpmdps(km),dpddps(km),dpidps(km+1),vgradp - integer k,iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call sigio_modpr(1,1,km,nvcoord,idvc,idsl,vcoord,iret,& - ps=(/ps/),& - pm=pm,pd=pd,dpmdps=dpmdps,dpddps=dpddps) - pi(1)=ps - dpidps(1)=1. - do k=1,km - pi(k+1)=pi(k)-pd(k) - dpidps(k+1)=dpidps(k)-dpddps(k) - enddo - aps=log(ps) - apm=log(pm) - os=0 - do k=km,1,-1 - vgradp=u(k)*psx+v(k)*psy - os=os-vgradp*ps*(dpmdps(k)-dpidps(k+1))-d(k)*(pm(k)-pi(k+1)) - om(k)=vgradp*ps*dpmdps(k)+os - os=os-vgradp*ps*(dpidps(k)-dpmdps(k))-d(k)*(pi(k)-pm(k)) - enddo - px=ps*dpmdps*psx - py=ps*dpmdps*psy - end subroutine diff --git a/sorc/gfs_bufr.fd/mstadb.f b/sorc/gfs_bufr.fd/mstadb.f deleted file mode 100755 index e9b01e09c6..0000000000 --- a/sorc/gfs_bufr.fd/mstadb.f +++ /dev/null @@ -1,49 +0,0 @@ - SUBROUTINE MSTADB(Q2,T2,P2,Q1,T1,P1) -C -C THIS ROUTINE PROVIDES T2 AND QSAT AT T2 AT PRESSUE P2 THAT -C GIVES THE SAME EQUIVALENT POTENTIAL TEMPERATURE AS THE POINT -C ( T1, P1). FOR EASE OF COMPUTATION, Q1 IS REQUESTED -C - REAL L0, KAPPA - parameter (dtdp=4.5e-4,kappa=.286,g=9.81) - parameter (cp=1004.6,cl=4185.5,cpv=1846.0) - parameter (rv=461.5,l0=2.500e6,t0=273.16,es0=610.78) - parameter (cps=2106.0,hfus=3.3358e5,rd=287.05) - parameter (fact1=(CPV - CL) / RV,fact1i=(cps-cl)/rv) - parameter (fact2=(L0 + (CL - CPV) * T0) / RV) - parameter (fact2i=(L0 + hfus + (CL - cps) * T0) / RV) - parameter (fact3=1. / T0,eps=rd/rv,tmix=t0-20.) - FUNC(QS,T) = EXP(L0 * QS / (CP * T)) - DESDT(ES,T) = ES * (FACT1 / T + FACT2 / T ** 2) - DESDTi(ES,T) = ES * (FACT1i / T + FACT2i / T ** 2) -C FIRST GUESS OF T2 - T2 = T1 + DTDP * (P2 - P1) - PFACT = (1.E5 / P2) ** KAPPA - CONST = T1 * (1.E5 / P1) ** KAPPA * FUNC(Q1,T1) - ITER = 0 -C ITERATION STARTS - 10 CALL SVP(Q2,E2,P2,T2) - FACT4 = FUNC(Q2,T2) - F = T2 * PFACT * FACT4 - CONST - if(t2.ge.t0) then - desdt2 = desdt(e2,t2) - elseif(t2.lt.tmix) then - desdt2 = desdti(e2,t2) - else - w = (t2 - tmix) / (t0 - tmix) - desdt2 = w * desdt(e2,t2) + (1.-w) * desdti(e2,t2) - endif - DQSDT = (Q2 / E2) * (P2 / (P2 - (1.-EPS) * E2)) * DESDT2 - DFDT = PFACT * FACT4 + PFACT * FACT4 * (L0 * DQSDT / CP - & - L0 * Q2 / (CP * T2)) - DT = - F / DFDT - T2 = T2 + DT - IF(ABS(DT).LT..1) GOTO 100 - ITER = ITER + 1 - IF(ITER.LT.50) GOTO 10 - WRITE(6,*) ' MSTADB ITERATION DIVERGED, PROGRAM STOPPED' - STOP 'ABEND 240' - 100 CONTINUE - CALL SVP(Q2,E2,P2,T2) - RETURN - END diff --git a/sorc/gfs_bufr.fd/newsig1.f b/sorc/gfs_bufr.fd/newsig1.f deleted file mode 100755 index 2b0b9ccb99..0000000000 --- a/sorc/gfs_bufr.fd/newsig1.f +++ /dev/null @@ -1,65 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE NEWSIG(NSIL,IDVC,LEVS,NVCOORD,VCOORD,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NEWSIG GET NEW SIGMA STRUCTURE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-04-03 -C -C ABSTRACT: READ IN INTERFACE SIGMA VALUES (OR USE OLD VALUES) -C AND COMPUTE FULL SIGMA VALUES. - -C PROGRAM HISTORY LOG: -C 98-04-03 IREDELL -C -C USAGE: CALL NEWSIG(NSIL,IDVC,LEVS,NVCOORD,VCOORD,IRET) -C INPUT ARGUMENTS: -C NSIL INTEGER UNIT NUMBER OF NEW SIGMA INTERFACE VALUES -C IDVC INTEGER VERTICAL COORDINATE ID -C LEVS INTEGER NEW NUMBER OF LEVELS -C NVCOORD INTEGER NEW NUMBER OF VERTICAL COORDINATES -C OUTPUT ARGUMENTS: -C VCOORD REAL (LEVS+1,NVCOORD) NEW VERTICAL COORDINATES -C IRET INTEGER RETURN CODE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN -C -C$$$ - REAL VCOORD(LEVS+1,NVCOORD) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ VERTICAL COORDINATES - READ(NSIL,*,IOSTAT=IRET) IDVCI,LEVSI,NVCOORDI - IF(IRET.EQ.0) THEN -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - READ(NSIL,*,IOSTAT=IRET) ((VCOORD(K,N),N=1,NVCOORD),K=1,LEVS+1) - IF(IRET.NE.0) RETURN - IF(IDVCI.NE.IDVC.OR.LEVSI.NE.LEVS) IRET=28 - IF(NVCOORDI.NE.NVCOORD) IRET=28 - IF(IRET.NE.0) RETURN -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ INTERFACE HYBRID VALUES - ELSE - REWIND NSIL - READ(NSIL,*,IOSTAT=IRET) IDVCI - REWIND NSIL - IF(IRET.EQ.0.AND.(IDVCI.EQ.2.OR.IDVCI.EQ.3)) THEN - READ(NSIL,*,IOSTAT=IRET) IDVCI,LEVSI - READ(NSIL,*,IOSTAT=IRET) (VCOORD(K,1),VCOORD(K,2),K=1,LEVS+1) - IF(IRET.NE.0) RETURN - IF(IDVCI.NE.IDVC.OR.LEVSI.NE.LEVS) IRET=28 - IF(IRET.NE.0) RETURN -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ INTERFACE SIGMA VALUES - ELSE - VCOORD(1,1)=1. - VCOORD(LEVS+1,1)=0. - READ(NSIL,*,IOSTAT=IRET) LEVSI - READ(NSIL,*,IOSTAT=IRET) (VCOORD(K,1),K=2,LEVS) - IF(IRET.NE.0) RETURN - IF(LEVSI.NE.LEVS) IRET=28 - IF(IRET.NE.0) RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ENDIF - IRET=0 - END diff --git a/sorc/gfs_bufr.fd/physcons.f b/sorc/gfs_bufr.fd/physcons.f deleted file mode 100755 index 03a0a8001d..0000000000 --- a/sorc/gfs_bufr.fd/physcons.f +++ /dev/null @@ -1,40 +0,0 @@ -module physcons - use machine,only:kind_phys -! Physical constants as set in NMC handbook from Smithsonian tables. -! Physical constants are given to 5 places. -! 1990/04/30: g and rd are made consistent with NWS usage. -! 2001/10/22: g made consistent with SI usage. -! Math constants - real(kind=kind_phys),parameter:: con_pi =3.141593e+0 ! pi - real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0 ! square root of 2 - real(kind=kind_phys),parameter:: con_sqrt3 =1.732051e+0 ! square root of 3 -! Primary constants - real(kind=kind_phys),parameter:: con_rerth =6.3712e+6 ! radius of earth (m) - real(kind=kind_phys),parameter:: con_g =9.80665e+0! gravity (m/s2) - real(kind=kind_phys),parameter:: con_omega =7.2921e-5 ! ang vel of earth (1/s) - real(kind=kind_phys),parameter:: con_rd =2.8705e+2 ! gas constant air (J/kg/K) - real(kind=kind_phys),parameter:: con_rv =4.6150e+2 ! gas constant H2O (J/kg/K) - real(kind=kind_phys),parameter:: con_cp =1.0046e+3 ! spec heat air @p (J/kg/K) - real(kind=kind_phys),parameter:: con_cv =7.1760e+2 ! spec heat air @v (J/kg/K) - real(kind=kind_phys),parameter:: con_cvap =1.8460e+3 ! spec heat H2O gas (J/kg/K) - real(kind=kind_phys),parameter:: con_cliq =4.1855e+3 ! spec heat H2O liq (J/kg/K) - real(kind=kind_phys),parameter:: con_csol =2.1060e+3 ! spec heat H2O ice (J/kg/K) - real(kind=kind_phys),parameter:: con_hvap =2.5000e+6 ! lat heat H2O cond (J/kg) - real(kind=kind_phys),parameter:: con_hfus =3.3358e+5 ! lat heat H2O fusion (J/kg) - real(kind=kind_phys),parameter:: con_psat =6.1078e+2 ! pres at H2O 3pt (Pa) - real(kind=kind_phys),parameter:: con_sbc =5.6730e-8 ! stefan-boltzmann (W/m2/K4) - real(kind=kind_phys),parameter:: con_solr =1.3533e+3 ! solar constant (W/m2) - real(kind=kind_phys),parameter:: con_t0c =2.7315e+2 ! temp at 0C (K) - real(kind=kind_phys),parameter:: con_ttp =2.7316e+2 ! temp at H2O 3pt (K) - real(kind=kind_phys),parameter:: con_epsq =1.0E-12 ! min q for computing precip type -! Secondary constants - real(kind=kind_phys),parameter:: con_rocp =con_rd/con_cp - real(kind=kind_phys),parameter:: con_cpor =con_cp/con_rd - real(kind=kind_phys),parameter:: con_rog =con_rd/con_g - real(kind=kind_phys),parameter:: con_fvirt =con_rv/con_rd-1. - real(kind=kind_phys),parameter:: con_eps =con_rd/con_rv - real(kind=kind_phys),parameter:: con_epsm1 =con_rd/con_rv-1. - real(kind=kind_phys),parameter:: con_dldt =con_cvap-con_cliq - real(kind=kind_phys),parameter:: con_xpona =-con_dldt/con_rv - real(kind=kind_phys),parameter:: con_xponb =-con_dldt/con_rv+con_hvap/(con_rv*con_ttp) -end module diff --git a/sorc/gfs_bufr.fd/read_nemsio.f b/sorc/gfs_bufr.fd/read_nemsio.f deleted file mode 100644 index d1262e7974..0000000000 --- a/sorc/gfs_bufr.fd/read_nemsio.f +++ /dev/null @@ -1,55 +0,0 @@ - subroutine read_nemsio(gfile,im,jm,levs, - & VarName,LayName,Varout,iret) -!! This subroutine reads either 2d or 3d nemsio data -!! 12/12/2019 Guang Ping Lou - - use nemsio_module - implicit none - include 'mpif.h' - type(nemsio_gfile) :: gfile - character(len=20) :: VarName,LayName - integer,intent(in) :: im,jm,levs - real,intent(out) :: Varout(im,jm,levs) - real,dimension(im*jm) :: dum1d - integer :: iret,i,j,k,jj - - print*,'read_nemsio,im,jm,levs' - print*, im,jm,levs - print*,'VarName=',trim(VarName) - print*,'LayName=',trim(LayName) - if(levs > 1) then - do k =1, levs - call nemsio_readrecvw34(gfile,trim(VarName), - & trim(LayName),k,data=dum1d,iret=iret) - !print*,"VarName,k= ",trim(VarName), k - if (iret /= 0) then - print*,trim(VarName)," not found" - else - do j=1,jm - jj= (j-1)*im - do i=1,im - Varout(i,j,k) = dum1d(jj+i) - end do - end do - end if - enddo - - else - call nemsio_readrecvw34(gfile,trim(VarName), - & trim(LayName),1,data=dum1d,iret=iret) - !print*,"VarName= ",trim(VarName) - if (iret /= 0) then - print*,trim(VarName)," not found" - else - do j=1,jm - jj= (j-1)*im - do i=1,im - Varout(i,j,1) = dum1d(jj+i) - end do - end do - endif - - end if - - end subroutine read_nemsio - diff --git a/sorc/gfs_bufr.fd/read_netcdf.f b/sorc/gfs_bufr.fd/read_netcdf.f deleted file mode 100644 index a024323b31..0000000000 --- a/sorc/gfs_bufr.fd/read_netcdf.f +++ /dev/null @@ -1,55 +0,0 @@ - subroutine read_netcdf(ncid,im,jm,levs, - & VarName,Varout,Zreverse,iret) -!! This subroutine reads either 2d or 3d NetCDF data -!! 12/12/2019 Guang Ping Lou - - use netcdf - implicit none - include 'mpif.h' - character(len=20),intent(in) :: VarName - character(len=3),intent(in) :: Zreverse - integer,intent(in) :: ncid,im,jm,levs - real,intent(out) :: Varout(im,jm,levs) - real :: dummy3d(im,jm,levs) - integer :: iret,i,j,k,id_var,kk - - if(levs > 1) then - iret = nf90_inq_varid(ncid,trim(VarName),id_var) - !print*,stat,varname,id_var - iret = nf90_get_var(ncid,id_var,dummy3d) - if (iret /= 0) then - print*,VarName," not found" - else -!For FV3GFS NetCDF output, vertical layers need to be reversed - if(Zreverse == "yes" ) then - do k = 1, levs - kk=levs-k+1 - do j=1, jm - do i=1, im - Varout(i,j,k) = dummy3d(i,j,kk) - enddo - enddo - enddo - else - do k = 1, levs - do j=1, jm - do i=1, im - Varout(i,j,k) = dummy3d(i,j,k) - enddo - enddo - enddo - endif - endif - - else - iret = nf90_inq_varid(ncid,trim(VarName),id_var) - !print*,stat,varname,id_var - iret = nf90_get_var(ncid,id_var,Varout(:,:,1)) - if (iret /= 0) then - print*,VarName," not found" - endif - - end if - - end subroutine read_netcdf - diff --git a/sorc/gfs_bufr.fd/read_netcdf_p.f b/sorc/gfs_bufr.fd/read_netcdf_p.f deleted file mode 100644 index 4bfa8507be..0000000000 --- a/sorc/gfs_bufr.fd/read_netcdf_p.f +++ /dev/null @@ -1,113 +0,0 @@ - subroutine read_netcdf_p(ncid,im,jm,levs, - & VarName,Varout,Zreverse,iope,ionproc, - & iocomms,iret) -!! This subroutine reads either 2d or 3d NetCDF data in parallel -!! 02/08/2020 Guang Ping Lou - - use netcdf - use mpi - implicit none -!! include 'mpif.h' - character(len=20),intent(in) :: VarName - character(len=3),intent(in) :: Zreverse - integer,intent(in) :: ncid,im,jm,levs - real,intent(out) :: Varout(im,jm,levs) - real :: dummy3d(im,jm,levs) - integer :: iret,i,j,k,id_var,kk - integer :: iope,ionproc,iocomms - integer :: chunksize,ionproc1 - real, allocatable :: dummy(:,:,:) - integer start(3), count(3) - integer nskip - integer, allocatable :: starts(:) - integer, allocatable :: counts(:) - integer, allocatable :: chunksizes(:) - integer, allocatable :: rdispls(:) - integer, allocatable :: ii(:) - - if(levs > 1) then - nskip = int(levs/ionproc) + 1 - k=ionproc*nskip - if(k > levs) then - kk=(k-levs)/nskip - ionproc1=ionproc - kk - else - ionproc1=ionproc - endif - iret = nf90_inq_varid(ncid,trim(VarName),id_var) - allocate(starts(ionproc1), counts(ionproc1),ii(ionproc1)) - allocate(chunksizes(ionproc1)) - allocate(rdispls(ionproc1)) - print*,'ionproc,ionproc1,nskip= ',ionproc,ionproc1, nskip - print*,'trim(VarName)in read= ',trim(VarName) - starts(1) = 1 - ii(1) = 1 - do i = 2, ionproc1 - starts(i) = 1 + (i-1)*nskip - ii(i)= ii(i-1) + 1 - end do - do i=1, ionproc1 - 1 - counts(i) = starts(i+1) - starts(i) - end do - counts(ionproc1) = levs - starts(ionproc1)+1 - print*,'starts= ',starts - print*, 'counts= ', counts - k=ii(iope+1) - start = (/1,1,starts(k)/) - count = (/im,jm,counts(k)/) - chunksizes(:) = im * jm * counts(:) - rdispls(:) = im * jm * (starts(:)-1) - print*, 'iope,k,start,count= ',iope,k,start(3),count(3) - print*, 'chunksizes= ', chunksizes - print*, 'rdispls= ', rdispls - allocate (dummy(im,jm,count(3))) - iret=nf90_get_var(ncid,id_var,dummy, - & start=start,count=count) - if (iret /= 0) then - print*,VarName," not found" - endif - print*,'start(3),st(3):cnt(3)-1=',start(3),(start(3)+count(3)-1) - print*,'dummy(im/2,jm/2,:)= ', dummy(im/2,jm/2,:) - call mpi_allgatherv(dummy,chunksizes(k),mpi_real,dummy3d, - & chunksizes, rdispls, mpi_real, iocomms, iret) - print*,'VarName= ', VarName - print*,'dummy3d(im/2,jm/2,:)= ', dummy3d(im/2,jm/2,:) -!! call mpi_alltoallv(dummy, chunksizes, sdispls, mpi_real, dummy3d, -!! & chunksizes, rdispls, mpi_real, iocomms, iret) - -! enddo -!For FV3GFS NetCDF output, vertical layers need to be reversed - if(Zreverse == "yes" ) then - do k = 1, levs - kk=levs-k+1 - do j=1, jm - do i=1, im - Varout(i,j,k) = dummy3d(i,j,kk) - enddo - enddo - enddo - else - do k = 1, levs - do j=1, jm - do i=1, im - Varout(i,j,k) = dummy3d(i,j,k) - enddo - enddo - enddo - endif - deallocate(starts, counts,ii) - deallocate(chunksizes) - deallocate(rdispls) - deallocate (dummy) - - else - iret = nf90_inq_varid(ncid,trim(VarName),id_var) - print*,'trim(VarName)in read= ',trim(VarName) - iret = nf90_get_var(ncid,id_var,Varout(:,:,1)) - if (iret /= 0) then - print*,VarName," not found" - endif - - end if - end subroutine read_netcdf_p - diff --git a/sorc/gfs_bufr.fd/rsearch.f b/sorc/gfs_bufr.fd/rsearch.f deleted file mode 100755 index 73141facf5..0000000000 --- a/sorc/gfs_bufr.fd/rsearch.f +++ /dev/null @@ -1,145 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2, - & L2) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RSEARCH SEARCH FOR A SURROUNDING REAL INTERVAL -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-05-01 -C -C ABSTRACT: THIS SUBPROGRAM SEARCHES MONOTONIC SEQUENCES OF REAL NUMBERS -C FOR INTERVALS THAT SURROUND A GIVEN SEARCH SET OF REAL NUMBERS. -C THE SEQUENCES MAY BE MONOTONIC IN EITHER DIRECTION; THE REAL NUMBERS -C MAY BE SINGLE OR DOUBLE PRECISION; THE INPUT SEQUENCES AND SETS -C AND THE OUTPUT LOCATIONS MAY BE ARBITRARILY DIMENSIONED. -C -C PROGRAM HISTORY LOG: -C 1999-01-05 MARK IREDELL -C -C USAGE: CALL RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2, -C & L2) -C INPUT ARGUMENT LIST: -C IM INTEGER NUMBER OF SEQUENCES TO SEARCH -C KM1 INTEGER NUMBER OF POINTS IN EACH SEQUENCE -C IXZ1 INTEGER SEQUENCE SKIP NUMBER FOR Z1 -C KXZ1 INTEGER POINT SKIP NUMBER FOR Z1 -C Z1 REAL (1+(IM-1)*IXZ1+(KM1-1)*KXZ1) -C SEQUENCE VALUES TO SEARCH -C (Z1 MUST BE MONOTONIC IN EITHER DIRECTION) -C KM2 INTEGER NUMBER OF POINTS TO SEARCH FOR -C IN EACH RESPECTIVE SEQUENCE -C IXZ2 INTEGER SEQUENCE SKIP NUMBER FOR Z2 -C KXZ2 INTEGER POINT SKIP NUMBER FOR Z2 -C Z2 REAL (1+(IM-1)*IXZ2+(KM2-1)*KXZ2) -C SET OF VALUES TO SEARCH FOR -C (Z2 NEED NOT BE MONOTONIC) -C IXL2 INTEGER SEQUENCE SKIP NUMBER FOR L2 -C KXL2 INTEGER POINT SKIP NUMBER FOR L2 -C -C OUTPUT ARGUMENT LIST: -C L2 INTEGER (1+(IM-1)*IXL2+(KM2-1)*KXL2) -C INTERVAL LOCATIONS HAVING VALUES FROM 0 TO KM1 -C (Z2 WILL BE BETWEEN Z1(L2) AND Z1(L2+1)) -C -C SUBPROGRAMS CALLED: -C SBSRCH ESSL BINARY SEARCH -C DBSRCH ESSL BINARY SEARCH -C -C REMARKS: -C IF THE ARRAY Z1 IS DIMENSIONED (IM,KM1), THEN THE SKIP NUMBERS ARE -C IXZ1=1 AND KXZ1=IM; IF IT IS DIMENSIONED (KM1,IM), THEN THE SKIP -C NUMBERS ARE IXZ1=KM1 AND KXZ1=1; IF IT IS DIMENSIONED (IM,JM,KM1), -C THEN THE SKIP NUMBERS ARE IXZ1=1 AND KXZ1=IM*JM; ETCETERA. -C SIMILAR EXAMPLES APPLY TO THE SKIP NUMBERS FOR Z2 AND L2. -C -C RETURNED VALUES OF 0 OR KM1 INDICATE THAT THE GIVEN SEARCH VALUE -C IS OUTSIDE THE RANGE OF THE SEQUENCE. -C -C IF A SEARCH VALUE IS IDENTICAL TO ONE OF THE SEQUENCE VALUES -C THEN THE LOCATION RETURNED POINTS TO THE IDENTICAL VALUE. -C IF THE SEQUENCE IS NOT STRICTLY MONOTONIC AND A SEARCH VALUE IS -C IDENTICAL TO MORE THAN ONE OF THE SEQUENCE VALUES, THEN THE -C LOCATION RETURNED MAY POINT TO ANY OF THE IDENTICAL VALUES. -C -C TO BE EXACT, FOR EACH I FROM 1 TO IM AND FOR EACH K FROM 1 TO KM2, -C Z=Z2(1+(I-1)*IXZ2+(K-1)*KXZ2) IS THE SEARCH VALUE AND -C L=L2(1+(I-1)*IXL2+(K-1)*KXL2) IS THE LOCATION RETURNED. -C IF L=0, THEN Z IS LESS THAN THE START POINT Z1(1+(I-1)*IXZ1) -C FOR ASCENDING SEQUENCES (OR GREATER THAN FOR DESCENDING SEQUENCES). -C IF L=KM1, THEN Z IS GREATER THAN OR EQUAL TO THE END POINT -C Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1) FOR ASCENDING SEQUENCES -C (OR LESS THAN OR EQUAL TO FOR DESCENDING SEQUENCES). -C OTHERWISE Z IS BETWEEN THE VALUES Z1(1+(I-1)*IXZ1+(L-1)*KXZ1) AND -C Z1(1+(I-1)*IXZ1+(L-0)*KXZ1) AND MAY EQUAL THE FORMER. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: IM,KM1,IXZ1,KXZ1,KM2,IXZ2,KXZ2,IXL2,KXL2 - REAL,INTENT(IN):: Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) - REAL,INTENT(IN):: Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) - INTEGER,INTENT(OUT):: L2(1+(IM-1)*IXL2+(KM2-1)*KXL2) - INTEGER(4) INCX,N,INCY,M,INDX(KM2),RC(KM2),IOPT - INTEGER I,K1,K2,CT -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. - print*, IM,KM1,KM2,INCX,INCY - DO I=1,IM - IF(Z1(1+(I-1)*IXZ1).LE.Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1)) THEN -C INPUT COORDINATE IS MONOTONICALLY ASCENDING. - INCX=KXZ2 - N=KM2 - INCY=KXZ1 - M=KM1 - IOPT=1 -! IF(DIGITS(1.).LT.DIGITS(1._8)) THEN -! CALL SBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ELSE -! CALL DBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ENDIF -! DO K2=1,KM2 -! L2(1+(I-1)*IXL2+(K2-1)*KXL2)=INDX(K2)-RC(K2) -! ENDDO - DO K2=1,KM2 - L2(K2)=KM1 - DO K1=(1+(I-1)*IXZ1),(1+(I-1)*IXZ1+(KM1-1)*KXZ1)-1 - IF(Z1(K1)>=Z2(K2).AND.Z1(K1+1)>Z2(K2)) THEN - L2(K2)=K1 - EXIT - ENDIF - ENDDO - ENDDO - ELSE -C INPUT COORDINATE IS MONOTONICALLY DESCENDING. - INCX=KXZ2 - N=KM2 - INCY=-KXZ1 - M=KM1 - IOPT=0 -! IF(DIGITS(1.).LT.DIGITS(1._8)) THEN -! CALL SBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ELSE -! CALL DBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ENDIF -! DO K2=1,KM2 -! L2(1+(I-1)*IXL2+(K2-1)*KXL2)=KM1+1-INDX(K2) -! ENDDO - DO K2=1,KM2 - L2(K2)=KM1 - CT=0 - DO K1=(1+(I-1)*IXZ1+(KM1-1)*KXZ1),(1+(I-1)*IXZ1)+1,-1 - CT=CT+1 - IF(Z2(K2)<=Z1(K1).AND.Z2(K2) 1.0) then - print *,'Warning: aice_h>1:',aice_h(i,j) - aice_h(i,j)=1.0 - endif - fi(i,j)=aice_h(i,j) - else - fi(i,j)=0.0 - endif - fw=1.0-fi(i,j) - ts_h(i,j)=fw(i,j)*sst_h(i,j)+fi(i,j)*Tsfc_h(i,j) - enddo - enddo - - - return - end subroutine read_ice - - subroutine diag(im,jm,km,icefile,ocnfile, & - isyr,ismth,isday,ishr,iyr,imth,iday,ihr,mfh,mfhout, & - flonw,flone,dlon,flatn,flats,dlat,imo,jmo, & - outfile,mfcstcpl,igenocnp) - - integer nvar,ko,ki,kk,ndtc,mfcstcpl,igenocnp -! integer mkmoc,nreg - real hfc - - parameter(nvar=37,ko=40,ki=5) - parameter(ndtc=7) -! - character*300 cicefile,icefile,ocnfile,outfile -! character*120 mocfile - character*120 template_file,template_inv,metadata,template_var - character*10 datecode - character*4 level4 - character*8 hr8 - character*80 levelm(nvar) - character*80 levelcode,ftime - character*5 varcode(nvar) - - integer im,jm,km - integer imo,jmo - integer iyr,imth,iday,ihr,mfh,mfhout - integer isyr,ismth,isday,ishr - integer hrdif - integer isdate(8),iedate(8) - real dlat,dlon,flats,flatn,flonw,flone -! real tripolat,dtripolat -! integer jtripolat - real factor,undef,spv_ci,spv_pme,spv_tau,val - integer i,j,k,ierr,ilev,ind,iret,nv,ndata,nr,nundef,kreg - integer nx,ny - real datedif(5) -! - real*8, dimension(im,jm) :: hi,hs,ts,t1,t2,fi,alb,ui,vi,sst,saltf -! - real, dimension(im,jm) :: hi_ci,hs_ci,ts_ci,fi_ci,ui_ci,vi_ci -! - real, dimension(im,jm,km) :: t,s,u,v,w,vv -! real, dimension(im,jm,km) :: dckt,dcks,vfc - real, dimension(im,jm) :: eta,sfcflx,pme,mld,taux,tauy,uice,vice - real, dimension(im,jm) :: sss,ssu,ssv,speed,sensible,latent,sw,lw - real, dimension(im,jm) :: lprec,evap - real, dimension(im,jm) :: varice - real, dimension(im) :: lon - real, dimension(jm) :: lat -! - real, dimension(imo,jmo) :: grid,grdtmp,varsfc - real, dimension(imo,jmo,km) :: varocn,tocn,socn - - real zt(ko) - real zw(ko) - real dtc(ndtc) - real grid2(imo*jmo) -! - real, dimension(nvar) :: fac - integer, dimension(nvar) :: kpds5,kpds6,kpds7,kpds22 - integer, dimension(ko) :: levs - - integer, parameter :: kpds_dim=200 - integer, dimension(kpds_dim) :: KPDS,KGDS,JPDS,JGDS - logical*1 lbms(imo,jmo) - logical :: climate = .false. -! new wgrib2api requires this - integer, parameter :: regex=1 -! - data dtc/2.5,5.,10.,15.,20.,25.,28./ -! -! NV kpds5=Variable (Parameter Table) -! http://www.nco.ncep.noaa.gov/pmb/docs/on388/table2.html#TABLE128 -! -! 1. 13=Potential temperature (2) -! 2. 88=Salinity (2) -! 3. 49=u-component of current (2) -! 4. 50=v-component of current (2) -! 5. 40=Geometric Vertical velocity (2) -! 6. 124=Momentum flux, u component (2) -! 7. 125=Momentum flux, v component (2) -! 8. 198=Sea Surface Height Relative to Geoid (129) -! 9. 91=Ice concentration (2) -! 10. 92=Ice thickness (2) -! 11. 66=Snow depth (2) -! 12. 11=Surface Temperature over Water and Ice(2) -! 13. 95=u-component of ice drift (2) -! 14. 96=v-component of ice drift (2) -! 15. 188=Evaporation - Precipitation (2) -! 16. 202=Total downward heat flux at surface (downward is positive) (129) -! 17. 195=Geometric Depth Below Sea Surface (129) -! 18. 195=Geometric Depth Below Sea Surface (129) -! 19. 197=Ocean Heat Content (129) -! 20. 194=Tropical Cyclone Heat Potential (129) -! 21. 195=Geometric Depth Below Sea Surface for the 2.5C isotherm (129) -! 22. 195=Geometric Depth Below Sea Surface for the 5C isotherm (129) -! 23. 195=Geometric Depth Below Sea Surface for the 10C isotherm (129) -! 24. 195=Geometric Depth Below Sea Surface for the 15C isotherm (129) -! 25. 195=Geometric Depth Below Sea Surface for the 20C isotherm (129) -! 26. 195=Geometric Depth Below Sea Surface for the 25C isotherm (129) -! 27. 195=Geometric Depth Below Sea Surface for the 28C isotherm (129) -! 28. 88=Sea Surface Salinity (2) -! 29. 49=Sea Surface u-current (2) -! 30. 50=Sea Surface v-current (2) -! 31. 32=Sea Surface speed (2) -! 32. 122=Sensible Heat (2) -! 33. 121=Latent Heat (2) -! 34. 111=Net surface Downward Short Wave flux (2) -! 35. 112=Net surface Downward Long Wave flux (2) -! 36. 59=Precipitation (2) -! 37. 57=Evaporation (2) -! - data kpds5/ 13, 88, 49, 50, 40,124,125,198, 91, 92, & - 66, 11, 95, 96,188,202,195,195,197,194, & - 195,195,195,195,195,195,195, 88, 49, 50, & - 32,122,121,111,112, 59, 57/ - - data kpds6/ 160,160,160,160,160, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1,237,238,236,239, & - 235,235,235,235,235,235,235, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1/ - - data kpds7/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0, 0, 30,260, & - 25, 50,100,150,200,250,280, 0, 0, 0, & - 0, 0, 0, 0, 0, 0, 0/ -!------------------------------------------------------------------- -! Xingren: check why fac=273.15 for Ice temperature -! check why fac=-8.64e6 for evap minus precip -!------------------------------------------------------------------- - data fac/ 0.0, 0.001,1.0,1.0, 1.0, 1.0, 1.0,1.0,1.0,1.0, & - 1.0,273.15,1.0,1.0,-8.64e3, 1.0, 1.0,1.0,1.0,1.0, & - 1.0, 1.0,1.0,1.0, 1.0, 1.0, 1.0,1.0,1.0,1.0, & - 1.0, 1.0,1.0,1.0, 1.0, 1.0, 1.0/ - - data kpds22/ 2, 5, 3, 3, 9, 3, 3, 3, 3, 2, & - 3, 2, 3, 3, 3, 3, 0, 0, -5, -4, & - 0, 0, 0, 0, 0, 0, 0, 5, 3, 3, & - 0, 0, 0, 0, 0, 3, 3/ -! - data levs/ 5, 15, 25, 35, 45, 55, 65, 75, & - 85, 95, 105, 115, 125, 135, 145, 155, & - 165, 175, 185, 195, 205, 215, 225, 238, & - 262, 303, 366, 459, 584, 747, 949,1193, & - 1479,1807,2174,2579,3016,3483,3972,4478/ -! - data spv_tau/-1.0E+5/ - data spv_ci/1.0E+29/ - data spv_pme/-1.0E+10/ - data undef/-1.0E+34/ -! - data zt/ 5., 15., 25., 35., 45., 55., 65., 75., & - 85., 95., 105., 115., 125., 135., 145., 155., & - 165., 175., 185., 195., 205., 215., 225., 238., & - 262., 303., 366., 459., 584., 747., 949.,1193., & - 1479.,1807.,2174.,2579.,3016.,3483.,3972.,4478./ -! - data zw/ 10., 20., 30., 40., 50., 60., 70., 80., & - 90., 100., 110., 120., 130., 140., 150., 160., & - 170., 180., 190., 200., 210., 220., 232., 250., & - 283., 335., 413., 522., 666., 848.,1072.,1337., & - 1643.,1991.,2377.,2798.,3250.,3728.,4225.,4737./ -! - data levelm/' m below sea level', ' m below sea level', & - ' m below sea level', ' m below sea level', & - ' m below sea level', & - 'surface', 'surface', 'surface', 'surface', & - 'surface', 'surface', 'surface', 'surface', & - 'surface', 'surface', 'surface', & - 'bottom of ocean mixed layer', & - 'bottom of ocean isothermal layer', & - '0-300 m ocean layer', & - 'layer ocean surface and 26C ocean isothermal level', & - '2.5C ocean isotherm', & - '5C ocean isotherm', & - '10C ocean isotherm', & - '15C ocean isotherm', & - '20C ocean isotherm', & - '25C ocean isotherm', & - '28C ocean isotherm', & - 'surface', & - 'surface', & - 'surface', & - 'surface', & - 'surface', & - 'surface', & - 'surface', & - 'surface', & - 'surface', & - 'surface'/ - - data varcode/'POT', 'SALTY', 'UOGRD', 'VOGRD', 'DZDT', & - 'UFLX', 'VFLX', 'SSHG', 'ICEC', 'ICETK', & - 'SNOD', 'TMP', 'UICE', 'VICE', 'EMNP', & - 'THFLX', 'DBSS', 'DBSS', 'OHC', 'TCHP', & - 'DBSS', 'DBSS', 'DBSS', 'DBSS', 'DBSS', & - 'DBSS', 'DBSS', & - 'SALTY', 'UOGRD', 'VOGRD','SPEED','SHTFL', & - 'LHTFL', 'NSWRS', 'NLWRS','PRATE','EVP'/ -! - template_file = 'iceocnpost.g2' - template_inv = '@mem:0' - -! find grid size to make sure - iret = grb2_mk_inv(template_file, template_inv) - if (iret.ne.0) stop 1 - -! search using variable and regular date YYYYMMDDHH - template_var = '^1:' -! Based on Wesley's suggestion -! iret = grb2_inq(template_file,template_inv,template_var,nx=nx,ny=ny) - iret = grb2_inq(template_file,template_inv,template_var,nx=nx,ny=ny,regex=regex) - if (iret.ne.1) then - if (iret.eq.0) write(*,*) 'could not find message' - if (iret.gt.1) write(*,*) 'found multiple messages ', iret - stop 2 - endif - -! - if (mfcstcpl.eq.1) climate = .true. -! - print *,'im = ',im - print *,'jm = ',jm - print *,'km = ',km - - print *,'imo = ',imo - print *,'jmo = ',jmo - - print *,'IGEN_OCNP = ',igenocnp - print *,'mfcstcpl = ',mfcstcpl - print *,'climate = ',climate - - isdate=0 - isdate(1)=isyr - isdate(2)=ismth - isdate(3)=isday - isdate(5)=ishr - print *,'isdate ',isdate - - iedate=0 - iedate(1)=iyr - iedate(2)=imth - iedate(3)=iday - iedate(5)=ihr - - call w3difdat(iedate,isdate,2,datedif) - hrdif=datedif(2) - write(hr8,'(i8)') hrdif -! print *,'datedif',datedif - print *,'hrdif',hrdif - - write(datecode,'(i4.4,i2.2,i2.2,i2.2)') isyr, ismth, isday, ishr - print*, 'datecode=',datecode - - call read_ocn(im,jm,km,lon,lat, & - t,s,u,v,eta,sfcflx,pme,mld,taux,tauy,ocnfile, & - sss,ssu,ssv,speed,sensible,latent,sw,lw,lprec,evap) - print *,'after call read_ocn' - call read_ice(im,jm,hi_ci,hs_ci,fi_ci,ts_ci,ui_ci,vi_ci,icefile) - print *,'after call read_ice' - uice(:,:)=ui_ci(:,:) - vice(:,:)=vi_ci(:,:) - - do k=1,80 - ftime(k:k)=' ' - enddo -! ftime='6 hour fcst' - - kpds(1)=7 - if (igenocnp.GT.0) then - kpds(2)=igenocnp - else - kpds(2)=98 - endif - kpds(3)=10 - kpds(4)=192 - kpds(8)=mod(isyr-1,100)+1 - kpds(9)=ismth - kpds(10)=isday - kpds(11)=ishr - kpds(12)=0 - if (mfhout == 1) then - kpds(13)=1 - else if (mfhout == 3) then - kpds(13)=10 - else if (mfhout == 6) then - kpds(13)=11 - else if (mfhout == 12) then - kpds(13)=12 - else if (mfhout == 24) then - kpds(13)=2 - else - print *,'invalid mhout, must be one of (1 3 6 12 24).' - stop - endif - if (climate) then - kpds(13)=1 - kpds(14)=mfh - print *,'kpds(14)=',kpds(14) - print *,'mfhout=',mfhout - kpds(15)=0 - kpds(16)=10 - ftime=hr8 // ' hour fcst' - print *, 'ftime:', ftime - else - if (mfh > 1530) then - kpds(13)=1 - kpds(14)=mfh - kpds(15)=0 - kpds(16)=10 - else - kpds(14)=mfh/mfhout-1 - kpds(15)=kpds(14)+1 - kpds(16)=3 - endif - endif - kpds(17)=0 - kpds(18)=1 - kpds(19)=2 - kpds(20)=0 - kpds(21)=((iyr-1)/100)+1 - kpds(23)=4 - kpds(24)=0 - kpds(25)=32 - - print*,'kpds:',kpds(1:25) -! - kgds(1)=0 - kgds(2)=imo - kgds(3)=jmo - kgds(4)=nint(flatn*1000.) - kgds(5)=nint(flonw*1000.) - kgds(6)=128 - kgds(7)=nint(flats*1000.) - kgds(8)=nint(flone*1000.) - kgds(9)=nint(dlon*1000.) - kgds(10)=nint(dlat*1000.) - kgds(11)=0 - kgds(12)=0 - kgds(13)=0 - kgds(14)=0 - kgds(15)=0 - kgds(16)=0 - kgds(17)=0 - kgds(18)=0 - kgds(19)=0 - kgds(20)=255 - kgds(21)=0 - kgds(22)=0 -! - print*,'kgds:',kgds(1:22) -! - ndata=imo*jmo -! - ind=0 - do nv=1,5 - factor=fac(nv) - kpds(22)=kpds22(nv) - print *,nv,' factor ',factor,' kpds22 ',kpds(22) - -!temp/potdsl... - if (nv.eq.1) then - varocn=t - do k=1,km - do j=1,jmo - do i=1,imo - if (varocn(i,j,k).LE.undef) then - tocn(i,j,k)=undef - else - tocn(i,j,k)=varocn(i,j,k) - endif - enddo - enddo - enddo - endif - -!salinity - if (nv.eq.2) then - varocn=s - do k=1,km - do j=1,jmo - do i=1,imo - socn(i,j,k)=varocn(i,j,k) - enddo - enddo - enddo - endif -!u-current - if (nv.eq.3) then - varocn=u - endif -!v-current - if (nv.eq.4) then - varocn=v - endif -!------------------------------------------------------------------- -! Xingren: -! w vertical velocity (not present in raw NetCDF file) -! so how can you compute the vertical velocity with the program below? -!------------------------------------------------------------------- - if (nv.eq.5) then - varocn=w - do k=1,km-1 - kk=km-k+1 - do j=1,jmo - do i=1,imo - if (varocn(i,j,k).LE.undef) then - varocn(i,j,k)=varocn(i,j,k+1) - else - varocn(i,j,k)=(varocn(i,j,k+1)*(zw(kk)-zt(kk)) & - +varocn(i,j,k)*(zt(kk)-zw(kk-1)))/(zw(kk)-zw(kk-1)) - endif - enddo - enddo - enddo - continue - endif - - do k=1,km - ind=ind+1 - ilev=levs(k) - -! flip N-S - do j=1,jmo - grdtmp(:,j)=varocn(:,jmo-j+1,k) - enddo - -! make bit-map.... - do j=1,jmo - do i=1,imo - val=grdtmp(i,j) - if (val.eq.undef) then - lbms(i,j) = .false. - grid2(i+(j-1)*nx)=9.999E+20 - else - if (nv.eq.1) then - grid(i,j)=val+factor - else - grid(i,j)=val*factor - endif - lbms(i,j) = .true. - grid2(i+(j-1)*nx)=grid(i,j) - endif - enddo - enddo - - print *,' record written ',ind,nv,k,grid(92,125),lbms(92,125) - kpds(5)=kpds5(nv) - kpds(6)=kpds6(nv) - kpds(7)=ilev - - write(level4,'(i4)') ilev - levelcode=level4 // levelm(nv) - print *, 'levelcode= ', levelcode - print *, 'trim(ftime):', trim(ftime) - metadata='d=' // datecode // ':' // trim(varcode(nv)) // ':' // trim(levelcode) // ':' // trim(ftime) // ':' - iret = grb2_wrt(outfile,template_file,1,data1=grid2,meta=metadata) - write(*,*) iret -! -!.. end level-loop - enddo -!.. end variable-loop - enddo - -!... now read and grib 5 surface records... -! - do nv=6,nvar - levelcode=levelm(nv) - print *, 'levelcode= ', levelcode - print *, 'process data for nv=',nv - factor=fac(nv) - kpds(22)=kpds22(nv) - print *,nv,' factor ',factor,' kpds22 ',kpds(22) - ind=ind+1 - kpds(5)=kpds5(nv) - kpds(6)=kpds6(nv) - kpds(7)=kpds7(nv) - if (nv .EQ. 8 .or. (nv.GE.16 .AND. nv.LE.27)) then - kpds(19)=129 - else if (nv .EQ. 15) then - kpds(19)=128 - else - kpds(19)=2 - endif -! taux - if (nv.eq.6) then - varsfc=taux - do j=1,jmo - do i=1,imo - if (varsfc(i,j) .LE. spv_tau) varsfc(i,j)=undef - enddo - enddo - endif -! tauy - if (nv.eq.7) then - varsfc=tauy - do j=1,jmo - do i=1,imo - if (varsfc(i,j) .LE. spv_tau) varsfc(i,j)=undef - enddo - enddo - endif -! eta - if (nv.eq.8) then - varsfc=eta - endif -! fi - if (nv.eq.9) then - varsfc=fi_ci - call set_undef(im,jm,spv_ci,undef,varsfc) - endif -! hi - if (nv.eq.10) then - varsfc=hi_ci - call set_undef(im,jm,spv_ci,undef,varsfc) - endif -! hs - if (nv.eq.11) then - varsfc=hs_ci - call set_undef(im,jm,spv_ci,undef,varsfc) - endif -! ts - if (nv.eq.12) then - varsfc=ts_ci - call set_undef(im,jm,spv_ci,undef,varsfc) - endif -! uice - if (nv.eq.13) then - varsfc=uice - call set_undef(im,jm,spv_ci,undef,varsfc) - endif -! vice - if (nv.eq.14) then - varsfc=vice - call set_undef(im,jm,spv_ci,undef,varsfc) - endif -! pme - if (nv.eq.15) then - varsfc=lprec-evap !pme - do j=1,jm - do i=1,im -! if (varsfc(i,j) .LE. spv_pme) varsfc(i,j)=undef - if (lprec(i,j) .LE. spv_pme) varsfc(i,j)=undef - enddo - enddo - endif -! sfc_flx - if (nv.eq.16) then - varsfc=sfcflx - do j=1,jm - do i=1,im - if (varsfc(i,j) .LE. undef) varsfc(i,j)=undef - enddo - enddo - endif -! mld - if (nv.eq.17) then -! call mixed_layer(imo,jmo,km,tocn,socn,zt,varsfc,undef) - varsfc=mld - do j=1,jm - do i=1,im - if (varsfc(i,j) .LE. undef) varsfc(i,j)=undef - enddo - enddo - endif -! sfc isothm layer depth - if (nv.eq.18) then - call sfc_isothm_layer(imo,jmo,km,tocn,zt,varsfc,undef) - endif -! ocean heat content - if (nv.eq.19) then - call ocean_heat(imo,jmo,km,tocn,socn,zw,zt,varsfc,undef) - endif -! tropical cyc heat potential - if (nv.eq.20) then - call tchp26(imo,jmo,km,tocn,socn,zw,zt,varsfc,undef) - endif -! depth of 7 different isotherms... - if (nv.ge.21 .AND. nv.le.27) then - i=nv-20 - call isothm_layer(imo,jmo,km,dtc(i),tocn,zt,varsfc,undef) - endif -! sea surface salinity - if (nv.eq.28) then - varsfc=sss - do j=1,jm - do i=1,im - if (varsfc(i,j) .LE. undef) varsfc(i,j)=undef - enddo - enddo - endif -! sea surface u-current - if (nv.eq.29) then - varsfc=ssu - do j=1,jm - do i=1,im - if (varsfc(i,j) .LE. undef) varsfc(i,j)=undef - enddo - enddo - endif -! sea surface v-current - if (nv.eq.30) then - varsfc=ssv - do j=1,jm - do i=1,im - if (varsfc(i,j) .LE. undef) varsfc(i,j)=undef - enddo - enddo - endif -! sea surface speed - if (nv.eq.31) then - varsfc=speed - do j=1,jm - do i=1,im - if (varsfc(i,j) .LE. undef) varsfc(i,j)=undef - enddo - enddo - endif -! sensible heat - if (nv.eq.32) then - varsfc=sensible - do j=1,jm - do i=1,im - if (varsfc(i,j) .LE. undef) varsfc(i,j)=undef - enddo - enddo - endif -! latent heat - if (nv.eq.33) then - varsfc=latent - do j=1,jm - do i=1,im - if (varsfc(i,j) .LE. undef) varsfc(i,j)=undef - enddo - enddo - endif -! net downward shortwave radiation at the surface - if (nv.eq.34) then - varsfc=sw - do j=1,jm - do i=1,im - if (varsfc(i,j) .LE. undef) varsfc(i,j)=undef - enddo - enddo - endif -! net downward longwave radiation at the surface - if (nv.eq.35) then - varsfc=lw - do j=1,jm - do i=1,im - if (varsfc(i,j) .LE. undef) varsfc(i,j)=undef - enddo - enddo - endif -! precipitation rate - if (nv.eq.36) then - varsfc=lprec - do j=1,jm - do i=1,im - if (varsfc(i,j) .LE. undef) varsfc(i,j)=undef - enddo - enddo - endif -! evaporation - if (nv.eq.37) then - varsfc=evap - do j=1,jm - do i=1,im - if (varsfc(i,j) .LE. undef) varsfc(i,j)=undef - enddo - enddo - endif - - nundef=0 - do j=1,jmo - grdtmp(:,j)=varsfc(:,jmo-j+1) - enddo - do j=1,jmo - do i=1,imo - val=grdtmp(i,j) - if (val.eq.undef) then - lbms(i,j) = .false. - nundef=nundef+1 - grid2(i+(j-1)*nx)=9.999E+20 - else - if (nv.EQ.12) then - grid(i,j)=val+factor - else - grid(i,j)=val*factor - endif - lbms(i,j) = .true. - grid2(i+(j-1)*nx)=grid(i,j) - endif - enddo - enddo - if(nundef.eq.imo*jmo) then - print *,' record not written because of all undef ', & - ind,kpds(5),kpds(6),kpds(7) - else - print *,' record written ',ind,kpds(5),kpds(6),kpds(7), & - grid(92,125),lbms(92,125),factor - endif - print *,'nv= ', nv - metadata='d=' // datecode // ':' // trim(varcode(nv)) // ':' // trim(levelcode) // ':' // trim(ftime) // ':' - iret = grb2_wrt(outfile,template_file,1,data1=grid2,meta=metadata) - write(*,*) iret - - enddo - - return - end subroutine diag - - subroutine isothm_layer(im,jm,km,dtc,temp,zlev,zisothm,undef) - - real, parameter :: c2k=273.15 - integer inumc,im,jm,km - integer i,j,k - real dtc - real, dimension(km) :: tz,zlev - real, dimension(im,jm) :: zisothm - real, dimension(im,jm,km) :: temp - real a,b,tc,undef - - tc=dtc+c2k - - do j=1,jm - do i=1,im - - zisothm(i,j)=undef - if (temp(i,j,1) .GE. tc) then - do k=1,km - tz(k)=temp(i,j,k) - enddo - do k=2,km - if (tz(k) .LT. -3.0) go to 111 - if (tz(k) .LT. tc) then - a = (tz(k)-tc) / (tz(k)-tz(k-1)) - b = (tc-tz(k-1)) / (tz(k)-tz(k-1)) - zisothm(i,j)=a*zlev(k-1)+b*zlev(k) - go to 111 - endif - enddo - endif - 111 continue - enddo - enddo - - return - end subroutine isothm_layer - - subroutine mixed_layer(im,jm,km,temp,salt,zlev,mld,undef) - - real, parameter :: disot=0.8, c2k=273.15 - integer im,jm,km - integer i,j,k,kmsk,kbm,kbp,krf - real, dimension(km) :: zlev,plev,sa,ta,th,rho - real, dimension(im,jm) :: mld - real, dimension(im,jm,km) :: temp,salt - real a,b,deltarho,dr,rb,undef - - do k=1,km - plev(k) = press(zlev(k),980.0) - enddo - - do j=1,jm - do i=1,im - kmsk = 0 - do k=1,km - if (temp(i,j,k).GT.0.0 .AND. salt(i,j,k).GT.0.0) then - ta(k) = temp(i,j,k)-c2k - sa(k) = salt(i,j,k) - kmsk = k - endif - enddo - - if (kmsk.EQ.0 .OR. ta(1).LT.-3.0) then - mld(i,j)=undef - else - deltarho = (density(0.0,ta(1)-disot,sa(1)) & - - density(0.0,ta(1),sa(1))) - do k=1,kmsk - th(k) = theta(plev(k),ta(k),sa(k),0.0) - rho(k) = density(0.0,th(k),sa(k)) - 1000.0 - enddo - krf = 1 - kbm = 0 - kbp = 0 - do k = krf,kmsk - if ((rho(k)-rho(krf)) .GE. deltarho) then - kbp = k - exit - endif - enddo - if (kbp .LE. 1) then - mld(i,j) = undef - else - kbm = kbp - 1 - rb = rho(krf) + deltarho - dr = rho(kbp) - rho(kbm) - a = (rho(kbp) - rb) / dr - b = (rb - rho(kbm)) / dr - mld(i,j) = zlev(kbm)*a + zlev(kbp)*b - endif - endif - enddo - enddo - - end subroutine mixed_layer - - subroutine sfc_isothm_layer(im,jm,km,temp,zlev,sitd,undef) - - real, parameter :: disot=0.8 - integer im,jm,km - integer i,j,k - real, dimension(im,jm) :: sitd - real, dimension(im,jm,km) :: temp - real, dimension(km) :: zlev,tz - real a,b,tc,undef - - do j=1,jm - do i=1,im - - sitd(i,j)=undef - - if (temp(i,j,1).GE.0.0) then - tc=temp(i,j,1)-disot - do k=1,km - tz(k)=temp(i,j,k) - enddo - do k=2,km - if (tz(k).LT.0.0) go to 112 - if (tz(k).LT.tc) then - a = (tz(k)-tc) / (tz(k)-tz(k-1)) - b = (tc-tz(k-1)) / (tz(k)-tz(k-1)) - sitd(i,j) = a*zlev(k-1) + b*zlev(k) - go to 112 - endif - enddo - endif - - 112 continue - - enddo - enddo - - return - end subroutine sfc_isothm_layer - - subroutine ocean_heat(im,jm,km,temp,salt,zblev,zlev,ocnhc,undef) - - integer, parameter :: kmh=26 - real, parameter :: c2k=273.15 - integer im,jm,km - integer i,j,k - real, dimension(km) :: zblev,zlev,plev - real, dimension(im,jm) :: ocnhc - real, dimension(im,jm,km) :: salt,temp - real dptlyr,rk,sk,tk,undef - real pk,rhm,rhp,tempk,zk - - k=kmh - zk=0.5*(300.0+zblev(k-1)) - pk=press(zk,980.0) - rhm = (zk-zlev(k-1))/(zlev(k)-zlev(k-1)) - rhp = (zlev(k)-zk)/(zlev(k)-zlev(k-1)) - - do k=1,km - plev(k) = press(zlev(k),980.0) - enddo - - do j=1,jm - do i=1,im - - ocnhc(i,j)=undef - - if (temp(i,j,kmh).GT.0.0 .AND. salt(i,j,kmh).GT.0.0) then - ocnhc(i,j)=0. - do k=1,kmh-1 - tk=temp(i,j,k)-c2k -! print *,'tk= ',tk - sk=salt(i,j,k) - rk=density(plev(k),tk,sk) - if (k .eq. 1) then - dptlyr=zblev(k) - else - dptlyr=zblev(k)-zblev(k-1) - endif - ocnhc(i,j)=ocnhc(i,j) + rk*temp(i,j,k)*dptlyr - enddo - k=kmh - tempk=rhp*temp(i,j,k-1) + rhm*temp(i,j,k) - tk=tempk - c2k - sk=rhp*salt(i,j,k-1) + rhm*salt(i,j,k) - rk=density(pk,tk,sk) - dptlyr=300.0-zblev(k-1) - ocnhc(i,j)=ocnhc(i,j)+rk*tempk*dptlyr - ocnhc(i,j)=ocnhc(i,j)*3996. - endif - enddo - enddo - - return - end subroutine ocean_heat - - subroutine tchp26(im,jm,km,temp,salt,zblev,zlev,ocnhcp,undef) - - real, parameter :: c2k=273.15, t26=26.0 - integer im,jm,km - integer i,j,k,k26 - real, dimension(km) :: zblev,zlev,plev,tz - real, dimension(im,jm) :: ocnhcp,z26isothm - real, dimension(im,jm,km) :: salt,temp - real dptlyr,rk,sk,tk,undef - real rhm,rhp,pk,zk - real a,b,skk,skm,tc,z26 - logical*1 lbms(im,jm) - - tc=c2k+t26 - - do k=1,km - plev(k) = press(zlev(k),980.0) - enddo - - do j=1,jm - do i=1,im - - z26isothm(i,j)=undef - lbms(i,j)=.false. - if (temp(i,j,1) .GE. tc) then - do k=1,km - tz(k)=temp(i,j,k) - enddo - k = 1 - do while (tz(k).GE.tc) - k26 = k - if (k.EQ.km) exit - k = k + 1 - enddo - k = k26 - if (tz(k) .GT. tc) then - if (k.LT.km .AND. tz(k+1).GT.0.0) then - k = k + 1 - a = (tz(k)-tc) / (tz(k)-tz(k-1)) - b = (tc-tz(k-1)) / (tz(k)-tz(k-1)) - z26isothm(i,j) = a*zlev(k-1) + b*zlev(k) - lbms(i,j)=.true. - else if (k.GE.2 .AND. tz(k).LT.tz(k-1)) then - a = (tz(k)-tc) / (tz(k)-tz(k-1)) - b = (tc-tz(k-1)) / (tz(k)-tz(k-1)) - z26 = a*zlev(k-1) + b*zlev(k) - if (z26.LE.zblev(k)) then - z26isothm(i,j) = z26 - lbms(i,j)=.true. - endif - endif - else if (tz(k).EQ.tc) then - z26isothm(i,j) = zlev(k) - lbms(i,j)=.true. - endif - endif - - enddo - enddo - -! -!---------- get ocean heat potential relative to 26C (TCHP) ------------ -! - do j=1,jm - do i=1,im - - if (temp(i,j,1) .GT. 0.0) then - ocnhcp(i,j)=0.0 - else - ocnhcp(i,j)=undef - cycle - endif - - if (lbms(i,j)) then ! we have water above 26c - - z26 = z26isothm(i,j) -! -! case where Z26 is within the topmost layer -! - if (z26 .LE. zblev(1)) then - tk=temp(i,j,1)-c2k - if (salt(i,j,1) .GT. 0.0) then - sk=salt(i,j,1) - else - sk=35. ! fake salinity - endif - rk=density(plev(1),tk,sk) - dptlyr=z26 - ocnhcp(i,j) = rk*(tk-t26)*dptlyr*3996. -! -! case where z26 is below the top layer and above the bottom -! - else - k26 = 1 - do k=2,km - if (z26.GT.zblev(k-1) .AND. z26.LE.zblev(k)) k26=k - enddo - - ocnhcp(i,j)=0.0 - do k=1,k26-1 - tk=temp(i,j,k)-c2k - if (salt(i,j,K) .GT. 0.0) then - sk=salt(i,j,k) - else - sk=35. ! fake salinity - endif - rk=density(plev(k),tk,sk) - if (k .EQ. 1) then - dptlyr=zblev(1) - else - dptlyr=zblev(k)-zblev(k-1) - endif - ocnhcp(i,j)=ocnhcp(i,j)+rk*(tk-26.0)*dptlyr - enddo - k=k26 - zk=0.5*(z26+zblev(k-1)) - pk=press(zk,980.0) - rhm = (zk-zlev(k-1))/(zlev(k)-zlev(k-1)) - rhp = (zlev(k)-zk)/(zlev(k)-zlev(k-1)) - tk=rhp*temp(i,j,k-1) + rhm*temp(i,j,k) - c2k - if (salt(i,j,k-1) .GT. 0.0) then - skm=salt(i,j,k-1) - else - skm=35. ! fake salinity - endif - if (salt(i,j,k) .GT. 0.0) then - skk=salt(i,j,k) - else - skk=35. ! fake salinity - endif - sk=(rhp*skm + rhm*skk) - rk=density(pk,tk,sk) - dptlyr=z26-zblev(k-1) - ocnhcp(i,j)=ocnhcp(i,j)+rk*(tk-26.0)*dptlyr - ocnhcp(i,j)=ocnhcp(i,j)*3996. - endif -! -! case where temperature is above 26C down to the bottom -! - else if ((temp(i,j,1)-c2k) .GT. t26) then - ocnhcp(i,j)=0.0 - do k=1,km - if (temp(i,j,k) .GT. undef) then - tk=temp(i,j,k)-c2k - if (salt(i,j,k) .GT. 0.0) then - sk=salt(i,j,k) - else - sk=35. ! fake salinity - endif - rk=density(plev(k),tk,sk) - if (k .EQ. 1) then - dptlyr=zblev(1) - else - dptlyr=zblev(k)-zblev(k-1) - endif - ocnhcp(i,j)=ocnhcp(i,j)+rk*(tk-26.0)*dptlyr - endif - enddo - ocnhcp(i,j)=ocnhcp(i,j)*3996. - endif - - enddo - enddo - - return - end subroutine tchp26 - - function press(z, g) - -! copy from cfs_ocean_time.f and modified -! depth (z) in meters and grav acc'l (g) in cm/sec**2 - - integer, parameter :: itr=20 - integer i - real p, a0, z, g, press - real(kind=8) :: e, ae, es -! - p = z*(1.0076+z*(2.3487e-6-z*1.2887e-11)) - e = zeta(p,g)-z - ae = abs(e) - es = ae*2. - do i = 1,itr - a0 = 0.972643+p*(1.32696e-5-p*(6.228e-12+p*1.885e-16)) - a0 = a0/(1.0+1.83e-5*p) - p = p-((g+1.113e-4*p)/a0)*e*0.001 - es = ae - e = zeta(p,g)-z - ae = abs(e) - if (ae .le. 0.01) exit - enddo -! - press = p -! - end function press - - function zeta(p, glat) -! -! copy from cfs_ocean_time.f and modified - - real p, glat, z, zeta - - z = ((-3.434e-12*p+1.113e-7)*p+0.712953)*p+14190.7*log(1.0+1.83e-5*p) - z = (z/(glat+1.113e-4*p))*1000. - - zeta = z -! - end function zeta - - function density(prs, tmp, sal) -! -! copy from cfs_ocean_time.f and modified -! Density is in units of kg/m**3 (1 g/cm**3 = 1000 kg/m**3) - - real density, prs, tmp, sal - real p, t, s, kstp, k0, kw, d0, dw -! - s = sal - t = tmp - p = prs/10.00 -! - kw = 19652.21+(148.4206-(2.327105-(1.360477e-2-5.155288e-5*t)*t)*t)*t -! - k0 = kw+s*(54.6746-(0.603459-(1.09987e-2-6.1670e-5*t)*t)*t) & - +sqrt(s*s*s)*(7.944e-2+(1.6483e-2-5.3009e-4*t)*t) -! - kstp = k0+p*((3.239908+(1.43713e-3+(1.16092e-4-5.77905e-7*t)*t)*t) & - +s*(2.2838e-3-(1.0981e-5+1.6078e-6*t)*t) & - +sqrt(s*s*s)*1.91075e-4 & - +p*((8.50935e-5-(6.12293e-6-5.2787e-8*t)*t) & - -s*(9.9348e-7-(2.0816e-8+9.1697e-10*t)*t))) -! - dw = 999.842594+(6.793952e-2-(9.095290e-3-(1.001685e-4 & - -(1.120083e-6-6.536332e-9*t)*t)*t)*t)*t -! - d0 = dw+s*(0.824493-(4.0899e-3-(7.6438e-5-(8.2467e-7 & - -5.3875e-9*t)*t)*t)*t) & - -sqrt(s*s*s)*(5.72466e-3-(1.0227e-4-1.6546e-6*t)*t) & - +s*s*4.8314e-4 -! - density = d0/(1.0-p/kstp) - - end function density - - function theta(p, t, s, pref) - - real(kind=8), parameter :: sqrt2 = 0.7071067811865475 - real theta, p,t, s, pref - real del_p, del_t1, del_t2, del_t3, del_t4, tp, th - - del_p = pref-p - del_t1 = del_p*atg(p,t,s) - tp = t+0.5*del_t1 - del_t2 = del_p*atg((p+0.5*del_p),tp,s) - tp = t+(-0.5+sqrt2)*del_t1+(1.0-sqrt2)*del_t2 - del_t3 = del_p*atg((p+0.5*del_p),tp,s) - tp = t-sqrt2*del_t2+(1.0+sqrt2)*del_t3 - del_t4 = del_p*atg(pref,tp,s) - th = (t+(del_t1+(1.0-sqrt2)*del_t2*2.0 & - + (1.0+sqrt2)*del_t3*2.0+del_t4)/6.0) - theta = th - - end function theta - - function atg(p, t, s) - - real atg, p, t, s, ds, a - - ds = s-35.0 - a = (((-2.1687e-16*t+1.8676e-14)*t-4.6206e-13)*p & - +((2.7759e-12*t-1.1351e-10)*ds+((-5.4481e-14*t & - +8.733e-12)*t-6.7795e-10)*t+1.8741e-8))*p & - +(-4.2393e-8*t+1.8932e-6)*ds & - +((6.6228e-10*t-6.836e-8)*t+8.5258e-6)*t+3.5803e-5 - - atg = a - - end function atg - - - end module regdiag_mod diff --git a/sorc/regrid_nemsio.fd/CMakeLists.txt b/sorc/regrid_nemsio.fd/CMakeLists.txt deleted file mode 100644 index 068a7213a3..0000000000 --- a/sorc/regrid_nemsio.fd/CMakeLists.txt +++ /dev/null @@ -1,27 +0,0 @@ -list(APPEND fortran_src -constants.f90 -fv3_interface.f90 -gfs_nems_interface.f90 -interpolation_interface.f90 -kinds.f90 -main.f90 -mpi_interface.f90 -namelist_def.f90 -netcdfio_interface.f90 -physcons.f90 -regrid_nemsio_interface.f90 -variable_interface.f90 -) - -set(exe_name regrid_nemsio.x) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - nemsio::nemsio - bacio::bacio_4 - sp::sp_d - w3nco::w3nco_d - NetCDF::NetCDF_Fortran - MPI::MPI_Fortran) - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/regrid_nemsio.fd/Makefile b/sorc/regrid_nemsio.fd/Makefile deleted file mode 100644 index c5bfb0ed1c..0000000000 --- a/sorc/regrid_nemsio.fd/Makefile +++ /dev/null @@ -1,159 +0,0 @@ -#============================================================================== -# -# REGRID_NEMSIO Makefile -# -#============================================================================== - -#----------------------------------------------------------------------------- -# -- Parent make (calls child make) -- -#----------------------------------------------------------------------------- - -# ------------- -# General Rules -# ------------- - -SHELL=/bin/sh - -RM = /bin/rm -f -MKDIR = /bin/mkdir -p - -#------------ -# Include machine dependent compile & load options -#------------ - -MAKE_CONF = -include $(MAKE_CONF) - -# ------------- -# This makefile -# ------------- - -MAKE_FILE = Makefile - -# ----------- -# Load module -# ----------- - -EXE_FILE = regrid_nemsio - -# -------------------- -# Installing directory -# -------------------- - -INSTALL_DIR = ../../exec/ - -# -------- -# Log file -# -------- - -LOG_FILE = log.make.$(EXE_FILE) - -# --------------- -# Call child make -# --------------- - -"" : - @$(MAKE) -f $(MAKE_FILE) all - -# ------------ -# Make install -# ------------ - -install: - @echo - @echo '==== INSTALL =================================================' - @if [ -e $(INSTALL_DIR) ]; then \ - if [ ! -d $(INSTALL_DIR) ]; then \ - echo '### Fail to create installing directory ###' ;\ - echo '### Stop the installation ###' ;\ - exit ;\ - fi ;\ - else \ - echo " mkdir -p $(INSTALL_DIR)" ;\ - mkdir -p $(INSTALL_DIR) ;\ - fi - cp $(EXE_FILE) $(INSTALL_DIR) - @cd $(INSTALL_DIR) ; ls -l `pwd`/$(EXE_FILE) - -#----------- -# Make clean -# ---------- - -clean: - @echo - @echo '==== CLEAN ===================================================' - - $(RM) $(EXE_FILE) *.o *.mod - - $(RM) log.make.$(EXE_FILE) - -#----------------------------------------------------------------------------- -# -- Child make -- -#----------------------------------------------------------------------------- - -# --------- -# Libraries -# --------- - -INCS = $(NETCDF_INCLUDE) -I$(NEMSIO_INC) -LIBS = $(NEMSIO_LIB) $(BACIO_LIB4) $(W3NCO_LIBd) $(SP_LIB4) $(NETCDF_LDFLAGS) - -# ------------ -# Source files -# ------------ - -SRCSF90 = \ - kinds.f90 \ - constants.f90 \ - physcons.f90 \ - mpi_interface.f90 \ - namelist_def.f90 \ - variable_interface.f90 \ - netcdfio_interface.f90 \ - interpolation_interface.f90 \ - gfs_nems_interface.f90 \ - fv3_interface.f90 - -SRCS = $(SRCSF77) $(SRCSF90) - -# ------------ -# Object files -# ------------ - -OBJS = ${SRCSF90:.f90=.o} ${SRCSF77:.f=.o} - -# ------------ -# Dependencies -# ------------ -MAKE_DEPEND = Makefile.dependency -include $(MAKE_DEPEND) - -# ----------------------- -# Default compiling rules -# ----------------------- - -.SUFFIXES : -.SUFFIXES : .F90 .f90 .f .c .o - -.f90.o : - @echo - @echo '---> Compiling $<' - $(F90) $(FCFFLAGS) $(INCS) $(OPTIMIZATION) $(DEBUG) -c $< - -.f.o : - @echo - @echo '---> Compiling $<' - $(F77) $(FCFFLAGS) $(OPTIMIZATION) $(DEBUG) -c $< - -# ------------------------ -# Call compiler and linker -# ------------------------ - -all: REGRID_NEMSIO - -REGRID_NEMSIO: $(OBJS) - $(LD) $(LDFLAGS) $(OBJS) $(INCS) main.f90 $(LIBS) -o $(EXE_FILE) > $(LOG_FILE) - -help: - @ echo "Available targets:" - @ echo " make creates executable" - @ echo " make install creates exec & places it in bin" - @ echo " make clean cleans objects, exec, and alien files" diff --git a/sorc/regrid_nemsio.fd/Makefile.dependency b/sorc/regrid_nemsio.fd/Makefile.dependency deleted file mode 100644 index 52f6e80077..0000000000 --- a/sorc/regrid_nemsio.fd/Makefile.dependency +++ /dev/null @@ -1,9 +0,0 @@ -kinds.o: kinds.f90 -constants.o: constants.f90 kinds.o -physcons.o: physcons.f90 kinds.o -variable_interface.o: variable_interface.f90 namelist_def.o physcons.o constants.o kinds.o -namelist_def.o: namelist_def.f90 mpi_interface.o kinds.o -netcdfio_interface.o: netcdfio_interface.f90 kinds.o -interpolation_interface.o: interpolation_interface.f90 constants.o kinds.o namelist_def.o netcdfio_interface.o -gfs_nems_interface.o: gfs_nems_interface.f90 variable_interface.o constants.o kinds.o mpi_interface.o namelist_def.o -fv3_interface.o: fv3_interface.f90 variable_interface.o interpolation_interface.o constants.o kinds.o mpi_interface.o namelist_def.o netcdfio_interface.o gfs_nems_interface.o diff --git a/sorc/regrid_nemsio.fd/constants.f90 b/sorc/regrid_nemsio.fd/constants.f90 deleted file mode 100644 index 8627358e2d..0000000000 --- a/sorc/regrid_nemsio.fd/constants.f90 +++ /dev/null @@ -1,314 +0,0 @@ -! this module was extracted from the GSI version operational -! at NCEP in Dec. 2007. -module constants -!$$$ module documentation block -! . . . . -! module: constants -! prgmmr: treadon org: np23 date: 2003-09-25 -! -! abstract: This module contains the definition of various constants -! used in the gsi code -! -! program history log: -! 2003-09-25 treadon - original code -! 2004-03-02 treadon - allow global and regional constants to differ -! 2004-06-16 treadon - update documentation -! 2004-10-28 treadon - replace parameter tiny=1.e-12 with tiny_r_kind -! and tiny_single -! 2004-11-16 treadon - add huge_single, huge_r_kind parameters -! 2005-01-27 cucurull - add ione -! 2005-08-24 derber - move cg_term to constants from qcmod -! 2006-03-07 treadon - add rd_over_cp_mass -! 2006-05-18 treadon - add huge_i_kind -! 2006-06-06 su - add var-qc wgtlim, change value to 0.25 (ECMWF) -! 2006-07-28 derber - add r1000 -! -! Subroutines Included: -! sub init_constants - compute derived constants, set regional/global constants -! -! Variable Definitions: -! see below -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ - use kinds, only: r_single,r_kind,i_kind - implicit none - -! Declare constants - integer(i_kind) izero,ione - real(r_kind) rearth,grav,omega,rd,rv,cp,cv,cvap,cliq - real(r_kind) csol,hvap,hfus,psat,t0c,ttp,jcal,cp_mass,cg_term - real(r_kind) fv,deg2rad,rad2deg,pi,tiny_r_kind,huge_r_kind,huge_i_kind - real(r_kind) ozcon,rozcon,tpwcon,rd_over_g,rd_over_cp,g_over_rd - real(r_kind) amsua_clw_d1,amsua_clw_d2,constoz,zero,one,two,four - real(r_kind) one_tenth,quarter,three,five,rd_over_cp_mass - real(r_kind) rearth_equator,stndrd_atmos_ps,r1000,stndrd_atmos_lapse - real(r_kind) semi_major_axis,semi_minor_axis,n_a,n_b - real(r_kind) eccentricity,grav_polar,grav_ratio - real(r_kind) grav_equator,earth_omega,grav_constant - real(r_kind) flattening,eccentricity_linear,somigliana - real(r_kind) dldt,dldti,hsub,psatk,tmix,xa,xai,xb,xbi - real(r_kind) eps,epsm1,omeps,wgtlim - real(r_kind) elocp,cpr,el2orc,cclimit,climit,epsq - real(r_kind) pcpeff0,pcpeff1,pcpeff2,pcpeff3,rcp,c0,delta - real(r_kind) h1000,factor1,factor2,rhcbot,rhctop,dx_max,dx_min,dx_inv - real(r_kind) h300,half,cmr,cws,ke2,row,rrow - real(r_single) zero_single,tiny_single,huge_single - real(r_single) rmw_mean_distance, roic_mean_distance - logical :: constants_initialized = .true. - - -! Define constants common to global and regional applications -! name value description units -! ---- ----- ----------- ----- - parameter(rearth_equator= 6.37813662e6_r_kind) ! equatorial earth radius (m) - parameter(omega = 7.2921e-5_r_kind) ! angular velocity of earth (1/s) - parameter(cp = 1.0046e+3_r_kind) ! specific heat of air @pressure (J/kg/K) - parameter(cvap = 1.8460e+3_r_kind) ! specific heat of h2o vapor (J/kg/K) - parameter(csol = 2.1060e+3_r_kind) ! specific heat of solid h2o (ice)(J/kg/K) - parameter(hvap = 2.5000e+6_r_kind) ! latent heat of h2o condensation (J/kg) - parameter(hfus = 3.3358e+5_r_kind) ! latent heat of h2o fusion (J/kg) - parameter(psat = 6.1078e+2_r_kind) ! pressure at h2o triple point (Pa) - parameter(t0c = 2.7315e+2_r_kind) ! temperature at zero celsius (K) - parameter(ttp = 2.7316e+2_r_kind) ! temperature at h2o triple point (K) - parameter(jcal = 4.1855e+0_r_kind) ! joules per calorie () - parameter(stndrd_atmos_ps = 1013.25e2_r_kind) ! 1976 US standard atmosphere ps (Pa) - -! Numeric constants - parameter(izero = 0) - parameter(ione = 1) - parameter(zero_single = 0.0_r_single) - parameter(zero = 0.0_r_kind) - parameter(one_tenth = 0.10_r_kind) - parameter(quarter= 0.25_r_kind) - parameter(one = 1.0_r_kind) - parameter(two = 2.0_r_kind) - parameter(three = 3.0_r_kind) - parameter(four = 4.0_r_kind) - parameter(five = 5.0_r_kind) - parameter(r1000 = 1000.0_r_kind) - -! Constants for gps refractivity - parameter(n_a=77.6_r_kind) !K/mb - parameter(n_b=3.73e+5_r_kind) !K^2/mb - -! Parameters below from WGS-84 model software inside GPS receivers. - parameter(semi_major_axis = 6378.1370e3_r_kind) ! (m) - parameter(semi_minor_axis = 6356.7523142e3_r_kind) ! (m) - parameter(grav_polar = 9.8321849378_r_kind) ! (m/s2) - parameter(grav_equator = 9.7803253359_r_kind) ! (m/s2) - parameter(earth_omega = 7.292115e-5_r_kind) ! (rad/s) - parameter(grav_constant = 3.986004418e14_r_kind) ! (m3/s2) - -! Derived geophysical constants - parameter(flattening = (semi_major_axis-semi_minor_axis)/semi_major_axis)!() - parameter(somigliana = & - (semi_minor_axis/semi_major_axis) * (grav_polar/grav_equator) - one)!() - parameter(grav_ratio = (earth_omega*earth_omega * & - semi_major_axis*semi_major_axis * semi_minor_axis) / grav_constant) !() - -! Derived thermodynamic constants - parameter ( dldti = cvap-csol ) - parameter ( hsub = hvap+hfus ) - parameter ( psatk = psat*0.001_r_kind ) - parameter ( tmix = ttp-20._r_kind ) - parameter ( elocp = hvap/cp ) - parameter ( rcp = one/cp ) - -! Constants used in GFS moist physics - parameter ( h300 = 300._r_kind ) - parameter ( half = 0.5_r_kind ) - parameter ( cclimit = 0.001_r_kind ) - parameter ( climit = 1.e-20_r_kind) - parameter ( epsq = 2.e-12_r_kind ) - parameter ( h1000 = 1000.0_r_kind) - parameter ( rhcbot=0.85_r_kind ) - parameter ( rhctop=0.85_r_kind ) - parameter ( dx_max=-8.8818363_r_kind ) - parameter ( dx_min=-5.2574954_r_kind ) - parameter ( dx_inv=one/(dx_max-dx_min) ) - parameter ( c0=0.002_r_kind ) - parameter ( delta=0.6077338_r_kind ) - parameter ( pcpeff0=1.591_r_kind ) - parameter ( pcpeff1=-0.639_r_kind ) - parameter ( pcpeff2=0.0953_r_kind ) - parameter ( pcpeff3=-0.00496_r_kind ) - parameter ( cmr = one/0.0003_r_kind ) - parameter ( cws = 0.025_r_kind ) - parameter ( ke2 = 0.00002_r_kind ) - parameter ( row = 1000._r_kind ) - parameter ( rrow = one/row ) - -! Constant used to process ozone - parameter ( constoz = 604229.0_r_kind) - -! Constants used in cloud liquid water correction for AMSU-A -! brightness temperatures - parameter ( amsua_clw_d1 = 0.754_r_kind ) - parameter ( amsua_clw_d2 = -2.265_r_kind ) - -! Constants used for variational qc - parameter ( wgtlim = 0.25_r_kind) ! Cutoff weight for concluding that obs has been - ! rejected by nonlinear qc. This limit is arbitrary - ! and DOES NOT affect nonlinear qc. It only affects - ! the printout which "counts" the number of obs that - ! "fail" nonlinear qc. Observations counted as failing - ! nonlinear qc are still assimilated. Their weight - ! relative to other observations is reduced. Changing - ! wgtlim does not alter the analysis, only - ! the nonlinear qc data "count" - -! Constants describing the Extended Best-Track Reanalysis [Demuth et -! al., 2008] tropical cyclone (TC) distance for regions relative to TC -! track position; units are in kilometers - - parameter (rmw_mean_distance = 64.5479412) - parameter (roic_mean_distance = 338.319656) - -contains - subroutine init_constants_derived -!$$$ subprogram documentation block -! . . . . -! subprogram: init_constants_derived set derived constants -! prgmmr: treadon org: np23 date: 2004-12-02 -! -! abstract: This routine sets derived constants -! -! program history log: -! 2004-12-02 treadon -! 2005-03-03 treadon - add implicit none -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp -! -!$$$ - implicit none - -! Trigonometric constants - pi = acos(-one) - deg2rad = pi/180.0_r_kind - rad2deg = one/deg2rad - cg_term = (sqrt(two*pi))/two ! constant for variational qc - tiny_r_kind = tiny(zero) - huge_r_kind = huge(zero) - tiny_single = tiny(zero_single) - huge_single = huge(zero_single) - huge_i_kind = huge(izero) - -! Geophysical parameters used in conversion of geopotential to -! geometric height - eccentricity_linear = sqrt(semi_major_axis**2 - semi_minor_axis**2) - eccentricity = eccentricity_linear / semi_major_axis - constants_initialized = .true. - - return - end subroutine init_constants_derived - - subroutine init_constants(regional) -!$$$ subprogram documentation block -! . . . . -! subprogram: init_constants set regional or global constants -! prgmmr: treadon org: np23 date: 2004-03-02 -! -! abstract: This routine sets constants specific to regional or global -! applications of the gsi -! -! program history log: -! 2004-03-02 treadon -! 2004-06-16 treadon, documentation -! 2004-10-28 treadon - use intrinsic TINY function to set value -! for smallest machine representable positive -! number -! 2004-12-03 treadon - move derived constants to init_constants_derived -! 2005-03-03 treadon - add implicit none -! -! input argument list: -! regional - if .true., set regional gsi constants; -! otherwise (.false.), use global constants -! -! output argument list: -! -! attributes: -! language: f90 -! machine: ibm rs/6000 sp -! -!$$$ - implicit none - logical regional - real(r_kind) reradius,g,r_d,r_v,cliq_wrf - - stndrd_atmos_lapse = 0.0065 - -! Define regional constants here - if (regional) then - -! Name given to WRF constants - reradius = one/6370.e03_r_kind - g = 9.81_r_kind - r_d = 287.04_r_kind - r_v = 461.6_r_kind - cliq_wrf = 4190.0_r_kind - cp_mass = 1004.67_r_kind - -! Transfer WRF constants into unified GSI constants - rearth = one/reradius - grav = g - rd = r_d - rv = r_v - cv = cp-r_d - cliq = cliq_wrf - rd_over_cp_mass = rd / cp_mass - -! Define global constants here - else - rearth = 6.3712e+6_r_kind - grav = 9.80665e+0_r_kind - rd = 2.8705e+2_r_kind - rv = 4.6150e+2_r_kind - cv = 7.1760e+2_r_kind - cliq = 4.1855e+3_r_kind - cp_mass= zero - rd_over_cp_mass = zero - endif - - -! Now define derived constants which depend on constants -! which differ between global and regional applications. - -! Constants related to ozone assimilation - ozcon = grav*21.4e-9_r_kind - rozcon= one/ozcon - -! Constant used in vertical integral for precipitable water - tpwcon = 100.0_r_kind/grav - -! Derived atmospheric constants - fv = rv/rd-one ! used in virtual temperature equation - dldt = cvap-cliq - xa = -(dldt/rv) - xai = -(dldti/rv) - xb = xa+hvap/(rv*ttp) - xbi = xai+hsub/(rv*ttp) - eps = rd/rv - epsm1 = rd/rv-one - omeps = one-eps - factor1 = (cvap-cliq)/rv - factor2 = hvap/rv-factor1*t0c - cpr = cp*rd - el2orc = hvap*hvap/(rv*cp) - rd_over_g = rd/grav - rd_over_cp = rd/cp - g_over_rd = grav/rd - - return - end subroutine init_constants - -end module constants diff --git a/sorc/regrid_nemsio.fd/fv3_interface.f90 b/sorc/regrid_nemsio.fd/fv3_interface.f90 deleted file mode 100644 index bbe558e428..0000000000 --- a/sorc/regrid_nemsio.fd/fv3_interface.f90 +++ /dev/null @@ -1,779 +0,0 @@ -module fv3_interface - - !======================================================================= - - ! Define associated modules and subroutines - - !----------------------------------------------------------------------- - - use constants - - !----------------------------------------------------------------------- - - use gfs_nems_interface - use interpolation_interface - use mpi_interface - use namelist_def - use netcdfio_interface - use variable_interface - use nemsio_module - - !----------------------------------------------------------------------- - - implicit none - - !----------------------------------------------------------------------- - - ! Define all data and structure types for routine; these variables - ! are variables required by the subroutines within this module - - type analysis_grid - character(len=500) :: filename - character(len=500) :: filename2d - integer :: nx - integer :: ny - integer :: nz - integer :: ntime - end type analysis_grid ! type analysis_grid - - ! Define global variables - - integer n2dvar,n3dvar,ntvars,nrecs,nvvars - real(nemsio_realkind), dimension(:,:,:,:), allocatable :: fv3_var_3d - real(nemsio_realkind), dimension(:,:,:), allocatable :: fv3_var_2d - - !----------------------------------------------------------------------- - - ! Define interfaces and attributes for module routines - - private - public :: fv3_regrid_nemsio - - !----------------------------------------------------------------------- - -contains - - !----------------------------------------------------------------------- - - subroutine fv3_regrid_nemsio() - - ! Define variables computed within routine - - implicit none - type(analysis_grid) :: anlygrd(ngrids) - type(varinfo), allocatable, dimension(:) :: var_info,var_info2d,var_info3d - type(gfs_grid) :: gfs_grid - type(gridvar) :: invar,invar2 - type(gridvar) :: outvar,outvar2 - type(nemsio_meta) :: meta_nemsio2d, meta_nemsio3d - - type(esmfgrid) :: grid_bilin - type(esmfgrid) :: grid_nn - - character(len=20) :: var_name - character(len=20) :: nems_name - character(len=20) :: nems_levtyp - character(len=20) :: itrptyp - logical :: itrp_bilinear - logical :: itrp_nrstnghbr - real(nemsio_realkind), dimension(:,:), allocatable :: workgrid - real(nemsio_realkind), dimension(:), allocatable :: pk - real(nemsio_realkind), dimension(:), allocatable :: bk - real, dimension(:), allocatable :: sendbuffer,recvbuffer - integer :: fhour - integer :: ncoords - integer nems_lev,ndims,istatus,ncol,levs_fix - logical clip - - ! Define counting variables - - integer :: i, j, k, l,nlev,k2,k3,nrec - - !===================================================================== - - ! Define local variables - - call init_constants_derived() - call gfs_grid_initialize(gfs_grid) - - ! Loop through local variables - - if(mpi_procid .eq. mpi_masternode) then - print *,'variable table' - print *,'--------------' - open(912,file=trim(variable_table),form='formatted') - ntvars=0; n2dvar=0; n3dvar=0 - nrecs = 0 - loop_read: do while (istatus == 0) - read(912,199,iostat=istatus) var_name,nems_name,nems_levtyp,nems_lev,itrptyp,clip,ndims - if( istatus /= 0 ) exit loop_read - nrecs = nrecs + 1 - if(var_name(1:1) .ne. "#") then - ntvars = ntvars + 1 - ntvars = ntvars + 1 - if (ndims == 2) then - n2dvar = n2dvar+1 - else if (ndims == 3) then - n3dvar = n3dvar+1 - else - print *,'ndims must be 2 or 3 in variable_table.txt' - call mpi_abort(mpi_comm_world,-91,mpi_ierror) - stop - endif - !print *,'ntvars,n2dvar,n3dvar',ntvars,n2dvar,n3dvar - !write(6,199) var_name, nems_name,nems_levtyp,nems_lev,itrptyp,clip,ndims - endif - enddo loop_read - close(912) - print *,'nrecs,ntvars,n2dvar,n3dvar',nrecs,ntvars,n2dvar,n3dvar - endif - call mpi_bcast(nrecs,1,mpi_integer,mpi_masternode,mpi_comm_world,mpi_ierror) - call mpi_bcast(n2dvar,1,mpi_integer,mpi_masternode,mpi_comm_world,mpi_ierror) - call mpi_bcast(n3dvar,1,mpi_integer,mpi_masternode,mpi_comm_world,mpi_ierror) - call mpi_bcast(ntvars,1,mpi_integer,mpi_masternode,mpi_comm_world,mpi_ierror) - if (ntvars == 0) then - print *,'empty variable_table.txt!' - call mpi_interface_terminate() - stop - endif - allocate(var_info(ntvars)) - open(912,file=trim(variable_table),form='formatted') - k = 0 - nvvars = 0 ! number of vector variables - do nrec = 1, nrecs - read(912,199,iostat=istatus) var_name,nems_name,nems_levtyp,nems_lev,itrptyp,clip,ndims - if (var_name(1:1) .ne. "#") then - k = k + 1 - var_info(k)%var_name = var_name - var_info(k)%nems_name = nems_name - var_info(k)%nems_levtyp = nems_levtyp - var_info(k)%nems_lev = nems_lev - var_info(k)%itrptyp = itrptyp - if (itrptyp.EQ.'vector') then - nvvars=nvvars+1 - endif - var_info(k)%clip = clip - var_info(k)%ndims = ndims - if(mpi_procid .eq. mpi_masternode) then - write(6,199) var_info(k)%var_name, var_info(k)%nems_name,var_info(k)%nems_levtyp, & - var_info(k)%nems_lev,var_info(k)%itrptyp,var_info(k)%clip,var_info(k)%ndims - endif - endif - end do ! do k = 1, ntvars - ! assume vectors are in pairs - nvvars=nvvars/2 - call mpi_bcast(nvvars,1,mpi_integer,mpi_masternode,mpi_comm_world,mpi_ierror) - close(912) -199 format(a20,1x,a20,1x,a20,1x,i1,1x,a20,1x,l1,1x,i1) - allocate(var_info3d(n3dvar+2)) - allocate(var_info2d(n2dvar)) - k2 = 0 - k3 = 0 - do k=1,ntvars - if (var_info(k)%ndims == 2) then - k2 = k2 + 1 - var_info2d(k2) = var_info(k) - endif - if (var_info(k)%ndims == 3 .or. & - trim(var_info(k)%nems_name) == 'pres' .or. & - trim(var_info(k)%nems_name) == 'orog') then - k3 = k3 + 1 - var_info3d(k3) = var_info(k) - ! orography called 'hgt' in 3d file, not 'orog' - if (trim(var_info(k)%nems_name) == 'orog') then - var_info3d(k3)%nems_name = 'hgt ' - endif - endif - enddo - - - do i = 1, ngrids - anlygrd(i)%filename = analysis_filename(i) - anlygrd(i)%filename2d = analysis_filename2d(i) - call fv3_regrid_initialize(anlygrd(i)) - end do ! do i = 1, ngrids - - ! Define local variables - - ncxdim = anlygrd(1)%nx - ncydim = anlygrd(1)%ny - if (n3dvar > 0) then - nczdim = anlygrd(1)%nz - else - nczdim = 0 - endif - nctdim = anlygrd(1)%ntime - ncoords = ncxdim*ncydim - invar%ncoords = ncoords*ngrids - invar2%ncoords = ncoords*ngrids - outvar%ncoords = gfs_grid%ncoords - outvar2%ncoords = gfs_grid%ncoords - call interpolation_initialize_gridvar(invar) - call interpolation_initialize_gridvar(invar2) - call interpolation_initialize_gridvar(outvar) - call interpolation_initialize_gridvar(outvar2) - meta_nemsio3d%modelname = 'GFS' - meta_nemsio3d%version = 200509 - meta_nemsio3d%nrec = 2 + nczdim*n3dvar - meta_nemsio3d%nmeta = 5 - meta_nemsio3d%nmetavari = 3 - meta_nemsio3d%nmetaaryi = 1 - meta_nemsio3d%dimx = gfs_grid%nlons - meta_nemsio3d%dimy = gfs_grid%nlats - meta_nemsio3d%dimz = nczdim - meta_nemsio3d%jcap = ntrunc - meta_nemsio3d%nsoil = 4 - meta_nemsio3d%nframe = 0 - meta_nemsio3d%ntrac = 3 - meta_nemsio3d%idrt = 4 - meta_nemsio3d%ncldt = 3 - meta_nemsio3d%idvc = 2 - meta_nemsio3d%idvm = 2 - meta_nemsio3d%idsl = 1 - meta_nemsio3d%idate(1:6) = 0 - meta_nemsio3d%idate(7) = 1 - read(forecast_timestamp(9:10),'(i2)') meta_nemsio3d%idate(4) - read(forecast_timestamp(7:8), '(i2)') meta_nemsio3d%idate(3) - read(forecast_timestamp(5:6), '(i2)') meta_nemsio3d%idate(2) - read(forecast_timestamp(1:4), '(i4)') meta_nemsio3d%idate(1) - meta_nemsio2d = meta_nemsio3d - meta_nemsio2d%nrec = n2dvar - call mpi_barrier(mpi_comm_world,mpi_ierror) - call gfs_nems_meta_initialization(meta_nemsio2d,var_info2d,gfs_grid) - call gfs_nems_meta_initialization(meta_nemsio3d,var_info3d,gfs_grid) - - ! Allocate memory for local variables - - if(.not. allocated(fv3_var_2d) .and. n2dvar > 0) & - & allocate(fv3_var_2d(ngrids,ncxdim,ncydim)) - if (mpi_nprocs /= nczdim+1) then - call mpi_barrier(mpi_comm_world, mpi_ierror) - if (mpi_procid .eq. mpi_masternode) then - print *,'number of mpi tasks must be equal to number of levels + 1' - print *,'mpi procs = ',mpi_nprocs,' levels = ',nczdim - endif - call mpi_interface_terminate() - stop - endif - !print *,'allocate fv3_var_3d',ngrids,ncxdim,ncydim,nczdim,mpi_procid - if(.not. allocated(fv3_var_3d) .and. n3dvar > 0) & - & allocate(fv3_var_3d(ngrids,ncxdim,ncydim,nczdim)) - !print *,'done allocating fv3_var_3d',ngrids,ncxdim,ncydim,nczdim,mpi_procid - - ! Check local variable and proceed accordingly - - call mpi_barrier(mpi_comm_world,mpi_ierror) - if(mpi_procid .eq. mpi_masternode) then - - ! Allocate memory for local variables - - if (n3dvar > 0) then - if(.not. allocated(pk)) allocate(pk(nczdim+1)) - if(.not. allocated(bk)) allocate(bk(nczdim+1)) - - ! Define local variables - - if (trim(gfs_hyblevs_filename) == 'NOT USED' ) then - call netcdfio_values_1d(anlygrd(1)%filename,'pk',pk) - call netcdfio_values_1d(anlygrd(1)%filename,'bk',bk) - else - open(913,file=trim(gfs_hyblevs_filename),form='formatted') - read(913,*) ncol, levs_fix - if (levs_fix /= (nczdim+1) ) then - call mpi_barrier(mpi_comm_world, mpi_ierror) - print *,'levs in ', trim(gfs_hyblevs_filename), ' not equal to',(nczdim+1) - call mpi_interface_terminate() - stop - endif - do k=nczdim+1,1,-1 - read(913,*) pk(k),bk(k) - enddo - close(913) - endif - if (minval(pk) < -1.e10 .or. minval(bk) < -1.e10) then - print *,'pk,bk not found in netcdf file..' - meta_nemsio3d%vcoord = -9999._nemsio_realkind - else - ! Loop through local variable - - do k = 1, nczdim + 1 - - ! Define local variables - - meta_nemsio3d%vcoord((nczdim + 1) - k + 1,1,1) = pk(k) - meta_nemsio3d%vcoord((nczdim + 1) - k + 1,2,1) = bk(k) - - end do ! do k = 1, nczdim + 1 - endif - endif - - end if ! if(mpi_procid .eq. mpi_masternode) - - ! initialize/read in interpolation weight - - grid_bilin%filename = esmf_bilinear_filename - call interpolation_initialize_esmf(grid_bilin) - - grid_nn%filename = esmf_neareststod_filename - call interpolation_initialize_esmf(grid_nn) - - do l = 1, nctdim - - ncrec = l ! time level to read from netcdf file - - ! Define local variables - - call fv3_grid_fhour(anlygrd(1),meta_nemsio2d%nfhour) - call fv3_grid_fhour(anlygrd(1),meta_nemsio3d%nfhour) - meta_nemsio3d%nfminute = int(0.0) - meta_nemsio3d%nfsecondn = int(0.0) - meta_nemsio3d%nfsecondd = int(1.0) - meta_nemsio3d%fhour = meta_nemsio3d%nfhour - meta_nemsio2d%nfminute = int(0.0) - meta_nemsio2d%nfsecondn = int(0.0) - meta_nemsio2d%nfsecondd = int(1.0) - meta_nemsio2d%fhour = meta_nemsio2d%nfhour - - ! initialize nemsio file. - if(mpi_procid .eq. mpi_masternode) then - call gfs_nems_initialize(meta_nemsio2d, meta_nemsio3d) - end if - - ! wait here. - call mpi_barrier(mpi_comm_world,mpi_ierror) - - ! Loop through local variables - k2=1 - do k = 1, ntvars - nvvars - - ! Define local variables - - itrp_bilinear = .false. - itrp_nrstnghbr = .false. - - ! Do 2D variables. - - if(var_info(k2)%ndims .eq. 2) then - - ! Check local variable and proceed accordingly - - if(mpi_procid .eq. mpi_masternode) then - - ! Check local variable and proceed accordingly - - call fv3_grid_read(anlygrd(1:ngrids), var_info(k2)%var_name,.true.,.false.) - - call interpolation_define_gridvar(invar,ncxdim,ncydim, ngrids,fv3_var_2d) - if (trim(var_info(k2)%nems_name) == 'pres') then - ! interpolate in exner(pressure) - invar%var = (invar%var/stndrd_atmos_ps)**(rd_over_g*stndrd_atmos_lapse) - end if - - if(var_info(k2)%itrptyp .eq. 'bilinear') then - call interpolation_esmf(invar,outvar,grid_bilin, .false.) - end if - - if(var_info(k2)%itrptyp .eq. 'nrstnghbr') then - call interpolation_esmf(invar,outvar,grid_nn, .true.) - end if - - if (trim(var_info(k2)%nems_name) == 'pres') then - outvar%var = stndrd_atmos_ps*(outvar%var**(g_over_rd/stndrd_atmos_lapse)) - end if - - if(var_info(k2)%itrptyp .eq. 'vector') then - ! read in u winds - call fv3_grid_read(anlygrd(1:ngrids), var_info(k2)%var_name,.true.,.false.) - call interpolation_define_gridvar(invar,ncxdim,ncydim,ngrids,fv3_var_2d) - ! read in v winds - call fv3_grid_read(anlygrd(1:ngrids), var_info(k2+1)%var_name,.true.,.false.) - call interpolation_define_gridvar(invar2,ncxdim,ncydim,ngrids,fv3_var_2d) - call interpolation_esmf_vect(invar,invar2,grid_bilin,outvar,outvar2) - end if - - ! Clip variable to zero if desired. - if(var_info(k2)%clip) call variable_clip(outvar%var) - - ! Write to NEMSIO file. - call gfs_nems_write('2d',real(outvar%var), & - var_info(k2)%nems_name,var_info(k2)%nems_levtyp,var_info(k2)%nems_lev) - if (trim(var_info(k2)%nems_name) == 'pres' .or. & - trim(var_info(k2)%nems_name) == 'orog' .or. & - trim(var_info(k2)%nems_name) == 'hgt') then - ! write surface height and surface pressure to 3d file. - ! (surface height called 'orog' in nemsio bin4, 'hgt' in - ! grib) - if (trim(var_info(k2)%nems_name) == 'orog') then - call gfs_nems_write('3d',real(outvar%var), & - 'hgt ',var_info(k2)%nems_levtyp,1) - else - call gfs_nems_write('3d',real(outvar%var), & - var_info(k2)%nems_name,var_info(k2)%nems_levtyp,1) - endif - endif - if(var_info(k2)%itrptyp .eq. 'vector') then ! write v winds - call gfs_nems_write('2d',real(outvar2%var), & - var_info(k2+1)%nems_name,var_info(k2+1)%nems_levtyp,var_info(k2+1)%nems_lev) - endif - end if ! if(mpi_procid .eq. mpi_masternode) - - ! Define local variables - call mpi_barrier(mpi_comm_world,mpi_ierror) - - end if ! if(var_info(k2)%ndims .eq. 2) - - ! Do 3D variables. - - if(var_info(k2)%ndims .eq. 3) then - - ! read 3d grid on master node, send to other tasks - if(mpi_procid .eq. mpi_masternode) then - call fv3_grid_read(anlygrd(1:ngrids), var_info(k2)%var_name,.false.,.true.) - do nlev=1,nczdim - call mpi_send(fv3_var_3d(1,1,1,nlev),ngrids*ncxdim*ncydim,mpi_real,& - nlev,1,mpi_comm_world,mpi_errorstatus,mpi_ierror) - enddo - if(trim(adjustl(var_info(k2)%itrptyp)) .eq. 'vector') then ! winds - call mpi_barrier(mpi_comm_world,mpi_ierror) - call fv3_grid_read(anlygrd(1:ngrids), var_info(k2+1)%var_name,.false.,.true.) - do nlev=1,nczdim - call mpi_send(fv3_var_3d(1,1,1,nlev),ngrids*ncxdim*ncydim,mpi_real,& - nlev,1,mpi_comm_world,mpi_errorstatus,mpi_ierror) - enddo - endif - else if (mpi_procid .le. nczdim) then - ! do interpolation, one level on each task. - call mpi_recv(fv3_var_3d(1,1,1,mpi_procid),ngrids*ncxdim*ncydim,mpi_real,& - 0,1,mpi_comm_world,mpi_errorstatus,mpi_ierror) - - call interpolation_define_gridvar(invar,ncxdim,ncydim, ngrids,fv3_var_3d(:,:,:,mpi_procid)) - - if(var_info(k2)%itrptyp .eq. 'bilinear') then - call interpolation_esmf(invar,outvar,grid_bilin, .false.) - end if ! if(var_info(k2)%itrptyp .eq. 'bilinear') - - if(var_info(k2)%itrptyp .eq. 'nrstnghbr') then - call interpolation_esmf(invar,outvar,grid_nn, .true.) - end if ! if(var_info(k2)%itrptyp .eq. 'nrstnghbr') - - if(trim(adjustl(var_info(k2)%itrptyp)) .eq. 'vector') then ! winds - call mpi_barrier(mpi_comm_world,mpi_ierror) - call mpi_recv(fv3_var_3d(1,1,1,mpi_procid),ngrids*ncxdim*ncydim,mpi_real,& - 0,1,mpi_comm_world,mpi_errorstatus,mpi_ierror) - call interpolation_define_gridvar(invar2,ncxdim,ncydim,ngrids,fv3_var_3d(:,:,:,mpi_procid)) - call interpolation_esmf_vect(invar,invar2,grid_bilin,outvar,outvar2) - endif - - if(var_info(k2)%clip) call variable_clip(outvar%var(:)) - - end if ! if(mpi_procid .ne. mpi_masternode .and. & - ! mpi_procid .le. nczdim) - - ! gather results back on root node to write out. - - if (mpi_procid == mpi_masternode) then - ! receive one level of interpolated data on root task. - if (.not. allocated(workgrid)) allocate(workgrid(gfs_grid%ncoords,nczdim)) - if (.not. allocated(recvbuffer)) allocate(recvbuffer(gfs_grid%ncoords)) - do nlev=1,nczdim - call mpi_recv(recvbuffer,gfs_grid%ncoords,mpi_real,& - nlev,1,mpi_comm_world,mpi_errorstatus,mpi_ierror) - workgrid(:,nlev) = recvbuffer - enddo - deallocate(recvbuffer) - else - ! send one level of interpolated data to root task. - if (.not. allocated(sendbuffer)) allocate(sendbuffer(gfs_grid%ncoords)) - sendbuffer(:) = outvar%var(:) - call mpi_send(sendbuffer,gfs_grid%ncoords,mpi_real,& - 0,1,mpi_comm_world,mpi_errorstatus,mpi_ierror) - endif - - ! Write to NEMSIO file. - - if(mpi_procid .eq. mpi_masternode) then - - ! Loop through local variable - - do j = 1, nczdim - - ! Define local variables - - call gfs_nems_write('3d',workgrid(:,nczdim - j + 1), & - & var_info(k2)%nems_name,var_info(k2)%nems_levtyp, & - & j) - - end do ! do j = 1, nczdim - - end if ! if(mpi_procid .eq. mpi_masternode) - - if(trim(adjustl(var_info(k2)%itrptyp)) .eq. 'vector') then ! winds - if (mpi_procid == mpi_masternode) then - ! receive one level of interpolated data on root task. - if (.not. allocated(workgrid)) allocate(workgrid(gfs_grid%ncoords,nczdim)) - if (.not. allocated(recvbuffer)) allocate(recvbuffer(gfs_grid%ncoords)) - do nlev=1,nczdim - call mpi_recv(recvbuffer,gfs_grid%ncoords,mpi_real,& - nlev,1,mpi_comm_world,mpi_errorstatus,mpi_ierror) - workgrid(:,nlev) = recvbuffer - enddo - deallocate(recvbuffer) - else - ! send one level of interpolated data to root task. - if (.not. allocated(sendbuffer)) allocate(sendbuffer(gfs_grid%ncoords)) - sendbuffer(:) = outvar2%var(:) - call mpi_send(sendbuffer,gfs_grid%ncoords,mpi_real,& - 0,1,mpi_comm_world,mpi_errorstatus,mpi_ierror) - endif - - ! Write to NEMSIO file. - - if(mpi_procid .eq. mpi_masternode) then - - do j = 1, nczdim - - call gfs_nems_write('3d',workgrid(:,nczdim - j + 1), & - & var_info(k2+1)%nems_name,var_info(k2+1)%nems_levtyp, & - & j) - end do ! do j = 1, nczdim - - end if ! if(mpi_procid .eq. mpi_masternode) - endif - - ! wait here - - call mpi_barrier(mpi_comm_world,mpi_ierror) - - end if ! if(var_info(k2)%ndims .eq. 3) - if(var_info(k2)%itrptyp .eq. 'vector') then ! skip v record here - k2=k2+1 - endif - k2=k2+1 - end do ! do k = 1, ntvars - - ! Wait here. - - call mpi_barrier(mpi_comm_world,mpi_ierror) - - ! Finalize and cleanup - - if(mpi_procid .eq. mpi_masternode) then - call gfs_nems_finalize() - end if - call mpi_barrier(mpi_comm_world,mpi_ierror) - if(allocated(workgrid)) deallocate(workgrid) - - end do ! do l = 1, nctdim - - -!===================================================================== - - end subroutine fv3_regrid_nemsio - - !======================================================================= - - ! fv3_regrid_initialize.f90: - - !----------------------------------------------------------------------- - - subroutine fv3_regrid_initialize(grid) - - ! Define variables passed to routine - - implicit none - type(analysis_grid) :: grid - - !===================================================================== - - ! Define local variables - - call netcdfio_dimension(grid%filename,'grid_xt',grid%nx) - call netcdfio_dimension(grid%filename,'grid_yt',grid%ny) - if (n3dvar > 0) then - call netcdfio_dimension(grid%filename,'pfull',grid%nz) - else - grid%nz = 0 - endif - call netcdfio_dimension(grid%filename,'time',grid%ntime) - - !===================================================================== - - end subroutine fv3_regrid_initialize - - !======================================================================= - - ! fv3_grid_read.f90: - - !----------------------------------------------------------------------- - - subroutine fv3_grid_read(anlygrd,varname,is_2d,is_3d) - - ! Define variables passed to subroutine - - type(analysis_grid) :: anlygrd(ngrids) - character(len=20) :: varname - logical :: is_2d - logical :: is_3d - - ! Define counting variables - - integer :: i, j, k - - !===================================================================== - - ! Loop through local variable - - do k = 1, ngrids - - ! Check local variable and proceed accordingly - - if(debug) write(6,500) ncrec, k - if(is_2d) then - - ! Define local variables - - ! orog and psfc are in 3d file. - if (trim(varname) == 'orog' .or. trim(varname) == 'psfc') then - call netcdfio_values_2d(anlygrd(k)%filename,varname, & - & fv3_var_2d(k,:,:)) - else - call netcdfio_values_2d(anlygrd(k)%filename2d,varname, & - & fv3_var_2d(k,:,:)) - endif - - end if ! if(is_2d) - - ! Check local variable and proceed accordingly - - if(is_3d) then - - ! Define local variables - - call netcdfio_values_3d(anlygrd(k)%filename,varname, & - & fv3_var_3d(k,:,:,:)) - - end if ! if(is_3d) - - end do ! do k = 1, ngrids - - !===================================================================== - - ! Define format statements - -500 format('FV3_GRID_READ: Time record = ', i6, '; Cubed sphere face = ', & - & i1,'.') - - !===================================================================== - - end subroutine fv3_grid_read - - !======================================================================= - - ! fv3_grid_fhour.f90: - - !----------------------------------------------------------------------- - - subroutine fv3_grid_fhour(grid,fhour) - - ! Define variables passed to routine - - implicit none - type(analysis_grid) :: grid - integer :: fhour - - ! Define variables computed within routine - - real(nemsio_realkind) :: workgrid(grid%ntime) - real(nemsio_realkind) :: start_jday - real(nemsio_realkind) :: fcst_jday - integer :: year - integer :: month - integer :: day - integer :: hour - integer :: minute - integer :: second, iw3jdn - character(len=80) timeunits - - !===================================================================== - - ! Define local variables - - read(forecast_timestamp(1:4), '(i4)') year - read(forecast_timestamp(5:6), '(i2)') month - read(forecast_timestamp(7:8), '(i2)') day - read(forecast_timestamp(9:10),'(i2)') hour - minute = 0; second = 0 - - ! Compute local variables - - ! 'flux day' (days since dec 31 1900) - !call date2wnday(start_jday,year,month,day) - ! same as above, but valid after 2099 - start_jday=real(iw3jdn(year,month,day)-iw3jdn(1900,12,31)) - start_jday = start_jday + real(hour)/24.0 + real(minute)/1440.0 + & - & real(second)/86400.0 - - ! Define local variables - - call netcdfio_values_1d(grid%filename,'time',workgrid) - call netcdfio_variable_attr(grid%filename,'time','units',timeunits) - - ! Compute local variables - - ! ncrec is a global variable in the netcdfio-interface module - if (timeunits(1:4) == 'days') then - fcst_jday = start_jday + workgrid(ncrec) - else if (timeunits(1:5) == 'hours') then - fcst_jday = start_jday + workgrid(ncrec)/24. - else if (timeunits(1:7) == 'seconds') then - fcst_jday = start_jday + workgrid(ncrec)/86400.0 - else - print *,'unrecognized time units',trim(timeunits) - call mpi_interface_terminate() - stop - endif - fhour = nint((86400*(fcst_jday - start_jday))/3600.0) - - !===================================================================== - - end subroutine fv3_grid_fhour - -! SUBROUTINE DATE2WNDAY(WDAY, IYR,MON,IDY) -! IMPLICIT NONE -! INTEGER IYR,MON,IDY -! REAL WDAY -!! -!!********** -!!* -!! 1) CONVERT DATE INTO 'FLUX DAY'. -!! -!! 2) THE 'FLUX DAY' IS THE NUMBER OF DAYS SINCE 001/1901 (WHICH IS -!! FLUX DAY 1.0). -!! FOR EXAMPLE: -!! A) IYR=1901,MON=1,IDY=1, REPRESENTS 0000Z HRS ON 01/01/1901 -!! SO WDAY WOULD BE 1.0. -!! A) IYR=1901,MON=1,IDY=2, REPRESENTS 0000Z HRS ON 02/01/1901 -!! SO WDAY WOULD BE 2.0. -!! YEAR MUST BE NO LESS THAN 1901.0, AND NO GREATER THAN 2099.0. -!! NOTE THAT YEAR 2000 IS A LEAP YEAR (BUT 1900 AND 2100 ARE NOT). -!! -!! 3) ALAN J. WALLCRAFT, NAVAL RESEARCH LABORATORY, JULY 2002. -!!* -!!********** -!! -! INTEGER NLEAP -! REAL WDAY1 -! REAL MONTH(13) -! DATA MONTH / 0, 31, 59, 90, 120, 151, 181, & -! 212, 243, 273, 304, 334, 365 / -!! FIND THE RIGHT YEAR. -! NLEAP = (IYR-1901)/4 -! WDAY = 365.0*(IYR-1901) + NLEAP + MONTH(MON) + IDY -! IF (MOD(IYR,4).EQ.0 .AND. MON.GT.2) THEN -! WDAY = WDAY + 1.0 -! ENDIF -! END SUBROUTINE DATE2WNDAY - - !======================================================================= - -end module fv3_interface diff --git a/sorc/regrid_nemsio.fd/gfs_nems_interface.f90 b/sorc/regrid_nemsio.fd/gfs_nems_interface.f90 deleted file mode 100644 index aa1305dc01..0000000000 --- a/sorc/regrid_nemsio.fd/gfs_nems_interface.f90 +++ /dev/null @@ -1,595 +0,0 @@ -module gfs_nems_interface - - !======================================================================= - - ! Define associated modules and subroutines - - !----------------------------------------------------------------------- - - use constants - use kinds - - !----------------------------------------------------------------------- - - use interpolation_interface - use mpi_interface - use namelist_def - use nemsio_module - use netcdfio_interface - use variable_interface - - !----------------------------------------------------------------------- - - implicit none - - !----------------------------------------------------------------------- - - ! Define all data and structure types for routine; these variables - ! are variables required by the subroutines within this module - - type gfs_grid - real(r_kind), dimension(:,:), allocatable :: rlon - real(r_kind), dimension(:,:), allocatable :: rlat - integer :: ncoords - integer :: nlons - integer :: nlats - integer :: nz - end type gfs_grid ! type gfs_grid - - type nemsio_meta - character(nemsio_charkind), dimension(:), allocatable :: recname - character(nemsio_charkind), dimension(:), allocatable :: reclevtyp - character(nemsio_charkind), dimension(:), allocatable :: variname - character(nemsio_charkind), dimension(:), allocatable :: varr8name - character(nemsio_charkind), dimension(:), allocatable :: aryiname - character(nemsio_charkind), dimension(:), allocatable :: aryr8name - character(nemsio_charkind8) :: gdatatype - character(nemsio_charkind8) :: modelname - real(nemsio_realkind), dimension(:,:,:), allocatable :: vcoord - real(nemsio_realkind), dimension(:), allocatable :: lon - real(nemsio_realkind), dimension(:), allocatable :: lat - integer(nemsio_intkind), dimension(:,:), allocatable :: aryival - integer(nemsio_intkind), dimension(:), allocatable :: reclev - integer(nemsio_intkind), dimension(:), allocatable :: varival - integer(nemsio_intkind), dimension(:), allocatable :: aryilen - integer(nemsio_intkind), dimension(:), allocatable :: aryr8len - integer(nemsio_intkind) :: idate(7) - integer(nemsio_intkind) :: version - integer(nemsio_intkind) :: nreo_vc - integer(nemsio_intkind) :: nrec - integer(nemsio_intkind) :: nmeta - integer(nemsio_intkind) :: nmetavari - integer(nemsio_intkind) :: nmetaaryi - integer(nemsio_intkind) :: nfhour - integer(nemsio_intkind) :: nfminute - integer(nemsio_intkind) :: nfsecondn - integer(nemsio_intkind) :: nfsecondd - integer(nemsio_intkind) :: jcap - integer(nemsio_intkind) :: dimx - integer(nemsio_intkind) :: dimy - integer(nemsio_intkind) :: dimz - integer(nemsio_intkind) :: nframe - integer(nemsio_intkind) :: nsoil - integer(nemsio_intkind) :: ntrac - integer(nemsio_intkind) :: ncldt - integer(nemsio_intkind) :: idvc - integer(nemsio_intkind) :: idsl - integer(nemsio_intkind) :: idvm - integer(nemsio_intkind) :: idrt - integer(nemsio_intkind) :: fhour - end type nemsio_meta ! type nemsio_meta - - !----------------------------------------------------------------------- - - ! Define global variables - - type(nemsio_gfile) :: gfile2d,gfile3d - integer :: nemsio_iret - - !----------------------------------------------------------------------- - - ! Define interfaces and attributes for module routines - - private - public :: gfs_grid_initialize - public :: gfs_grid_cleanup - public :: gfs_grid - public :: gfs_nems_meta_initialization - public :: gfs_nems_meta_cleanup - public :: gfs_nems_initialize - public :: gfs_nems_finalize - public :: gfs_nems_write - public :: nemsio_meta - -contains - - !======================================================================= - - ! gfs_nems_write.f90: - - !----------------------------------------------------------------------- - - subroutine gfs_nems_write(c2dor3d,nems_data,nems_varname,nems_levtyp,nems_lev) - - ! Define variables passed to routine - - character(nemsio_charkind) :: nems_varname - character(nemsio_charkind) :: nems_levtyp - real(nemsio_realkind) :: nems_data(:) - integer(nemsio_intkind) :: nems_lev - character(len=2) :: c2dor3d - - !===================================================================== - - ! Define local variables - - if (c2dor3d == '2d') then - call nemsio_writerecv(gfile2d,trim(adjustl(nems_varname)),levtyp= & - & trim(adjustl(nems_levtyp)),lev=nems_lev,data=nems_data, & - & iret=nemsio_iret) - else if (c2dor3d == '3d') then - call nemsio_writerecv(gfile3d,trim(adjustl(nems_varname)),levtyp= & - & trim(adjustl(nems_levtyp)),lev=nems_lev,data=nems_data, & - & iret=nemsio_iret) - else - nemsio_iret=-99 - endif - - ! Check local variable and proceed accordingly - - if(debug) write(6,500) c2dor3d,trim(adjustl(nems_varname)), nemsio_iret, & - & nems_lev, minval(nems_data), maxval(nems_data) - - !===================================================================== - - ! Define format statements - -500 format('GFS_NEMS_WRITE',a2,': NEMS I/O name = ', a, '; writerecv return ', & - & 'code = ', i5,'; level = ', i3, '; (min,max) = (', f13.5,f13.5, & - & ').') - if (nemsio_iret /= 0) then - print *,'nemsio_writerecv failed, stopping...' - call mpi_interface_terminate() - stop - endif - - !===================================================================== - - end subroutine gfs_nems_write - - !======================================================================= - - ! gfs_nems_meta_initialization.f90: - - !----------------------------------------------------------------------- - - subroutine gfs_nems_meta_initialization(meta_nemsio,var_info,grid) - - ! Define variables passed to routine - - type(nemsio_meta) :: meta_nemsio - type(varinfo) :: var_info(:) - type(gfs_grid) :: grid - - ! Define variables computed within routine - - integer :: offset - integer :: n2dvar - integer :: n3dvar - - ! Define counting variables - - integer :: i, j, k - - !===================================================================== - - ! Allocate memory for local variables - - if(.not. allocated(meta_nemsio%recname)) & - & allocate(meta_nemsio%recname(meta_nemsio%nrec)) - if(.not. allocated(meta_nemsio%reclevtyp)) & - & allocate(meta_nemsio%reclevtyp(meta_nemsio%nrec)) - if(.not. allocated(meta_nemsio%reclev)) & - & allocate(meta_nemsio%reclev(meta_nemsio%nrec)) - if(.not. allocated(meta_nemsio%variname)) & - & allocate(meta_nemsio%variname(meta_nemsio%nmetavari)) - if(.not. allocated(meta_nemsio%varival)) & - & allocate(meta_nemsio%varival(meta_nemsio%nmetavari)) - if(.not. allocated(meta_nemsio%aryiname)) & - & allocate(meta_nemsio%aryiname(meta_nemsio%nmetaaryi)) - if(.not. allocated(meta_nemsio%aryilen)) & - & allocate(meta_nemsio%aryilen(meta_nemsio%nmetaaryi)) - if(.not. allocated(meta_nemsio%vcoord)) & - & allocate(meta_nemsio%vcoord(meta_nemsio%dimz+1,3,2)) - if(.not. allocated(meta_nemsio%aryival)) & - & allocate(meta_nemsio%aryival(grid%nlats/2, & - & meta_nemsio%nmetaaryi)) - if(.not. allocated(meta_nemsio%lon)) & - & allocate(meta_nemsio%lon(grid%ncoords)) - if(.not. allocated(meta_nemsio%lat)) & - & allocate(meta_nemsio%lat(grid%ncoords)) - meta_nemsio%vcoord(:,:,:)=0.0 - ! Define local variables - - meta_nemsio%lon = & - & reshape(grid%rlon,(/grid%ncoords/)) - meta_nemsio%lat = & - & reshape(grid%rlat,(/grid%ncoords/)) - meta_nemsio%aryilen(1) = grid%nlats/2 - meta_nemsio%aryiname(1) = 'lpl' - meta_nemsio%aryival(1:grid%nlats/2,1) = grid%nlons - k = 0 - - ! Loop through local variable - offset = 0 - n3dvar = 0 - n2dvar = 0 - - - do i = 1, size(var_info) - - ! Check local variable and proceed accordingly - - if(var_info(i)%ndims .eq. 2) then - - ! Define local variables - - k = k + 1 - meta_nemsio%reclev(k) = var_info(i)%nems_lev - meta_nemsio%recname(k) = trim(adjustl(var_info(i)%nems_name)) - meta_nemsio%reclevtyp(k) = trim(adjustl(var_info(i)%nems_levtyp)) - n2dvar = k - - else if(var_info(i)%ndims .eq. 3) then - - ! Loop through local variable - - meta_nemsio%variname(1) = 'LEVS' - meta_nemsio%varival(1) = meta_nemsio%dimz - meta_nemsio%variname(2) = 'NVCOORD' - meta_nemsio%varival(2) = 2 - meta_nemsio%variname(3) = 'IVS' - meta_nemsio%varival(3) = 200509 - do k = 1, meta_nemsio%dimz - - ! Define local variables - - meta_nemsio%reclev(k+n2dvar+offset) = k - meta_nemsio%recname(k+n2dvar+offset) = & - & trim(adjustl(var_info(i)%nems_name)) - meta_nemsio%reclevtyp(k+n2dvar+offset) = & - & trim(adjustl(var_info(i)%nems_levtyp)) - - end do ! do k = 1, nczdim - - ! Define local variables - - n3dvar = n3dvar + 1 - offset = nczdim*n3dvar - - end if ! if(var_info(i)%ndims .eq. 3) - - end do ! do i = 1, size(var_info) - - !===================================================================== - - end subroutine gfs_nems_meta_initialization - - !======================================================================= - - ! gfs_nems_meta_cleanup.f90: - - !----------------------------------------------------------------------- - - subroutine gfs_nems_meta_cleanup(meta_nemsio2d,meta_nemsio3d) - - ! Define variables passed to routine - - type(nemsio_meta) :: meta_nemsio2d,meta_nemsio3d - - !===================================================================== - - ! Deallocate memory for local variables - - if(allocated(meta_nemsio2d%recname)) & - & deallocate(meta_nemsio2d%recname) - if(allocated(meta_nemsio2d%reclevtyp)) & - & deallocate(meta_nemsio2d%reclevtyp) - if(allocated(meta_nemsio2d%reclev)) & - & deallocate(meta_nemsio2d%reclev) - if(allocated(meta_nemsio2d%variname)) & - & deallocate(meta_nemsio2d%variname) - if(allocated(meta_nemsio2d%aryiname)) & - & deallocate(meta_nemsio2d%aryiname) - if(allocated(meta_nemsio2d%aryival)) & - & deallocate(meta_nemsio2d%aryival) - if(allocated(meta_nemsio2d%aryilen)) & - & deallocate(meta_nemsio2d%aryilen) - if(allocated(meta_nemsio2d%vcoord)) & - & deallocate(meta_nemsio2d%vcoord) - if(allocated(meta_nemsio2d%lon)) & - & deallocate(meta_nemsio2d%lon) - if(allocated(meta_nemsio2d%lat)) & - & deallocate(meta_nemsio2d%lat) - if(allocated(meta_nemsio3d%recname)) & - & deallocate(meta_nemsio3d%recname) - if(allocated(meta_nemsio3d%reclevtyp)) & - & deallocate(meta_nemsio3d%reclevtyp) - if(allocated(meta_nemsio3d%reclev)) & - & deallocate(meta_nemsio3d%reclev) - if(allocated(meta_nemsio3d%variname)) & - & deallocate(meta_nemsio3d%variname) - if(allocated(meta_nemsio3d%aryiname)) & - & deallocate(meta_nemsio3d%aryiname) - if(allocated(meta_nemsio3d%aryival)) & - & deallocate(meta_nemsio3d%aryival) - if(allocated(meta_nemsio3d%aryilen)) & - & deallocate(meta_nemsio3d%aryilen) - if(allocated(meta_nemsio3d%vcoord)) & - & deallocate(meta_nemsio3d%vcoord) - if(allocated(meta_nemsio3d%lon)) & - & deallocate(meta_nemsio3d%lon) - if(allocated(meta_nemsio3d%lat)) & - & deallocate(meta_nemsio3d%lat) - - !===================================================================== - - end subroutine gfs_nems_meta_cleanup - - !======================================================================= - - ! gfs_nems_initialize.f90: - - !----------------------------------------------------------------------- - - subroutine gfs_nems_initialize(meta_nemsio2d, meta_nemsio3d) - - ! Define variables passed to routine - - type(nemsio_meta) :: meta_nemsio2d,meta_nemsio3d - character(len=500) :: filename - character(len=7) :: suffix - - !===================================================================== - - ! Define local variables - - call nemsio_init(iret=nemsio_iret) - write(suffix,500) meta_nemsio2d%nfhour - filename = trim(adjustl(datapathout2d))//suffix - meta_nemsio2d%gdatatype = trim(adjustl(nemsio_opt2d)) - meta_nemsio3d%gdatatype = trim(adjustl(nemsio_opt3d)) - call nemsio_open(gfile2d,trim(adjustl(filename)),'write', & - & iret=nemsio_iret, & - & modelname=trim(adjustl(meta_nemsio2d%modelname)), & - & version=meta_nemsio2d%version, & - & gdatatype=meta_nemsio2d%gdatatype, & - & jcap=meta_nemsio2d%jcap, & - & dimx=meta_nemsio2d%dimx, & - & dimy=meta_nemsio2d%dimy, & - & dimz=meta_nemsio2d%dimz, & - & idate=meta_nemsio2d%idate, & - & nrec=meta_nemsio2d%nrec, & - & nframe=meta_nemsio2d%nframe, & - & idrt=meta_nemsio2d%idrt, & - & ncldt=meta_nemsio2d%ncldt, & - & idvc=meta_nemsio2d%idvc, & - & idvm=meta_nemsio2d%idvm, & - & idsl=meta_nemsio2d%idsl, & - & nfhour=meta_nemsio2d%fhour, & - & nfminute=meta_nemsio2d%nfminute, & - & nfsecondn=meta_nemsio2d%nfsecondn, & - & nfsecondd=meta_nemsio2d%nfsecondd, & - & extrameta=.true., & - & nmetaaryi=meta_nemsio2d%nmetaaryi, & - & recname=meta_nemsio2d%recname, & - & reclevtyp=meta_nemsio2d%reclevtyp, & - & reclev=meta_nemsio2d%reclev, & - & aryiname=meta_nemsio2d%aryiname, & - & aryilen=meta_nemsio2d%aryilen, & - & aryival=meta_nemsio2d%aryival, & - & vcoord=meta_nemsio2d%vcoord) - write(suffix,500) meta_nemsio3d%nfhour - filename = trim(adjustl(datapathout3d))//suffix - call nemsio_open(gfile3d,trim(adjustl(filename)),'write', & - & iret=nemsio_iret, & - & modelname=trim(adjustl(meta_nemsio3d%modelname)), & - & version=meta_nemsio3d%version, & - & gdatatype=meta_nemsio3d%gdatatype, & - & jcap=meta_nemsio3d%jcap, & - & dimx=meta_nemsio3d%dimx, & - & dimy=meta_nemsio3d%dimy, & - & dimz=meta_nemsio3d%dimz, & - & idate=meta_nemsio3d%idate, & - & nrec=meta_nemsio3d%nrec, & - & nframe=meta_nemsio3d%nframe, & - & idrt=meta_nemsio3d%idrt, & - & ncldt=meta_nemsio3d%ncldt, & - & idvc=meta_nemsio3d%idvc, & - & idvm=meta_nemsio3d%idvm, & - & idsl=meta_nemsio3d%idsl, & - & nfhour=meta_nemsio3d%fhour, & - & nfminute=meta_nemsio3d%nfminute, & - & nfsecondn=meta_nemsio3d%nfsecondn, & - & nfsecondd=meta_nemsio3d%nfsecondd, & - & extrameta=.true., & - & nmetaaryi=meta_nemsio3d%nmetaaryi, & - & recname=meta_nemsio3d%recname, & - & reclevtyp=meta_nemsio3d%reclevtyp, & - & reclev=meta_nemsio3d%reclev, & - & aryiname=meta_nemsio3d%aryiname, & - & aryilen=meta_nemsio3d%aryilen, & - & aryival=meta_nemsio3d%aryival, & - & variname=meta_nemsio3d%variname, & - & varival=meta_nemsio3d%varival, & - & nmetavari=meta_nemsio3d%nmetavari, & - & vcoord=meta_nemsio3d%vcoord) - - !===================================================================== - - ! Define format statements - -500 format('.fhr',i3.3) - - !===================================================================== - - end subroutine gfs_nems_initialize - - !======================================================================= - - ! gfs_nems_finalize.f90: - - !----------------------------------------------------------------------- - - subroutine gfs_nems_finalize() - - !===================================================================== - - ! Define local variables - - call nemsio_close(gfile2d,iret=nemsio_iret) - call nemsio_close(gfile3d,iret=nemsio_iret) - - !===================================================================== - - end subroutine gfs_nems_finalize - - !======================================================================= - - ! gfs_grid_initialize.f90: - - !----------------------------------------------------------------------- - - subroutine gfs_grid_initialize(grid) - - ! Define variables passed to routine - - type(gfs_grid) :: grid - - ! Define variables computed within routine - - real(r_kind), dimension(:), allocatable :: slat - real(r_kind), dimension(:), allocatable :: wlat - real(r_kind), dimension(:), allocatable :: workgrid - - ! Define counting variables - - integer :: i, j, k - - !===================================================================== - - ! Check local variable and proceed accordingly - - if(mpi_procid .eq. mpi_masternode) then - - ! Define local variables - - call init_constants_derived() - - ! Check local variable and proceed accordingly - - ! Define local variables - - grid%nlons = nlons - grid%nlats = nlats - - end if ! if(mpi_procid .eq. mpi_masternode) - - ! Define local variables - - call mpi_barrier(mpi_comm_world,mpi_ierror) - - ! Broadcast all necessary variables to compute nodes - - call mpi_bcast(grid%nlons,1,mpi_integer,mpi_masternode,mpi_comm_world, & - & mpi_ierror) - call mpi_bcast(grid%nlats,1,mpi_integer,mpi_masternode,mpi_comm_world, & - & mpi_ierror) - - ! Allocate memory for local variables - - if(.not. allocated(grid%rlon)) & - & allocate(grid%rlon(grid%nlons,grid%nlats)) - if(.not. allocated(grid%rlat)) & - & allocate(grid%rlat(grid%nlons,grid%nlats)) - - ! Check local variable and proceed accordingly - - if(mpi_procid .eq. mpi_masternode) then - - ! Allocate memory for local variables - - if(.not. allocated(slat)) allocate(slat(grid%nlats)) - if(.not. allocated(wlat)) allocate(wlat(grid%nlats)) - if(.not. allocated(workgrid)) allocate(workgrid(grid%nlats)) - - ! Compute local variables - - grid%ncoords = grid%nlons*grid%nlats - call splat(grid%nlats,slat,wlat) - workgrid = acos(slat) - pi/2.0 - - ! Loop through local variable - - do j = 1, grid%nlats - - ! Loop through local variable - - do i = 1, grid%nlons - - ! Compute local variables - - grid%rlon(i,j) = (i-1)*(360./grid%nlons)*deg2rad - grid%rlat(i,j) = workgrid(grid%nlats - j + 1) - - end do ! do i = 1, grid%nlons - - end do ! do j = 1, grid%nlats - - ! Deallocate memory for local variables - - if(allocated(slat)) deallocate(slat) - if(allocated(wlat)) deallocate(wlat) - if(allocated(workgrid)) deallocate(workgrid) - - endif ! if(mpi_procid .eq. mpi_masternode) - - ! Broadcast all necessary variables to compute nodes - - call mpi_bcast(grid%ncoords,1,mpi_integer,mpi_masternode, & - & mpi_comm_world,mpi_ierror) - call mpi_bcast(grid%rlon,grid%ncoords,mpi_real,mpi_masternode, & - & mpi_comm_world,mpi_ierror) - call mpi_bcast(grid%rlat,grid%ncoords,mpi_real,mpi_masternode, & - & mpi_comm_world,mpi_ierror) - - !===================================================================== - - end subroutine gfs_grid_initialize - - !======================================================================= - - ! gfs_grid_cleanup.f90: - - !----------------------------------------------------------------------- - - subroutine gfs_grid_cleanup(grid) - - ! Define variables passed to routine - - type(gfs_grid) :: grid - - !===================================================================== - - ! Deallocate memory for local variables - - if(allocated(grid%rlon)) deallocate(grid%rlon) - if(allocated(grid%rlat)) deallocate(grid%rlat) - - !===================================================================== - - end subroutine gfs_grid_cleanup - - !======================================================================= - -end module gfs_nems_interface diff --git a/sorc/regrid_nemsio.fd/interpolation_interface.f90 b/sorc/regrid_nemsio.fd/interpolation_interface.f90 deleted file mode 100644 index 775d1a7cc3..0000000000 --- a/sorc/regrid_nemsio.fd/interpolation_interface.f90 +++ /dev/null @@ -1,335 +0,0 @@ -module interpolation_interface - - !======================================================================= - - ! Define associated modules and subroutines - - !----------------------------------------------------------------------- - - use constants - use kinds - - !----------------------------------------------------------------------- - - use namelist_def - use netcdf - use netcdfio_interface - use mpi_interface - - !----------------------------------------------------------------------- - - implicit none - - !----------------------------------------------------------------------- - - ! Define interfaces and attributes for module routines - - private - public :: interpolation_initialize_gridvar - public :: interpolation_initialize_esmf - public :: interpolation_define_gridvar - public :: interpolation_define_gridvar_out - public :: interpolation_esmf - public :: interpolation_esmf_vect - public :: gridvar - public :: esmfgrid - - !----------------------------------------------------------------------- - - ! Define all data and structure types for routine; these variables - ! are variables required by the subroutines within this module - - type esmfgrid - character(len=500) :: filename - real(r_double), dimension(:), allocatable :: s - integer, dimension(:), allocatable :: col - integer, dimension(:), allocatable :: row - real(r_double), dimension(:), allocatable :: inlats - real(r_double), dimension(:), allocatable :: inlons - real(r_double), dimension(:), allocatable :: outlats - real(r_double), dimension(:), allocatable :: outlons - integer :: n_s,n_a,n_b - end type esmfgrid ! type esmfgrid - - type gridvar - logical, dimension(:), allocatable :: check - real(r_double), dimension(:), allocatable :: var - integer :: ncoords - integer :: nx - integer :: ny - end type gridvar ! type gridvar - - ! Define global variables - - integer :: ncfileid - integer :: ncvarid - integer :: ncdimid - integer :: ncstatus - - !----------------------------------------------------------------------- - -contains - - !======================================================================= - - subroutine interpolation_define_gridvar(grid,xdim,ydim,ngrid,input) -! collapses the cubed grid into a 1-d array -! Define variables passed to routine - - use nemsio_module, only: nemsio_realkind - integer,intent(in) :: ngrid - integer,intent(in) :: xdim,ydim - type(gridvar),intent(inout) :: grid - real(nemsio_realkind),intent(in) :: input(ngrid,xdim,ydim) - -! locals - integer :: i,j,k,ncount - - ncount = 1 - do k = 1, ngrid - do j = 1, ydim - do i = 1, xdim - grid%var(ncount) = input(k,i,j) - ncount = ncount + 1 - end do - end do - end do - - - end subroutine interpolation_define_gridvar - -!======================================================================= - - - subroutine interpolation_define_gridvar_out(grid,xdim,ydim,output) -! make a 2-d array for output - ! Define variables passed to routine - - integer,intent(in) :: xdim,ydim - type(gridvar),intent(in) :: grid - real(r_double),intent(out) :: output(xdim,ydim) - -! locals - integer :: i,j,ncount - - ncount = 1 - do j = 1, ydim - do i = 1, xdim - output(j,i) = grid%var(ncount) - ncount = ncount + 1 - enddo - enddo - - end subroutine interpolation_define_gridvar_out - - !======================================================================= - - subroutine interpolation_initialize_gridvar(grid) - - ! Define variables passed to routine - - type(gridvar) :: grid - - allocate(grid%var(grid%ncoords)) - - end subroutine interpolation_initialize_gridvar - - -!======================================================================= - - subroutine interpolation_initialize_esmf(grid) - - ! Define variables passed to routine - - type(esmfgrid) :: grid - - !===================================================================== - - ! Define local variables - - ncstatus = nf90_open(path=trim(adjustl(grid%filename)),mode= & - & nf90_nowrite,ncid=ncfileid) - ncstatus = nf90_inq_dimid(ncfileid,'n_s',ncdimid) - ncstatus = nf90_inquire_dimension(ncfileid,ncdimid,len=grid%n_s) - ncstatus = nf90_inq_dimid(ncfileid,'n_a',ncdimid) - ncstatus = nf90_inquire_dimension(ncfileid,ncdimid,len=grid%n_a) - ncstatus = nf90_inq_dimid(ncfileid,'n_b',ncdimid) - ncstatus = nf90_inquire_dimension(ncfileid,ncdimid,len=grid%n_b) - - - ! Allocate memory for local variables - - allocate(grid%s(grid%n_s)) - allocate(grid%row(grid%n_s)) - allocate(grid%col(grid%n_s)) - - allocate(grid%inlats(grid%n_a)) - allocate(grid%inlons(grid%n_a)) - allocate(grid%outlats(grid%n_b)) - allocate(grid%outlons(grid%n_b)) - - ncstatus = nf90_inq_varid(ncfileid,'col',ncvarid) - ncstatus = nf90_get_var(ncfileid,ncvarid,grid%col) - ncstatus = nf90_inq_varid(ncfileid,'row',ncvarid) - ncstatus = nf90_get_var(ncfileid,ncvarid,grid%row) - ncstatus = nf90_inq_varid(ncfileid,'S',ncvarid) - ncstatus = nf90_get_var(ncfileid,ncvarid,grid%s) - ncstatus = nf90_inq_varid(ncfileid,'yc_a',ncvarid) - ncstatus = nf90_get_var(ncfileid,ncvarid,grid%inlats) - ncstatus = nf90_inq_varid(ncfileid,'xc_a',ncvarid) - ncstatus = nf90_get_var(ncfileid,ncvarid,grid%inlons) - where(grid%inlons .LT. 0.0) - grid%inlons=360+grid%inlons - endwhere - ncstatus = nf90_inq_varid(ncfileid,'yc_b',ncvarid) - ncstatus = nf90_get_var(ncfileid,ncvarid,grid%outlats) - ncstatus = nf90_inq_varid(ncfileid,'xc_b',ncvarid) - ncstatus = nf90_get_var(ncfileid,ncvarid,grid%outlons) - ncstatus = nf90_close(ncfileid) - - !===================================================================== - - end subroutine interpolation_initialize_esmf - - -!======================================================================= - - - subroutine interpolation_esmf(invar,outvar,grid,is_nrstnghbr) - - ! Define variables passed to routine - - type(gridvar) :: invar - type(gridvar) :: outvar - logical :: is_nrstnghbr - - type(esmfgrid) :: grid - - integer :: i, j, k, l - - outvar%var = dble(0.0) - - if(is_nrstnghbr) then - do i = 1, grid%n_s - outvar%var(grid%row(i)) = invar%var(grid%col(i)) - enddo - else - do i = 1, grid%n_s - outvar%var(grid%row(i)) = outvar%var(grid%row(i)) + grid%s(i)*invar%var(grid%col(i)) - end do - end if - - end subroutine interpolation_esmf -!===================================================================== - - subroutine interpolation_esmf_vect(invaru,invarv,grid,outvaru,outvarv) - - ! Define variables passed to routine - - type(gridvar) :: invaru,invarv - type(gridvar) :: outvaru,outvarv - type(esmfgrid) :: grid - - integer :: i, j, k, l - real(r_double) :: cxy,sxy,urot,vrot - - - outvaru%var = dble(0.0) - outvarv%var = dble(0.0) - - do i = 1, grid%n_s - CALL MOVECT(grid%inlats(grid%col(i)),grid%inlons(grid%col(i)),& - grid%outlats(grid%row(i)),grid%outlons(grid%row(i)),& - cxy,sxy) - urot=cxy*invaru%var(grid%col(i))-sxy*invarv%var(grid%col(i)) - vrot=sxy*invaru%var(grid%col(i))+cxy*invarv%var(grid%col(i)) - outvaru%var(grid%row(i)) = outvaru%var(grid%row(i)) + grid%s(i)*urot - outvarv%var(grid%row(i)) = outvarv%var(grid%row(i)) + grid%s(i)*vrot - - end do - - end subroutine interpolation_esmf_vect - -!===================================================================== - - SUBROUTINE MOVECT(FLAT,FLON,TLAT,TLON,CROT,SROT) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: MOVECT MOVE A VECTOR ALONG A GREAT CIRCLE -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-04-10 -! -! ABSTRACT: THIS SUBPROGRAM PROVIDES THE ROTATION PARAMETERS -! TO MOVE A VECTOR ALONG A GREAT CIRCLE FROM ONE -! POSITION TO ANOTHER WHILE CONSERVING ITS ORIENTATION -! WITH RESPECT TO THE GREAT CIRCLE. THESE ROTATION -! PARAMETERS ARE USEFUL FOR VECTOR INTERPOLATION. -! -! PROGRAM HISTORY LOG: -! 96-04-10 IREDELL -! 1999-04-08 IREDELL GENERALIZE PRECISION -! -! USAGE: CALL MOVECT(FLAT,FLON,TLAT,TLON,CROT,SROT) -! -! INPUT ARGUMENT LIST: -! FLAT - REAL LATITUDE IN DEGREES FROM WHICH TO MOVE THE VECTOR -! FLON - REAL LONGITUDE IN DEGREES FROM WHICH TO MOVE THE VECTOR -! TLAT - REAL LATITUDE IN DEGREES TO WHICH TO MOVE THE VECTOR -! TLON - REAL LONGITUDE IN DEGREES TO WHICH TO MOVE THE VECTOR -! -! OUTPUT ARGUMENT LIST: -! CROT - REAL CLOCKWISE VECTOR ROTATION COSINE -! SROT - REAL CLOCKWISE VECTOR ROTATION SINE -! (UTO=CROT*UFROM-SROT*VFROM; -! VTO=SROT*UFROM+CROT*VFROM) -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - IMPLICIT NONE -! - INTEGER, PARAMETER :: KD=SELECTED_REAL_KIND(15,45) -! - REAL(KIND=r_double), INTENT(IN ) :: FLAT, FLON - REAL(KIND=r_double), INTENT(IN ) :: TLAT, TLON - REAL(KIND=r_double), INTENT( OUT) :: CROT, SROT -! - REAL(KIND=r_double), PARAMETER :: CRDLIM=0.9999999 - REAL(KIND=r_double), PARAMETER :: PI=3.14159265358979 - REAL(KIND=r_double), PARAMETER :: DPR=180./PI -! - REAL(KIND=r_double) :: CTLAT,STLAT,CFLAT,SFLAT - REAL(KIND=r_double) :: CDLON,SDLON,CRD - REAL(KIND=r_double) :: SRD2RN,STR,CTR,SFR,CFR -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE COSINE OF THE RADIAL DISTANCE BETWEEN THE POINTS. - CTLAT=COS(TLAT/DPR) - STLAT=SIN(TLAT/DPR) -CFLAT=COS(FLAT/DPR) - SFLAT=SIN(FLAT/DPR) - CDLON=COS((FLON-TLON)/DPR) - SDLON=SIN((FLON-TLON)/DPR) - CRD=STLAT*SFLAT+CTLAT*CFLAT*CDLON -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE ROTATIONS AT BOTH POINTS WITH RESPECT TO THE GREAT CIRCLE -! AND COMBINE THEM TO GIVE THE TOTAL VECTOR ROTATION PARAMETERS. - IF(ABS(CRD).LE.CRDLIM) THEN - SRD2RN=-1/(1-CRD**2) - STR=CFLAT*SDLON - CTR=CFLAT*STLAT*CDLON-SFLAT*CTLAT - SFR=CTLAT*SDLON - CFR=CTLAT*SFLAT*CDLON-STLAT*CFLAT - CROT=SRD2RN*(CTR*CFR-STR*SFR) - SROT=SRD2RN*(CTR*SFR+STR*CFR) -! USE A DIFFERENT APPROXIMATION FOR NEARLY COINCIDENT POINTS. -! MOVING VECTORS TO ANTIPODAL POINTS IS AMBIGUOUS ANYWAY. - ELSE - CROT=CDLON - SROT=SDLON*STLAT - ENDIF -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE MOVECT - - !======================================================================= - -end module interpolation_interface diff --git a/sorc/regrid_nemsio.fd/kinds.f90 b/sorc/regrid_nemsio.fd/kinds.f90 deleted file mode 100644 index 11c93b98e0..0000000000 --- a/sorc/regrid_nemsio.fd/kinds.f90 +++ /dev/null @@ -1,107 +0,0 @@ -! this module was extracted from the GSI version operational -! at NCEP in Dec. 2007. -module kinds -!$$$ module documentation block -! . . . . -! module: kinds -! prgmmr: treadon org: np23 date: 2004-08-15 -! -! abstract: Module to hold specification kinds for variable declaration. -! This module is based on (copied from) Paul vanDelst's -! type_kinds module found in the community radiative transfer -! model -! -! module history log: -! 2004-08-15 treadon -! -! Subroutines Included: -! -! Functions Included: -! -! remarks: -! The numerical data types defined in this module are: -! i_byte - specification kind for byte (1-byte) integer variable -! i_short - specification kind for short (2-byte) integer variable -! i_long - specification kind for long (4-byte) integer variable -! i_llong - specification kind for double long (8-byte) integer variable -! r_single - specification kind for single precision (4-byte) real variable -! r_double - specification kind for double precision (8-byte) real variable -! r_quad - specification kind for quad precision (16-byte) real variable -! -! i_kind - generic specification kind for default integer -! r_kind - generic specification kind for default floating point -! -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - implicit none - private - -! Integer type definitions below - -! Integer types - integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer - integer, parameter, public :: i_short = selected_int_kind(4) ! short integer - integer, parameter, public :: i_long = selected_int_kind(8) ! long integer - integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer - integer, parameter, public :: i_llong = max( llong_t, i_long ) - -! Expected 8-bit byte sizes of the integer kinds - integer, parameter, public :: num_bytes_for_i_byte = 1 - integer, parameter, public :: num_bytes_for_i_short = 2 - integer, parameter, public :: num_bytes_for_i_long = 4 - integer, parameter, public :: num_bytes_for_i_llong = 8 - -! Define arrays for default definition - integer, parameter, private :: num_i_kinds = 4 - integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & - i_byte, i_short, i_long, i_llong /) - integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & - num_bytes_for_i_byte, num_bytes_for_i_short, & - num_bytes_for_i_long, num_bytes_for_i_llong /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** - integer, parameter, public :: default_integer = 3 ! 1=byte, - ! 2=short, - ! 3=long, - ! 4=llong - integer, parameter, public :: i_kind = integer_types( default_integer ) - integer, parameter, public :: num_bytes_for_i_kind = & - integer_byte_sizes( default_integer ) - - -! Real definitions below - -! Real types - integer, parameter, public :: r_single = selected_real_kind(6) ! single precision - integer, parameter, public :: r_double = selected_real_kind(15) ! double precision - integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision - integer, parameter, public :: r_quad = max( quad_t, r_double ) - -! Expected 8-bit byte sizes of the real kinds - integer, parameter, public :: num_bytes_for_r_single = 4 - integer, parameter, public :: num_bytes_for_r_double = 8 - integer, parameter, public :: num_bytes_for_r_quad = 16 - -! Define arrays for default definition - integer, parameter, private :: num_r_kinds = 3 - integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & - r_single, r_double, r_quad /) - integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & - num_bytes_for_r_single, num_bytes_for_r_double, & - num_bytes_for_r_quad /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** - integer, parameter, public :: default_real = 1 ! 1=single, - ! 2=double, - ! 3=quad - integer, parameter, public :: r_kind = real_kinds( default_real ) - integer, parameter, public :: num_bytes_for_r_kind = & - real_byte_sizes( default_real ) - -end module kinds diff --git a/sorc/regrid_nemsio.fd/main.f90 b/sorc/regrid_nemsio.fd/main.f90 deleted file mode 100644 index f3dfe4ef09..0000000000 --- a/sorc/regrid_nemsio.fd/main.f90 +++ /dev/null @@ -1,92 +0,0 @@ -program regrid_nemsio_main - - !===================================================================== - - !$$$ PROGRAM DOCUMENTATION BLOCK - ! - ! ABSTRACT: - ! - ! This routine provides an interface between the National Oceanic - ! and Atmospheric Administration (NOAA) National Centers for - ! Environmental Prediction (NCEP) implemented NOAA Environmental - ! Modeling System (NEMS) input/output file format and the native - ! FV3 cubed sphere grid. - ! - ! NOTES: - ! - ! * Uses interpolation weights generated by - ! Earth-System Modeling Framework (ESMF) remapping utilities. - ! - ! PRGMMR: Winterbottom - ! ORG: ESRL/PSD1 - ! DATE: 2016-02-02 - ! - ! PROGRAM HISTORY LOG: - ! - ! 2016-02-02 Initial version. Henry R. Winterbottom - ! 2016-11-01 Modifed by Jeff Whitaker. - ! - !$$$ - - !===================================================================== - - ! Define associated modules and subroutines - - !--------------------------------------------------------------------- - - use kinds - - !--------------------------------------------------------------------- - - use mpi_interface - use fv3_interface - use namelist_def - use constants - - !--------------------------------------------------------------------- - - implicit none - - !===================================================================== - - ! Define variables computed within routine - - real(r_kind) :: exectime_start - real(r_kind) :: exectime_finish - - !===================================================================== - - ! Define local variables - - call mpi_interface_initialize() - call init_constants(.false.) - - if(mpi_procid .eq. mpi_masternode) then - - call cpu_time(exectime_start) - - end if - call mpi_barrier(mpi_comm_world,mpi_ierror) - - call namelistparams() - call fv3_regrid_nemsio() - - - if(mpi_procid .eq. mpi_masternode) then - - call cpu_time(exectime_finish) - write(6,500) exectime_finish - exectime_start - - end if ! if(mpi_procid .eq. mpi_masternode) - - call mpi_barrier(mpi_comm_world,mpi_ierror) - call mpi_interface_terminate() - - !===================================================================== - ! Define format statements - -500 format('MAIN: Execution time: ', f13.5, ' seconds.') - - !===================================================================== - -end program regrid_nemsio_main diff --git a/sorc/regrid_nemsio.fd/mpi_interface.f90 b/sorc/regrid_nemsio.fd/mpi_interface.f90 deleted file mode 100644 index 2e6c5c7a94..0000000000 --- a/sorc/regrid_nemsio.fd/mpi_interface.f90 +++ /dev/null @@ -1,89 +0,0 @@ -module mpi_interface - - !======================================================================= - - use kinds - - !----------------------------------------------------------------------- - - implicit none - - !----------------------------------------------------------------------- - - ! Define necessary include files - - include "mpif.h" - - !----------------------------------------------------------------------- - - ! Define global variables - - character :: mpi_nodename(mpi_max_processor_name) - character :: mpi_noderequest - logical :: abort_mpi - integer(kind=4), dimension(:), allocatable :: mpi_ranks - integer(kind=4) :: mpi_errorstatus(mpi_status_size) - integer(kind=4) :: mpi_masternode - integer(kind=4) :: mpi_slavenode - integer(kind=4) :: mpi_ierror - integer(kind=4) :: mpi_ierrorcode - integer(kind=4) :: mpi_procid - integer(kind=4) :: mpi_nprocs - integer(kind=4) :: mpi_node_source - integer(kind=4) :: mpi_node_destination - integer(kind=4) :: mpi_loopcount - integer(kind=4) :: mpi_request - integer(kind=4) :: mpi_group_user - integer(kind=4) :: mpi_group_nprocs - integer(kind=4) :: mpi_group_procid - integer(kind=4) :: mpi_group_begin - integer(kind=4) :: mpi_group_end - - !----------------------------------------------------------------------- - -contains - - !======================================================================= - - ! mpi_interface_initialize.f90: - - !----------------------------------------------------------------------- - - subroutine mpi_interface_initialize() - - !===================================================================== - - ! Define local variables - - call mpi_init(mpi_ierror) - call mpi_comm_rank(mpi_comm_world,mpi_procid,mpi_ierror) - call mpi_comm_size(mpi_comm_world,mpi_nprocs,mpi_ierror) - mpi_masternode = 0 - abort_mpi = .false. - - !===================================================================== - - end subroutine mpi_interface_initialize - - !======================================================================= - - ! mpi_interface_terminate.f90: - - !----------------------------------------------------------------------- - - subroutine mpi_interface_terminate() - - !===================================================================== - - ! Define local variables - - !call mpi_abort(mpi_comm_world,ierror_code,mpi_ierror) - call mpi_finalize(mpi_ierror) - - !===================================================================== - - end subroutine mpi_interface_terminate - - !======================================================================= - -end module mpi_interface diff --git a/sorc/regrid_nemsio.fd/namelist_def.f90 b/sorc/regrid_nemsio.fd/namelist_def.f90 deleted file mode 100644 index ff15a335f5..0000000000 --- a/sorc/regrid_nemsio.fd/namelist_def.f90 +++ /dev/null @@ -1,181 +0,0 @@ -module namelist_def - - !======================================================================= - - ! Define associated modules and subroutines - - !----------------------------------------------------------------------- - - use kinds - - !----------------------------------------------------------------------- - - use mpi_interface - - !----------------------------------------------------------------------- - - implicit none - - !----------------------------------------------------------------------- - - ! Define global variables - - integer, parameter :: max_ngrids = 12 - character(len=500) :: analysis_filename(max_ngrids) = 'NOT USED' - character(len=500) :: analysis_filename2d(max_ngrids) = 'NOT USED' - character(len=500) :: gfs_hyblevs_filename = 'NOT USED' - character(len=500) :: esmf_neareststod_filename = 'NOT USED' - character(len=500) :: esmf_bilinear_filename = 'NOT USED' - character(len=500) :: variable_table = 'NOT USED' - character(len=500) :: datapathout2d = './' - character(len=500) :: datapathout3d = './' - character(len=19) :: forecast_timestamp = '0000-00-00_00:00:00' - character(len=4) :: nemsio_opt = 'bin4' - character(len=4) :: nemsio_opt2d = 'none' - character(len=4) :: nemsio_opt3d = 'none' - logical :: is_ugrid2sgrid = .false. - logical :: debug = .false. - integer :: nlons = 0 - integer :: nlats = 0 - integer :: ntrunc = 0 - integer :: ngrids = 0 - namelist /share/ debug, nlons,nlats,ntrunc,datapathout2d,datapathout3d, & - analysis_filename, forecast_timestamp, nemsio_opt, nemsio_opt2d, nemsio_opt3d, & - analysis_filename2d, variable_table - - namelist /interpio/ esmf_bilinear_filename, esmf_neareststod_filename, gfs_hyblevs_filename - - !--------------------------------------------------------------------- - -contains - - !===================================================================== - - ! namelistparams.f90: - - !--------------------------------------------------------------------- - - subroutine namelistparams() - - ! Define variables computed within routine - - logical :: is_it_there - integer :: unit_nml - - ! Define counting variables - - integer :: i, j, k - - !=================================================================== - - ! Define local variables - - unit_nml = 9 - is_it_there = .false. - inquire(file='regrid-nemsio.input',exist = is_it_there) - - ! Check local variable and proceed accordingly - - if(is_it_there) then - - ! Define local variables - - open(file = 'regrid-nemsio.input', & - unit = unit_nml , & - status = 'old' , & - form = 'formatted' , & - action = 'read' , & - access = 'sequential' ) - read(unit_nml,NML = share) - read(unit_nml,NML = interpio) - close(unit_nml) - if (nemsio_opt2d == 'none') nemsio_opt2d=nemsio_opt - if (nemsio_opt3d == 'none') nemsio_opt3d=nemsio_opt - - ! Loop through local variable - - do i = 1, max_ngrids - - ! Check local variable and proceed accordingly - - if(analysis_filename(i) .ne. 'NOT USED') then - - ! Define local variables - - ngrids = ngrids + 1 - - end if ! if(analysis_filename(i) .ne. 'NOT USED') - - end do ! do i = 1, max_ngrids - - else ! if(is_it_there) - - ! Define local variables - - if(mpi_procid .eq. mpi_masternode) write(6,500) - call mpi_barrier(mpi_comm_world,mpi_ierror) - call mpi_interface_terminate() - - end if ! if(.not. is_it_there) - - !=================================================================== - - ! Check local variable and proceed accordingly - - if(mpi_procid .eq. mpi_masternode) then - - ! Define local variables - - write(6,*) '&SHARE' - write(6,*) 'DEBUG = ', debug - write(6,*) 'ANALYSIS_FILENAME = ' - do k = 1, ngrids - write(6,*) trim(adjustl(analysis_filename(k))) - ! if analysis_filename2d not specified, set to analysis_filename - if (trim(analysis_filename2d(k)) == 'NOT USED') then - analysis_filename2d(k) = analysis_filename(k) - endif - end do ! do k = 1, ngrids - write(6,*) 'ANALYSIS_FILENAME2D = ' - do k = 1, ngrids - write(6,*) trim(adjustl(analysis_filename2d(k))) - end do ! do k = 1, ngrids - write(6,*) 'VARIABLE_TABLE = ', & - & trim(adjustl(variable_table)) - write(6,*) 'FORECAST_TIMESTAMP = ', forecast_timestamp - write(6,*) 'OUTPUT DATAPATH (2d) = ', & - & trim(adjustl(datapathout2d)) - write(6,*) 'OUTPUT DATAPATH (3d) = ', & - & trim(adjustl(datapathout3d)) - write(6,*) 'NEMSIO_OPT (2d) = ', nemsio_opt2d - write(6,*) 'NEMSIO_OPT (3d) = ', nemsio_opt3d - write(6,*) '/' - write(6,*) '&INTERPIO' - write(6,*) 'ESMF_BILINEAR_FILENAME = ', & - & trim(adjustl(esmf_bilinear_filename)) - write(6,*) 'ESMF_NEARESTSTOD_FILENAME = ', & - & trim(adjustl(esmf_neareststod_filename)) - write(6,*) 'GFS_HYBLEVS_FILENAME = ', & - & trim(adjustl(gfs_hyblevs_filename)) - write(6,*) '/' - - end if ! if(mpi_procid .eq. mpi_masternode) - - ! Define local variables - - call mpi_barrier(mpi_comm_world,mpi_ierror) - - !=================================================================== - - ! Define format statements - -500 format('NAMELISTPARAMS: regrid-nemsio.input not found in the', & - & ' current working directory. ABORTING!!!!') - - !=================================================================== - - end subroutine namelistparams - - !===================================================================== - -end module namelist_def diff --git a/sorc/regrid_nemsio.fd/netcdfio_interface.f90 b/sorc/regrid_nemsio.fd/netcdfio_interface.f90 deleted file mode 100644 index 473b765c50..0000000000 --- a/sorc/regrid_nemsio.fd/netcdfio_interface.f90 +++ /dev/null @@ -1,592 +0,0 @@ -module netcdfio_interface - - !======================================================================= - - ! Define associated modules and subroutines - - !----------------------------------------------------------------------- - - use kinds - - !----------------------------------------------------------------------- - - use namelist_def - use netcdf - use mpi_interface - - !----------------------------------------------------------------------- - - implicit none - - !----------------------------------------------------------------------- - - ! Define global variables - - logical :: ncstatic - integer :: ncrec - integer :: ncxdim - integer :: ncydim - integer :: nczdim - integer :: nctdim - integer :: ncfileid - integer :: ncvarid - integer :: ncdimid - integer :: ncstatus - - !----------------------------------------------------------------------- - - ! Define interfaces and attributes for module routines - - private - interface netcdfio_values_1d - module procedure netcdfio_values_1d_dblepr - module procedure netcdfio_values_1d_realpr - module procedure netcdfio_values_1d_intepr - end interface ! interface netcdfio_values_2d - interface netcdfio_values_2d - module procedure netcdfio_values_2d_dblepr - module procedure netcdfio_values_2d_realpr - module procedure netcdfio_values_2d_intepr - end interface ! interface netcdfio_values_2d - interface netcdfio_values_3d - module procedure netcdfio_values_3d_dblepr - module procedure netcdfio_values_3d_realpr - module procedure netcdfio_values_3d_intepr - end interface ! interface netcdfio_values_3d - interface netcdfio_global_attr - module procedure netcdfio_global_attr_char - end interface ! interface netcdfio_global_attr - interface netcdfio_variable_attr - module procedure netcdfio_variable_attr_char - end interface ! interface netcdfio_variable_attr - public :: netcdfio_values_1d - public :: netcdfio_values_2d - public :: netcdfio_values_3d - public :: netcdfio_dimension - public :: netcdfio_global_attr - public :: netcdfio_variable_attr - public :: ncrec - public :: ncxdim - public :: ncydim - public :: nczdim - public :: nctdim - public :: ncstatic - - !----------------------------------------------------------------------- - -contains - - !======================================================================= - - ! netcdfio_global_attr.f90: - - !----------------------------------------------------------------------- - - subroutine netcdfio_global_attr_char(filename,varname,varvalue) - - ! Define variables passed to routine - - character(len=500) :: filename - character(len=*) :: varname - character(len=*) :: varvalue - - !===================================================================== - - ! Define local variables - - ncstatus = nf90_open(path=trim(adjustl(filename)),mode=nf90_nowrite, & - & ncid=ncfileid) - ncstatus = nf90_get_att(ncfileid,nf90_global,trim(adjustl(varname)), & - & varvalue) - ncstatus = nf90_close(ncfileid) - - !===================================================================== - - end subroutine netcdfio_global_attr_char - - subroutine netcdfio_variable_attr_char(filename,varname,attribute,varvalue) - - implicit none - - !======================================================================= - - ! Define variables passed to subroutine - - character(len=500),intent(in) :: filename - character(len=*),intent(in) :: attribute - character(len=*),intent(in) :: varname - - ! Define variables returned by subroutine - - character(len=80),intent(out) :: varvalue - - ! Define variables for decoding netCDF data - - integer ncid, varid, ncstatus - - ncstatus = nf90_open(path=trim(adjustl(filename)),mode=nf90_nowrite,ncid=ncid) - ncstatus = nf90_inq_varid(ncid,trim(adjustl(varname)),varid) - ncstatus = nf90_get_att(ncid,varid,trim(adjustl(attribute)),varvalue) - ncstatus = nf90_close(ncfileid) - - !===================================================================== - - end subroutine netcdfio_variable_attr_char - - !======================================================================= - - ! netcdfio_values_1d_dblepr.f90: - - !----------------------------------------------------------------------- - - subroutine netcdfio_values_1d_dblepr(filename,varname,varvalue) - - ! Define variables passed to routine - - character(len=500) :: filename - character(len=*) :: varname - real(r_double) :: varvalue(:) - - !===================================================================== - - ! Define local variables - - ncstatus = nf90_open(path=trim(adjustl(filename)),mode=nf90_nowrite, & - & ncid=ncfileid) - ncstatus = nf90_inq_varid(ncfileid,trim(adjustl(varname)),ncvarid) - if (ncstatus /= 0) then - varvalue = -1.e30 - else - ncstatus = nf90_get_var(ncfileid,ncvarid,varvalue) - if (ncstatus .ne. 0) then - print *,'fv3 read failed for ',trim(adjustl(varname)) - call mpi_interface_terminate() - stop - endif - endif - ncstatus = nf90_close(ncfileid) - - !===================================================================== - - end subroutine netcdfio_values_1d_dblepr - - !======================================================================= - - ! netcdfio_values_2d_dblepr.f90: - - !----------------------------------------------------------------------- - - subroutine netcdfio_values_2d_dblepr(filename,varname,varvalue) - - ! Define variables passed to routine - - character(len=500) :: filename - character(len=*) :: varname - real(r_double), dimension(ncxdim,ncydim) :: varvalue - - ! Define variables computed within routine - - integer, dimension(3) :: start - integer, dimension(3) :: count - - !===================================================================== - - ! Define local variables - - ncstatus = nf90_open(path=trim(adjustl(filename)),mode=nf90_nowrite, & - & ncid=ncfileid) - ncstatus = nf90_inq_varid(ncfileid,trim(adjustl(varname)),ncvarid) - if (ncstatus .ne. 0) then - print *,'fv3 read failed for ',trim(adjustl(varname)) - call mpi_interface_terminate() - stop - endif - if(ncstatic) start = (/1,1,1/) - if(.not. ncstatic) start = (/1,1,ncrec/) - count = (/ncxdim,ncydim,1/) - ncstatus = nf90_get_var(ncfileid,ncvarid,varvalue,start,count) - if (ncstatus .ne. 0) then - print *,'fv3 read failed for ',trim(adjustl(varname)) - call mpi_interface_terminate() - stop - endif - if(debug) write(6,500) trim(adjustl(varname)), minval(varvalue), & - & maxval(varvalue) - ncstatus = nf90_close(ncfileid) - - !===================================================================== - - ! Define format statements - -500 format('NETCDFIO_VALUES_2D: Variable name = ', a, '; (min,max) = (', & - & f13.5,',',f13.5,').') - - !===================================================================== - - end subroutine netcdfio_values_2d_dblepr - - !======================================================================= - - ! netcdfio_values_3d_dblepr.f90: - - !----------------------------------------------------------------------- - - subroutine netcdfio_values_3d_dblepr(filename,varname,varvalue) - - ! Define variables passed to routine - - character(len=500) :: filename - character(len=*) :: varname - real(r_double), dimension(ncxdim,ncydim,nczdim) :: varvalue - - ! Define variables computed within routine - - integer, dimension(4) :: start - integer, dimension(4) :: count - - !===================================================================== - - ! Define local variables - - ncstatus = nf90_open(path=trim(adjustl(filename)),mode=nf90_nowrite, & - & ncid=ncfileid) - ncstatus = nf90_inq_varid(ncfileid,trim(adjustl(varname)),ncvarid) - if (ncstatus .ne. 0) then - print *,'fv3 read failed for ',trim(adjustl(varname)) - call mpi_interface_terminate() - stop - endif - if(ncstatic) start = (/1,1,1,1/) - if(.not. ncstatic) start = (/1,1,1,ncrec/) - count = (/ncxdim,ncydim,nczdim,1/) - ncstatus = nf90_get_var(ncfileid,ncvarid,varvalue,start,count) - if (ncstatus .ne. 0) then - print *,'fv3 read failed for ',trim(adjustl(varname)) - call mpi_interface_terminate() - stop - endif - if(debug) write(6,500) trim(adjustl(varname)), minval(varvalue), & - & maxval(varvalue) - ncstatus = nf90_close(ncfileid) - - !===================================================================== - - ! Define format statements - -500 format('NETCDFIO_VALUES_3D: Variable name = ', a, '; (min,max) = (', & - & f13.5,',',f13.5,').') - - !===================================================================== - - end subroutine netcdfio_values_3d_dblepr - - !======================================================================= - - ! netcdfio_values_1d_realpr.f90: - - !----------------------------------------------------------------------- - - subroutine netcdfio_values_1d_realpr(filename,varname,varvalue) - - ! Define variables passed to routine - - character(len=500) :: filename - character(len=*) :: varname - real(r_kind) :: varvalue(:) - - !===================================================================== - - ! Define local variables - - ncstatus = nf90_open(path=trim(adjustl(filename)),mode=nf90_nowrite, & - & ncid=ncfileid) - ncstatus = nf90_inq_varid(ncfileid,trim(adjustl(varname)),ncvarid) - if (ncstatus .ne. 0) then - print *,'fv3 read failed for ',trim(adjustl(varname)) - call mpi_interface_terminate() - stop - endif - if (ncstatus /= 0) then - varvalue = -1.e30 - else - ncstatus = nf90_get_var(ncfileid,ncvarid,varvalue) - if (ncstatus .ne. 0) then - print *,'fv3 read failed for ',trim(adjustl(varname)) - call mpi_interface_terminate() - stop - endif - endif - ncstatus = nf90_close(ncfileid) - - !===================================================================== - - end subroutine netcdfio_values_1d_realpr - - !======================================================================= - - ! netcdfio_values_2d_realpr.f90: - - !----------------------------------------------------------------------- - - subroutine netcdfio_values_2d_realpr(filename,varname,varvalue) - - ! Define variables passed to routine - - character(len=500) :: filename - character(len=*) :: varname - real(r_kind), dimension(ncxdim,ncydim) :: varvalue - - ! Define variables computed within routine - - integer, dimension(3) :: start - integer, dimension(3) :: count - - !===================================================================== - - ! Define local variables - - ncstatus = nf90_open(path=trim(adjustl(filename)),mode=nf90_nowrite, & - & ncid=ncfileid) - ncstatus = nf90_inq_varid(ncfileid,trim(adjustl(varname)),ncvarid) - if (ncstatus .ne. 0) then - print *,'fv3 read failed for ',trim(adjustl(varname)) - call mpi_interface_terminate() - stop - endif - if(ncstatic) start = (/1,1,1/) - if(.not. ncstatic) start = (/1,1,ncrec/) - count = (/ncxdim,ncydim,1/) - ncstatus = nf90_get_var(ncfileid,ncvarid,varvalue,start,count) - if (ncstatus .ne. 0) then - print *,'fv3 read failed for ',trim(adjustl(varname)) - call mpi_interface_terminate() - stop - endif - if(debug) write(6,500) trim(adjustl(varname)), minval(varvalue), & - & maxval(varvalue) - ncstatus = nf90_close(ncfileid) - - !===================================================================== - - ! Define format statements - -500 format('NETCDFIO_VALUES_2D: Variable name = ', a, '; (min,max) = (', & - & f13.5,',',f13.5,').') - - !===================================================================== - - end subroutine netcdfio_values_2d_realpr - - !======================================================================= - - ! netcdfio_values_3d_realpr.f90: - - !----------------------------------------------------------------------- - - subroutine netcdfio_values_3d_realpr(filename,varname,varvalue) - - ! Define variables passed to routine - - character(len=500) :: filename - character(len=*) :: varname - real(r_kind), dimension(ncxdim,ncydim,nczdim) :: varvalue - - ! Define variables computed within routine - - integer, dimension(4) :: start - integer, dimension(4) :: count - - !===================================================================== - - ! Define local variables - - ncstatus = nf90_open(path=trim(adjustl(filename)),mode=nf90_nowrite, & - & ncid=ncfileid) - ncstatus = nf90_inq_varid(ncfileid,trim(adjustl(varname)),ncvarid) - if (ncstatus .ne. 0) then - print *,'fv3 read failed for ',trim(adjustl(varname)) - call mpi_interface_terminate() - stop - endif - if(ncstatic) start = (/1,1,1,1/) - if(.not. ncstatic) start = (/1,1,1,ncrec/) - count = (/ncxdim,ncydim,nczdim,1/) - ncstatus = nf90_get_var(ncfileid,ncvarid,varvalue,start,count) - if (ncstatus .ne. 0) then - print *,'fv3 read failed for ',trim(adjustl(varname)) - call mpi_interface_terminate() - stop - endif - if(debug) write(6,500) trim(adjustl(varname)), minval(varvalue), & - & maxval(varvalue) - ncstatus = nf90_close(ncfileid) - - !===================================================================== - - ! Define format statements - -500 format('NETCDFIO_VALUES_3D: Variable name = ', a, '; (min,max) = (', & - & f13.5,',',f13.5,').') - - !===================================================================== - - end subroutine netcdfio_values_3d_realpr - - !======================================================================= - - ! netcdfio_values_1d_intepr.f90: - - !----------------------------------------------------------------------- - - subroutine netcdfio_values_1d_intepr(filename,varname,varvalue) - - ! Define variables passed to routine - - character(len=500) :: filename - character(len=*) :: varname - integer :: varvalue(:) - - !===================================================================== - - ! Define local variables - - ncstatus = nf90_open(path=trim(adjustl(filename)),mode=nf90_nowrite, & - & ncid=ncfileid) - ncstatus = nf90_inq_varid(ncfileid,trim(adjustl(varname)),ncvarid) - if (ncstatus /= 0) then - varvalue = -9999 - else - ncstatus = nf90_get_var(ncfileid,ncvarid,varvalue) - endif - ncstatus = nf90_close(ncfileid) - - !===================================================================== - - end subroutine netcdfio_values_1d_intepr - - !======================================================================= - - ! netcdfio_values_2d_intepr.f90: - - !----------------------------------------------------------------------- - - subroutine netcdfio_values_2d_intepr(filename,varname,varvalue) - - ! Define variables passed to routine - - character(len=500) :: filename - character(len=*) :: varname - integer, dimension(ncxdim,ncydim) :: varvalue - - ! Define variables computed within routine - - integer, dimension(3) :: start - integer, dimension(3) :: count - - !===================================================================== - - ! Define local variables - - ncstatus = nf90_open(path=trim(adjustl(filename)),mode=nf90_nowrite, & - & ncid=ncfileid) - ncstatus = nf90_inq_varid(ncfileid,trim(adjustl(varname)),ncvarid) - if(ncstatic) start = (/1,1,1/) - if(.not. ncstatic) start = (/1,1,ncrec/) - count = (/ncxdim,ncydim,1/) - ncstatus = nf90_get_var(ncfileid,ncvarid,varvalue,start,count) - if(debug) write(6,500) trim(adjustl(varname)), minval(varvalue), & - & maxval(varvalue) - ncstatus = nf90_close(ncfileid) - - !===================================================================== - - ! Define format statements - -500 format('NETCDFIO_VALUES_2D: Variable name = ', a, '; (min,max) = (', & - & f13.5,',',f13.5,').') - - !===================================================================== - - end subroutine netcdfio_values_2d_intepr - - !======================================================================= - - ! netcdfio_values_3d_intepr.f90: - - !----------------------------------------------------------------------- - - subroutine netcdfio_values_3d_intepr(filename,varname,varvalue) - - ! Define variables passed to routine - - character(len=500) :: filename - character(len=*) :: varname - integer, dimension(ncxdim,ncydim,nczdim) :: varvalue - - ! Define variables computed within routine - - integer, dimension(4) :: start - integer, dimension(4) :: count - - !===================================================================== - - ! Define local variables - - ncstatus = nf90_open(path=trim(adjustl(filename)),mode=nf90_nowrite, & - & ncid=ncfileid) - ncstatus = nf90_inq_varid(ncfileid,trim(adjustl(varname)),ncvarid) - if (ncstatus .ne. 0) then - print *,'fv3 read failed for ',trim(adjustl(varname)) - call mpi_interface_terminate() - stop - endif - if(ncstatic) start = (/1,1,1,1/) - if(.not. ncstatic) start = (/1,1,1,ncrec/) - count = (/ncxdim,ncydim,nczdim,1/) - ncstatus = nf90_get_var(ncfileid,ncvarid,varvalue,start,count) - if(debug) write(6,500) trim(adjustl(varname)), minval(varvalue), & - & maxval(varvalue) - ncstatus = nf90_close(ncfileid) - - !===================================================================== - - ! Define format statements - -500 format('NETCDFIO_VALUES_3D: Variable name = ', a, '; (min,max) = (', & - & f13.5,',',f13.5,').') - - !===================================================================== - - end subroutine netcdfio_values_3d_intepr - - !======================================================================= - - ! netcdfio_dimension.f90: - - !----------------------------------------------------------------------- - - subroutine netcdfio_dimension(filename,dimname,dimvalue) - - ! Define variables passed to routine - - character(len=500) :: filename - character(len=*) :: dimname - integer :: dimvalue - - !===================================================================== - - ! Define local variables - - ncstatus = nf90_open(path=trim(adjustl(filename)),mode=nf90_nowrite, & - & ncid=ncfileid) - ncstatus = nf90_inq_dimid(ncfileid,trim(adjustl(dimname)),ncdimid) - ncstatus = nf90_inquire_dimension(ncfileid,ncdimid,len=dimvalue) - ncstatus = nf90_close(ncfileid) - - !===================================================================== - - end subroutine netcdfio_dimension - - !======================================================================= - -end module netcdfio_interface diff --git a/sorc/regrid_nemsio.fd/physcons.f90 b/sorc/regrid_nemsio.fd/physcons.f90 deleted file mode 100644 index 4e69dca337..0000000000 --- a/sorc/regrid_nemsio.fd/physcons.f90 +++ /dev/null @@ -1,77 +0,0 @@ -! this module contains some the most frequently used math and ! -! physics constatns for gcm models. ! -! ! -! references: ! -! as set in NMC handbook from Smithsonian tables. ! -! ! - module physcons -! - use kinds, only : r_kind -! - implicit none -! - public - -! --- ... Math constants - - real(r_kind),parameter:: con_pi =3.1415926535897931 ! pi - real(r_kind),parameter:: con_sqrt2 =1.414214e+0 ! square root of 2 - real(r_kind),parameter:: con_sqrt3 =1.732051e+0 ! square root of 3 - -! --- ... Geophysics/Astronomy constants - - real(r_kind),parameter:: con_rerth =6.3712e+6 ! radius of earth (m) - real(r_kind),parameter:: con_g =9.80665e+0 ! gravity (m/s2) - real(r_kind),parameter:: con_omega =7.2921e-5 ! ang vel of earth (1/s) - real(r_kind),parameter:: con_p0 =1.01325e5 ! std atms pressure (pa) - real(r_kind),parameter:: con_solr =1.3660e+3 ! solar constant (W/m2)-liu(2002) - -! --- ... Thermodynamics constants - - real(r_kind),parameter:: con_rgas =8.314472 ! molar gas constant (J/mol/K) - real(r_kind),parameter:: con_rd =2.8705e+2 ! gas constant air (J/kg/K) - real(r_kind),parameter:: con_rv =4.6150e+2 ! gas constant H2O (J/kg/K) - real(r_kind),parameter:: con_cp =1.0046e+3 ! spec heat air @p (J/kg/K) - real(r_kind),parameter:: con_cv =7.1760e+2 ! spec heat air @v (J/kg/K) - real(r_kind),parameter:: con_cvap =1.8460e+3 ! spec heat H2O gas (J/kg/K) - real(r_kind),parameter:: con_cliq =4.1855e+3 ! spec heat H2O liq (J/kg/K) - real(r_kind),parameter:: con_csol =2.1060e+3 ! spec heat H2O ice (J/kg/K) - real(r_kind),parameter:: con_hvap =2.5000e+6 ! lat heat H2O cond (J/kg) - real(r_kind),parameter:: con_hfus =3.3358e+5 ! lat heat H2O fusion (J/kg) - real(r_kind),parameter:: con_psat =6.1078e+2 ! pres at H2O 3pt (Pa) - real(r_kind),parameter:: con_t0c =2.7315e+2 ! temp at 0C (K) - real(r_kind),parameter:: con_ttp =2.7316e+2 ! temp at H2O 3pt (K) - real(r_kind),parameter:: con_tice =2.7120e+2 ! temp freezing sea (K) - real(r_kind),parameter:: con_jcal =4.1855E+0 ! joules per calorie () - real(r_kind),parameter:: con_rhw0 =1022.0 ! sea water reference density (kg/m^3) - real(r_kind),parameter:: con_epsq =1.0E-12 ! min q for computing precip type - -! Secondary constants - - real(r_kind),parameter:: con_rocp =con_rd/con_cp - real(r_kind),parameter:: con_cpor =con_cp/con_rd - real(r_kind),parameter:: con_rog =con_rd/con_g - real(r_kind),parameter:: con_fvirt =con_rv/con_rd-1. - real(r_kind),parameter:: con_eps =con_rd/con_rv - real(r_kind),parameter:: con_epsm1 =con_rd/con_rv-1. - real(r_kind),parameter:: con_dldt =con_cvap-con_cliq - real(r_kind),parameter:: con_xpona =-con_dldt/con_rv - real(r_kind),parameter:: con_xponb =-con_dldt/con_rv+con_hvap/(con_rv*con_ttp) - -! --- ... Other Physics/Chemistry constants (source: 2002 CODATA) - - real(r_kind),parameter:: con_c =2.99792458e+8 ! speed of light (m/s) - real(r_kind),parameter:: con_plnk =6.6260693e-34 ! planck constatn (J/s) - real(r_kind),parameter:: con_boltz =1.3806505e-23 ! boltzmann constant (J/K) - real(r_kind),parameter:: con_sbc =5.670400e-8 ! stefan-boltzmann (W/m2/K4) - real(r_kind),parameter:: con_avgd =6.0221415e23 ! avogadro constant (1/mol) - real(r_kind),parameter:: con_gasv =22413.996e-6 ! vol of ideal gas at 273.15k, 101.325kpa (m3/mol) - real(r_kind),parameter:: con_amd =28.9644 ! molecular wght of dry air (g/mol) - real(r_kind),parameter:: con_amw =18.0154 ! molecular wght of water vapor (g/mol) - real(r_kind),parameter:: con_amo3 =47.9982 ! molecular wght of o3 (g/mol) - real(r_kind),parameter:: con_amco2 =44.011 ! molecular wght of co2 (g/mol) - real(r_kind),parameter:: con_amo2 =31.9999 ! molecular wght of o2 (g/mol) - real(r_kind),parameter:: con_amch4 =16.043 ! molecular wght of ch4 (g/mol) - real(r_kind),parameter:: con_amn2o =44.013 ! molecular wght of n2o (g/mol) - -end module physcons diff --git a/sorc/regrid_nemsio.fd/regrid_nemsio_interface.f90 b/sorc/regrid_nemsio.fd/regrid_nemsio_interface.f90 deleted file mode 100644 index 9ab5597af8..0000000000 --- a/sorc/regrid_nemsio.fd/regrid_nemsio_interface.f90 +++ /dev/null @@ -1,50 +0,0 @@ -module regrid_nemsio_interface - - !======================================================================= - - ! Define associated modules and subroutines - - !----------------------------------------------------------------------- - - use constants - use kinds - - !----------------------------------------------------------------------- - - use fv3_interface - use gfs_nems_interface - use namelist_def - - !----------------------------------------------------------------------- - - implicit none - - !----------------------------------------------------------------------- - -contains - - !======================================================================= - - ! regrid_nemsio.f90: - - !----------------------------------------------------------------------- - - subroutine regrid_nemsio() - - !===================================================================== - - ! Define local variables - - call namelistparams() - - ! Check local variable and proceed accordingly - - call fv3_regrid_nemsio() - - !===================================================================== - - end subroutine regrid_nemsio - - !======================================================================= - -end module regrid_nemsio_interface diff --git a/sorc/regrid_nemsio.fd/variable_interface.f90 b/sorc/regrid_nemsio.fd/variable_interface.f90 deleted file mode 100644 index d0d568429d..0000000000 --- a/sorc/regrid_nemsio.fd/variable_interface.f90 +++ /dev/null @@ -1,66 +0,0 @@ -module variable_interface - - !======================================================================= - - ! Define associated modules and subroutines - - !----------------------------------------------------------------------- - - use kinds - use physcons, only: rgas => con_rd, cp => con_cp, grav => con_g, & - & rerth => con_rerth, rocp => con_rocp, & - & pi => con_pi, con_rog - - !----------------------------------------------------------------------- - - use mpi_interface - use namelist_def - - !----------------------------------------------------------------------- - - implicit none - - !----------------------------------------------------------------------- - - ! Define interfaces and attributes for module routines - - private - public :: varinfo - !public :: variable_lookup - public :: variable_clip - - !----------------------------------------------------------------------- - - ! Define all data and structure types for routine; these variables - ! are variables required by the subroutines within this module - - type varinfo - character(len=20) :: var_name - character(len=20) :: nems_name - character(len=20) :: nems_levtyp - integer :: nems_lev - character(len=20) :: itrptyp - logical :: clip - integer :: ndims - end type varinfo ! type varinfo - - !----------------------------------------------------------------------- - -contains - - !======================================================================= - - subroutine variable_clip(grid) - - - real(r_double) :: grid(:) - real(r_double) :: clip - - clip = tiny(grid(1)) - where(grid .le. dble(0.0)) grid = clip - - end subroutine variable_clip - - !======================================================================= - -end module variable_interface diff --git a/sorc/supvit.fd/CMakeLists.txt b/sorc/supvit.fd/CMakeLists.txt deleted file mode 100644 index 106fe3a7e5..0000000000 --- a/sorc/supvit.fd/CMakeLists.txt +++ /dev/null @@ -1,19 +0,0 @@ -list(APPEND fortran_src - supvit_modules.f - supvit_main.f -) - -if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -i4 -r8") -elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8") -endif() - -set(exe_name supvit.x) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - w3emc::w3emc_d - w3nco::w3nco_d) - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/supvit.fd/makefile b/sorc/supvit.fd/makefile deleted file mode 100644 index 288e42beff..0000000000 --- a/sorc/supvit.fd/makefile +++ /dev/null @@ -1,31 +0,0 @@ -SHELL= /bin/sh -ISIZE = 4 -RSIZE = 8 -COMP= ifort -##LIBS_SUP= -L/contrib/nceplibs/nwprod/lib -lw3emc_d -lw3nco_d -lg2_d -lbacio_4 -ljasper -lpng -lz -LDFLAGS= -##ccs FFLAGS= -O -qflttrap=ov:zero:inv:enable -qcheck -qextchk -qwarn64 -qintsize=$(ISIZE) -qrealsize=$(RSIZE) -# FFLAGS= -O2 -check bounds -check format -xHost -fpe0 -# DEBUG= -check bounds -check format -FFLAGS= -O2 -g -i$(ISIZE) -r$(RSIZE) - -supvit: supvit_main.f supvit_modules.o - @echo " " - @echo " Compiling program that sorts and updates vitals records...." - $(COMP) $(FFLAGS) $(LDFLAGS) supvit_modules.o supvit_main.f $(LIBS_SUP) -o supvit - @echo " " - -supvit_modules.o: supvit_modules.f - @echo " " - @echo " Compiling the modules....." - $(COMP) -c supvit_modules.f -o supvit_modules.o - @echo " " - -CMD = supvit - -clean: - -rm -f *.o *.mod - -install: - mv $(CMD) ../../exec/$(CMD) - diff --git a/sorc/supvit.fd/supvit_main.f b/sorc/supvit.fd/supvit_main.f deleted file mode 100644 index 1484e4efeb..0000000000 --- a/sorc/supvit.fd/supvit_main.f +++ /dev/null @@ -1,865 +0,0 @@ - program sort_and_update_vitals -c -c$$$ MAIN PROGRAM DOCUMENTATION BLOCK -c -c Main Program: SUPVIT Sort and Update Vitals File -C PRGMMR: MARCHOK ORG: NP22 DATE: 1999-04-14 -c -c ABSTRACT: This program searches through the TC Vitals file and reads -c the records for a particular dtg. It contains logic to eliminate -c duplicate records and only keep the most recent one (see further -c documentation below). It also searches to see if a storm was -c included in the Vitals file 6 hours earlier (or 3 hours earlier -c if we're tracking with the off-synoptic-time SREF) but is missing -c from the current Vitals records. In this case, the program assumes -c that the regional forecasting center was late in reporting the -c current position, and it includes the old Vitals record with -c the current Vitals records. This program will also take the -c position and heading from that old vitals record and extrapolate the -c information to get a current first guess estimate of the storm's -c position. By the way, if a storm was found 3 or 6 hours earlier, -c logic is also included to eliminate any duplicate records of that -c storm in those old records. Finally, if it turns out that the -c reason an old vitals is no longer on the current records is that -c the storm has dissipated, don't worry about including it to be -c passed into the tracking program; the tracking program will not be -c able to track it and that'll be the end of it. -c -c Program history log: -c 98-03-26 Marchok - Original operational version. -c 99-04-01 Marchok - Modified code to be able to read the year off -c of the TC Vitals card as a 4-digit integer, -c instead of as a 2-digit integer. -c 00-06-13 Marchok - Modified code to be able to read vitals from 6h -c ahead (this is for use in the GDAS tropical -c cyclone relocation system). -c 04-05-27 Marchok - Modified code to be able to read vitals from 3h -c ago. This is for tracking with the 09z and 21z -c SREF ensemble. Since there are no vitals at -c these offtimes, we need to update vitals from -c the synoptic times 3h earlier. -c -c Input files: -c unit 31 Text file containing all vitals (including duplicates) -c for current time and time from 3 or 6 hours ago and -c 3 or 6 hours ahead. -c Output files: -c unit 51 Text file containing sorted, updated vitals (without -c any duplicates) valid at the current time only. -c -c Subprograms called: -c read_nlists Read input namelists for input dates -c read_tcv_file Read TC vitals file to get initial storm positions -c delete_dups Delete duplicate TC vitals records from current time -c delete_old Delete records from 6h ago if current record exists -c delete_old_dups Delete duplicate records from 6h ago time -c update_old_vits Update position of storms from 6h ago positions -c output Output 1 record for each updated vitals record -c -c Attributes: -c Language: Fortran_90 -c -c$$$ -c -c------- -c -c - USE def_vitals; USE set_max_parms; USE inparms; USE date_checks - USE trig_vals -c - type (tcvcard) storm(maxstorm) - type (datecard) dnow, dold, dfuture - - logical okstorm(maxstorm) - integer vit_hr_incr -c - call w3tagb('SUPVIT ',1999,0104,0058,'NP22 ') -c - okstorm = .FALSE. -c - pi = 4. * atan(1.) ! pi, dtr and rtd were declared in module - dtr = pi/180.0 ! trig_vals, but were not yet defined. - rtd = 180.0/pi -c -c ----------------------------------------- -c Read namelists to get date information -c - call read_nlists (dnow,dold,dfuture,vit_hr_incr) -c -c ----------------------------------------------------------- -c Read in storm cards for current time and delete duplicates -c - - inowct = 0 - call read_tcv_file (storm,ymd_now,hhmm_now,inowct,okstorm) - - if (inowct > 0) then - call delete_dups (storm,inowct,okstorm) - else - print *,' ' - print *,'!!! No storms on tcv card for current time.' - print *,'!!! A check will be made for old tcv storm cards,' - print *,'!!! and if any exist, the positions will be updated' - print *,'!!! (extrapolated) to get a first guess position for' - print *,'!!! the current time.' - print *,'!!! Current forecast time = ',ymd_now,hhmm_now - print *,'!!! Old forecast time = ',ymd_old,hhmm_old - endif -c -c ----------------------------------------------------------- -c Read in storm cards for 3h or 6h ago and delete duplicates -c - rewind (31) - itempct = inowct - call read_tcv_file (storm,ymd_old,hhmm_old,itempct,okstorm) - ioldct = itempct - inowct - - if (ioldct > 0) then - if (inowct > 0) then - call delete_old (storm,inowct,ioldct,okstorm) - endif - call delete_old_dups (storm,inowct,ioldct,okstorm) - endif - -c ---------------------------------------------------------------- -c Now update any vitals records left from 3h or 6h ago by -c extrapolating their positions ahead to the current time. - - if (ioldct > 0) then - call update_old_vits (storm,inowct,ioldct,okstorm,vit_hr_incr) - endif - - -c -------------------------------------------------------------- -c Read in storm cards for 3h or 6h ahead and delete duplicates. -c This is used for Qingfu's vortex relocation purposes. If he is -c doing the analysis/relocation for, say, 12z, he looks at the -c first guess files from the 06z cycle and tracks from there. -c But suppose there is a storm whose first tcvitals card is -c issued at 12z; then we would have no tcvitals card at 06z for -c the tracker to use. So this next part reads the vitals from -c the cycle 6h ahead and, if it finds any vitals that were not -c included with the current time's vitals, then it extrapolates -c those vitals from the next cycle *backwards* to the current -c time. By the way, itempct is input/output for the read -c routine. Going in, it contains the count of the number of -c records read in so far. In that read routine, itempct is -c incremented for every valid record read for the input time. - - rewind (31) - iprevct = inowct + ioldct - call read_tcv_file (storm,ymd_future,hhmm_future,itempct,okstorm) - ifuturect = itempct - iprevct - - print *,'before d6a if, ifuturect = ',ifuturect,' iprevct= ' - & ,iprevct - print *,'before d6a if, inowct = ',inowct,' ioldct= ',ioldct - - if (ifuturect > 0) then - if (iprevct > 0) then - call delete_future (storm,iprevct,ifuturect,okstorm) - endif - call delete_future_dups (storm,iprevct,ifuturect,okstorm) - endif - -c ---------------------------------------------------------------- -c Now update any vitals records not filtered out from 3h or 6h -c ahead by extrapolating their future positions *backwards* to -c the current time. - - if (ifuturect > 0) then - call update_future_vits (storm,iprevct,ifuturect,okstorm - & ,vit_hr_incr) - endif - - -c --------------------------------------------------------- -c Now output all of the sorted, updated TC Vitals records - - itotalct = inowct + ioldct + ifuturect - call output (storm,itotalct,okstorm) -c - call w3tage('SUPVIT ') - stop - end -c -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine read_tcv_file (storm,ymd,hhmm,ict,okstorm) -c -c ABSTRACT: This routine reads in the TC Vitals file, and stores -c into an array those records that match the input ymd and hhmm. -c -c INPUT: -c -c ict Tells at what index in the storm array to begin reading -c the input records into. This is important because this -c subroutine is called twice; the first time the data are -c for the current time and are just started at ict = 0, -c but the second time it's called we're getting the 6h ago -c data, and they have to be added onto the end of the -c array, so we need to know where the current time's data -c ends so we know what index to start the 6h ago data. -c - USE def_vitals; USE set_max_parms -c - type (tcvcard) storm(maxstorm), ts -c - integer ymd,hhmm - logical okstorm(maxstorm) -c - lucard = 31 - - print *,' ' - print '(a26,i6.6,a8,i4.4)',' IN READ_TCV_FILE: , ymd= ',ymd - & ,' hhmm= ',hhmm - print *,' ' - - - do while (.true.) - read (lucard,21,END=801,ERR=891) ts - if (ts%tcv_yymmdd == ymd .and. ts%tcv_hhmm == hhmm) then - ict = ict + 1 - storm(ict) = ts - okstorm(ict) = .TRUE. - write (6,23) ' !!! MATCH, ict= ',ict,storm(ict) - endif - enddo - 801 continue - - 21 format (a4,1x,a3,1x,a9,1x,i2,i6,1x,i4,1x,i3,a1,1x,i4,a1,1x,i3,1x - & ,i3,a85) - 23 format (a18,i3,2x,a4,1x,a3,1x,a9,1x,i2,i6.6,1x,i4.4,1x,i3,a1,1x,i4 - & ,a1,1x,i3,1x,i3,a85) - - iret = 0 - return - - 891 print *,'!!! ERROR in program sort_and_update_vitals. Error ' - print *,'!!! occurred in read_tcv_file while reading unit ',lucard - iret = 98 - - return - end -c -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine output (storm,itotalct,okstorm) -c - USE def_vitals; USE set_max_parms; USE inparms -c - type (tcvcard) storm(maxstorm) - type (datecard) dnow, dold, dfuture - - logical okstorm(maxstorm) -c - lunvit = 51 - - ist = 1 - do while (ist <= itotalct) - - if (okstorm(ist)) then - if (storm(ist)%tcv_stdir == -99 .or. - & storm(ist)%tcv_stspd == -99) then - write (lunvit,23,ERR=891) storm(ist) - else - write (lunvit,21,ERR=891) storm(ist) - endif - endif - - ist = ist + 1 - - enddo - - 21 format (a4,1x,a3,1x,a9,1x,i2.2,i6.6,1x,i4.4,1x,i3.3,a1,1x,i4.4 - & ,a1,1x,i3.3,1x,i3.3,a85) - 23 format (a4,1x,a3,1x,a9,1x,i2.2,i6.6,1x,i4.4,1x,i3.3,a1,1x,i4.4 - & ,a1,1x,i3,1x,i3,a85) - - iret = 0 - return - - 891 print *,'!!! ERROR in program sort_and_update_vitals. Error ' - print *,'!!! occurred in output while writing new vitals file ' - print *,'!!! to unit number',lunvit - iret = 98 - - return - end -c -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine update_old_vits (storm,inowct,ioldct,okstorm - & ,vit_hr_incr) -c -c ABSTRACT: This subroutine updates the vitals from 3h or 6h ago. -c It uses the heading and direction values listed in the vitals -c record (see Module def_vitals for specfics on where to find -c heading & direction in the vitals record) to get a new -c position for the current time by extrapolating out 3h or 6h. -c - USE def_vitals; USE set_max_parms; USE inparms; USE date_checks - USE trig_vals -c - type (tcvcard) storm(maxstorm) - type (datecard) dnow, dold - - logical okstorm(maxstorm) - integer vit_hr_incr -c - ist = inowct + 1 - iend = inowct + ioldct - do while (ist <= iend) - - if (okstorm(ist) .and. storm(ist)%tcv_yymmdd == ymd_old .and. - & storm(ist)%tcv_hhmm == hhmm_old) then - - rlat = float(storm(ist)%tcv_lat) / 10. - rlon = float(storm(ist)%tcv_lon) / 10. - rhdg = float(storm(ist)%tcv_stdir) - rspd = float(storm(ist)%tcv_stspd) / 10. - -c ------------------------------------------ -c This first part updates the positions by simply -c extrapolating the current motion along the current -c heading at the current speed for 3h or 6h. Be -c careful with adding and subtracting these distances -c in the different hemispheres (see the if statements). -c Remember: In the storm message file, there are NO -c negative signs to distinguish between hemispheres, -c so a southern hemisphere latitude will be POSITIVE, -c but will be distinguished by the 'S'. - - strmucomp = rspd * sin(dtr*rhdg) - strmvcomp = rspd * cos(dtr*rhdg) -c - vdistdeg = (strmvcomp * secphr * vit_hr_incr) / dtk - if (storm(ist)%tcv_latns == 'N') then - rnewlat = rlat + vdistdeg - else - rnewlat = rlat - vdistdeg - endif -c - avglat = 0.5 * (rlat + rnewlat) - cosfac = cos(dtr * avglat) - udistdeg = (strmucomp * secphr * vit_hr_incr) / (dtk * cosfac) - if (storm(ist)%tcv_lonew == 'W') then - rnewlon = rlon - udistdeg - else - rnewlon = rlon + udistdeg - endif - -c ------------------------------------------ -c This part updates the E/W and N/S characters -c in the event that a storm changes hemisphere. -c (N to S and S to N is not really possible, but -c we'll include the code anyway). If a storm -c does change hemisphere, say from W to E at 180, -c we need to also adjust the new longitude value -c from say 186W to 174E. Have to include this -c code since storm messages contain longitudes on -c a 0-180 basis (E&W), NOT 0-360. - - if (storm(ist)%tcv_latns == 'N') then - if (rnewlat < 0.) then - storm(ist)%tcv_latns = 'S' - rnewlat = -1. * rnewlat - endif - else - if (rnewlat < 0.) then - storm(ist)%tcv_latns = 'N' - rnewlat = -1. * rnewlat - endif - endif -c - if (storm(ist)%tcv_lonew == 'W') then - if (rnewlon > 180.) then - storm(ist)%tcv_lonew = 'E' - rnewlon = 180. - abs(rnewlon - 180.) - endif - else - if (rnewlon > 180.) then - storm(ist)%tcv_lonew = 'W' - rnewlon = 180. - abs(rnewlon - 180.) - endif - endif - - storm(ist)%tcv_lat = int ((rnewlat + 0.05) * 10.) - storm(ist)%tcv_lon = int ((rnewlon + 0.05) * 10.) - storm(ist)%tcv_yymmdd = ymd_now - storm(ist)%tcv_hhmm = hhmm_now - - endif - - ist = ist + 1 - - enddo -c - return - end - -c -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine update_future_vits (storm,iprevct,ifuturect,okstorm - & ,vit_hr_incr) -c -c ABSTRACT: This subroutine updates the vitals from 3h or 6h ahead. -c It uses the heading and direction values listed in the vitals -c record (see Module def_vitals for specfics on where to find -c heading & direction in the vitals record) to get a new -c position for the current time by extrapolating *BACKWARDS* -c 3h or 6h to the current time. -c - USE def_vitals; USE set_max_parms; USE inparms; USE date_checks - USE trig_vals -c - type (tcvcard) storm(maxstorm) - type (datecard) dnow, dold, dfuture - - logical okstorm(maxstorm) - integer vit_hr_incr -c - ist = iprevct + 1 - iend = iprevct + ifuturect - do while (ist <= iend) - - if (okstorm(ist) .and. storm(ist)%tcv_yymmdd == ymd_future .and. - & storm(ist)%tcv_hhmm == hhmm_future) then - - rlat = float(storm(ist)%tcv_lat) / 10. - rlon = float(storm(ist)%tcv_lon) / 10. - rhdg = float(storm(ist)%tcv_stdir) - rspd = float(storm(ist)%tcv_stspd) / 10. - -c IMPORTANT NOTE: Since we are extrapolating *BACKWARDS* in -c time in this routine, we have to take that value of the -c storm heading in rhdg and switch it by 180 degrees so that -c we will be pointing back in the direction the storm came -c from.... - - if (rhdg >= 0. .and. rhdg <= 180.) then - rhdg = rhdg + 180. - else - rhdg = rhdg - 180. - endif - -c ------------------------------------------ -c This first part updates the positions by simply -c extrapolating the current motion along the REVERSE of -c the current heading at the current speed for 6 hours. -c Be careful with adding and subtracting these distances -c in the different hemispheres (see the if statements). -c Remember: In the storm message file, there are NO -c negative signs to distinguish between hemispheres, -c so a southern hemisphere latitude will be POSITIVE, -c but will be distinguished by the 'S'. - - strmucomp = rspd * sin(dtr*rhdg) - strmvcomp = rspd * cos(dtr*rhdg) -c - vdistdeg = (strmvcomp * secphr * vit_hr_incr) / dtk - if (storm(ist)%tcv_latns == 'N') then - rnewlat = rlat + vdistdeg - else - rnewlat = rlat - vdistdeg - endif -c - avglat = 0.5 * (rlat + rnewlat) - cosfac = cos(dtr * avglat) - udistdeg = (strmucomp * secphr * vit_hr_incr) / (dtk * cosfac) - if (storm(ist)%tcv_lonew == 'W') then - rnewlon = rlon - udistdeg - else - rnewlon = rlon + udistdeg - endif - -c ------------------------------------------ -c This part updates the E/W and N/S characters -c in the event that a storm changes hemisphere. -c (N to S and S to N is not really possible, but -c we'll include the code anyway). If a storm -c does change hemisphere, say from W to E at 180, -c we need to also adjust the new longitude value -c from say 186W to 174E. Have to include this -c code since storm messages contain longitudes on -c a 0-180 basis (E&W), NOT 0-360. - - if (storm(ist)%tcv_latns == 'N') then - if (rnewlat < 0.) then - storm(ist)%tcv_latns = 'S' - rnewlat = -1. * rnewlat - endif - else - if (rnewlat < 0.) then - storm(ist)%tcv_latns = 'N' - rnewlat = -1. * rnewlat - endif - endif -c - if (storm(ist)%tcv_lonew == 'W') then - if (rnewlon > 180.) then - storm(ist)%tcv_lonew = 'E' - rnewlon = 180. - abs(rnewlon - 180.) - endif - else - if (rnewlon > 180.) then - storm(ist)%tcv_lonew = 'W' - rnewlon = 180. - abs(rnewlon - 180.) - endif - endif - - storm(ist)%tcv_lat = int ((rnewlat + 0.05) * 10.) - storm(ist)%tcv_lon = int ((rnewlon + 0.05) * 10.) - storm(ist)%tcv_yymmdd = ymd_now - storm(ist)%tcv_hhmm = hhmm_now - - endif - - ist = ist + 1 - - enddo -c - return - end - -c -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine delete_old_dups (storm,inowct,ioldct,okstorm) -c -c ABSTRACT: The purpose of this subroutine is to loop through the -c list of storms for the dtg from 3h or 6h ago to eliminate any -c duplicates. Be sure to sort based on storm identifier (e.g., -c 13L) instead of storm name, since the name may change (e.g., -c from "THIRTEEN" to "IRIS") for an upgrade in intensity, but the -c storm number identifier will remain the same. -c -c ict Total number of storm card entries for this dtg -c - USE def_vitals; USE set_max_parms -c - type (tcvcard) storm(maxstorm) - logical okstorm(maxstorm) - character found_dup*1 -c - ist = inowct + 1 - iend = inowct + ioldct - do while (ist < iend) - - isortnum = ist + 1 - found_dup = 'n' - if (okstorm(ist)) then - - do while (isortnum <= iend .and. found_dup == 'n') - - if (storm(ist)%tcv_storm_id == storm(isortnum)%tcv_storm_id) - & then - found_dup = 'y' - endif - isortnum = isortnum + 1 - - enddo - - endif - - if (found_dup == 'y') then - okstorm(ist) = .FALSE. - endif - - ist = ist + 1 - - enddo - -c NOTE: The last member of the array to be checked is okay, -c since all potential duplicates for this record were eliminated -c in the previous sort while loop just completed, and, further, -c the last member of this array is either already FALSE (from -c being checked off in delete_old), or it's TRUE because it -c didn't get checked off in delete_old, so keep it. - - return - end -c -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine delete_old (storm,inowct,ioldct,okstorm) -c -c ABSTRACT: This subroutine compares the list of storm card entries -c from 3h or 6h ago to those from the current time to eliminate -c any matching storms (i.e., if we've got a current record for a -c storm, we obviously don't need the old one). -c - USE def_vitals; USE set_max_parms -c - type (tcvcard) storm(maxstorm) -c - logical okstorm(maxstorm) - character found_dup*1 -c - ist = inowct + 1 - iend = inowct + ioldct - do while (ist <= iend) - - isortnum = 1 - found_dup = 'n' - do while (isortnum <= inowct .and. found_dup == 'n') - - if (storm(ist)%tcv_storm_id == storm(isortnum)%tcv_storm_id) - & then - found_dup = 'y' - endif - isortnum = isortnum + 1 - - enddo - - if (found_dup == 'y') then - okstorm(ist) = .FALSE. - endif - - ist = ist + 1 - - enddo - - return - end - -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine delete_future (storm,iprevct,ifuturect,okstorm) -c -c ABSTRACT: This subroutine compares the list of storm card entries -c from 3h or 6h ahead to those from the current time and from 3h or -c 6h ago to eliminate any matching storms (i.e., we only need the -c record for the future time if we don't have either a current time -c record or an old record that we've updated). -c - USE def_vitals; USE set_max_parms -c - type (tcvcard) storm(maxstorm) -c - logical okstorm(maxstorm) - character found_dup*1 -c - ist = iprevct + 1 - iend = iprevct + ifuturect - do while (ist <= iend) - - isortnum = 1 - found_dup = 'n' - do while (isortnum <= iprevct .and. found_dup == 'n') - - if (storm(ist)%tcv_storm_id == storm(isortnum)%tcv_storm_id) - & then - found_dup = 'y' - endif - isortnum = isortnum + 1 - - enddo - - if (found_dup == 'y') then - okstorm(ist) = .FALSE. - endif - - ist = ist + 1 - - enddo - - return - end - -c -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine delete_future_dups (storm,iprevct,ifuturect,okstorm) -c -c ABSTRACT: The purpose of this subroutine is to loop through the -c list of storms for the dtg from 3h or 6h ahead to eliminate any -c duplicates. Be sure to sort based on storm identifier (e.g., -c 13L) instead of storm name, since the name may change (e.g., -c from "THIRTEEN" to "IRIS") for an upgrade in intensity, but the -c storm number identifier will remain the same. -c -c ict Total number of storm card entries for this dtg -c - USE def_vitals; USE set_max_parms -c - type (tcvcard) storm(maxstorm) - logical okstorm(maxstorm) - character found_dup*1 -c - ist = iprevct + 1 - iend = iprevct + ifuturect - do while (ist < iend) - - isortnum = ist + 1 - found_dup = 'n' - if (okstorm(ist)) then - - do while (isortnum <= iend .and. found_dup == 'n') - - if (storm(ist)%tcv_storm_id == storm(isortnum)%tcv_storm_id) - & then - found_dup = 'y' - endif - isortnum = isortnum + 1 - - enddo - - endif - - if (found_dup == 'y') then - okstorm(ist) = .FALSE. - endif - - ist = ist + 1 - - enddo - -c NOTE: The last member of the array to be checked is okay, -c since all potential duplicates for this record were eliminated -c in the previous sort while loop just completed, and, further, -c the last member of this array is either already FALSE (from -c being checked off in delete_future), or it's TRUE because it -c didn't get checked off in delete_future, so keep it. - - return - end -c -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine delete_dups (storm,ict,okstorm) -c -c ABSTRACT: The purpose of this subroutine is to loop through the -c list of storms for the current dtg to eliminate any duplicates. -c Be sure to sort based on storm identifier (e.g.,13L) instead of -c storm name, since the name may change (e.g., from "THIRTEEN" to -c "IRIS") for an upgrade in intensity, but the storm number -c identifier will remain the same. -c -c ict Total number of storm card entries for this dtg -c - USE def_vitals; USE set_max_parms -c - type (tcvcard) storm(maxstorm) - logical okstorm(maxstorm) - character found_dup*1 -c - ist = 1 - do while (ist < ict) - - isortnum = ist + 1 - found_dup = 'n' - do while (isortnum <= ict .and. found_dup == 'n') - - if (storm(ist)%tcv_storm_id == storm(isortnum)%tcv_storm_id) - & then - found_dup = 'y' - endif - isortnum = isortnum + 1 - - enddo - - if (found_dup == 'y') then - okstorm(ist) = .FALSE. - endif - - ist = ist + 1 - - enddo - -c Now set the last member of the array to be checked as okay, -c since all potential duplicates for this record were eliminated -c in the previous sort while loop just completed. - - okstorm(ict) = .TRUE. -c - return - end -c -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine read_nlists (dnow,dold,dfuture,vit_hr_incr) -c -c ABSTRACT: Read in the namelists that contain the date for the -c current time, the time from 3h or 6h ago, and the time from 3h -c or 6h ahead . It also converts the input dates for the current -c time, the old time and the future time into a format that can -c be easily compared against the dates in the TC Vitals file. -c - USE inparms; USE date_checks -c - type (datecard) dnow,dold,dfuture -c - integer vit_hr_incr -c - namelist/datenowin/dnow - namelist/dateoldin/dold - namelist/datefuturein/dfuture - namelist/hourinfo/vit_hr_incr -c - read (5,NML=datenowin,END=801) - 801 continue - read (5,NML=dateoldin,END=803) - 803 continue - read (5,NML=datefuturein,END=805) - 805 continue - read (5,NML=hourinfo,END=807) - 807 continue -c - ymd_now = dnow%yy * 10000 + dnow%mm * 100 + dnow%dd - hhmm_now = dnow%hh * 100 - ymd_old = dold%yy * 10000 + dold%mm * 100 + dold%dd - hhmm_old = dold%hh * 100 - ymd_future = dfuture%yy * 10000 + dfuture%mm * 100 + dfuture%dd - hhmm_future = dfuture%hh * 100 -c - return - end -c -c---------------------------------------------------------------------- -c -c---------------------------------------------------------------------- - integer function char2int (charnum) -c -c This function takes as input a character numeral and -c returns the integer equivalent -c - character*1 charnum,cx(10) - data cx/'0','1','2','3','4','5','6','7','8','9'/ -c - do i=1,10 - if (charnum.eq.cx(i)) char2int = i-1 - enddo -c - return - end -c -c---------------------------------------------------------------------- -c -c---------------------------------------------------------------------- - character function int2char (inum) -c -c This function takes as input an integer and -c returns the character numeral equivalent -c - character*1 cx(10) - data cx/'0','1','2','3','4','5','6','7','8','9'/ -c - do i=1,10 - ihold=i-1 - if (ihold.eq.inum) int2char = cx(i) - enddo -c - return - end diff --git a/sorc/supvit.fd/supvit_modules.f b/sorc/supvit.fd/supvit_modules.f deleted file mode 100755 index 9172af58db..0000000000 --- a/sorc/supvit.fd/supvit_modules.f +++ /dev/null @@ -1,52 +0,0 @@ - module def_vitals - type tcvcard ! Define a new type for a TC Vitals card - character*4 tcv_center ! Hurricane Center Acronym - character*3 tcv_storm_id ! Storm Identifier (03L, etc) - character*9 tcv_storm_name ! Storm name - integer tcv_century ! 2-digit century id (19 or 20) - integer tcv_yymmdd ! Date of observation - integer tcv_hhmm ! Time of observation (UTC) - integer tcv_lat ! Storm Lat (*10), always >0 - character*1 tcv_latns ! 'N' or 'S' - integer tcv_lon ! Storm Lon (*10), always >0 - character*1 tcv_lonew ! 'E' or 'W' - integer tcv_stdir ! Storm motion vector (in degr) - integer tcv_stspd ! Spd of storm movement (m/s*10) - character*85 tcv_chunk ! Remainder of vitals record; - ! will just be read & written - end type tcvcard - end module def_vitals -c - module inparms - type datecard ! Define a new type for the input namelist parms - sequence - integer yy ! Beginning yy of date to search for - integer mm ! Beginning mm of date to search for - integer dd ! Beginning dd of date to search for - integer hh ! Beginning hh of date to search for - end type datecard - end module inparms -c - module date_checks - integer, save :: ymd_now,hhmm_now,ymd_old,hhmm_old - & ,ymd_future,hhmm_future - end module date_checks -c - module set_max_parms - integer, parameter :: maxstorm=400 ! max # of storms pgm can - ! handle - end module set_max_parms -c - module trig_vals - real, save :: pi, dtr, rtd - real, save :: dtk = 111194.9 ! Dist (m) over 1 deg lat - ! using erad=6371.0e+3 - real, save :: erad = 6371.0e+3 ! Earth's radius (m) - real, save :: ecircum = 40030200 ! Earth's circumference - ! (m) using erad=6371.e3 - real, save :: omega = 7.292e-5 - real, save :: secphr = 3600. - end module trig_vals -c -c------------------------------------------------------ -c diff --git a/sorc/syndat_getjtbul.fd/CMakeLists.txt b/sorc/syndat_getjtbul.fd/CMakeLists.txt deleted file mode 100644 index 9659f0a275..0000000000 --- a/sorc/syndat_getjtbul.fd/CMakeLists.txt +++ /dev/null @@ -1,15 +0,0 @@ -list(APPEND fortran_src - getjtbul.f -) - -if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -assume noold_ldout_format") -endif() - -set(exe_name syndat_getjtbul.x) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - w3nco::w3nco_4) - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/syndat_getjtbul.fd/getjtbul.f b/sorc/syndat_getjtbul.fd/getjtbul.f deleted file mode 100755 index c6e93f752b..0000000000 --- a/sorc/syndat_getjtbul.fd/getjtbul.f +++ /dev/null @@ -1,248 +0,0 @@ -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C -C MAIN PROGRAM: SYNDAT_GETJTBUL RETRIEVES JTWC BULLETINS FROM TANK -C PRGMMR: STOKES ORG: NP23 DATE: 2013-02-22 -C -C ABSTRACT: RETRIEVES TROPICAL CYCLONE POSITION AND INTENSITY -C INFORMATION FROM JOINT TYPHOON WARNING CENTER/FNMOC. THESE -C BULLETINS COME IN TWO PIECES. THIS PROGRAM READS THEM AND -C JOINS THEM TOGETHER. THIS ALLOWS THE DOWNSTREAM PROGRAM -C QCTROPCY TO PROCESS THEM. -C -C PROGRAM HISTORY LOG: -C 1997-06-23 S. J. LORD ---- ORIGINAL AUTHOR -C 1998-11-24 D. A. KEYSER -- FORTRAN 90/Y2K COMPLIANT -C 1998-12-30 D. A. KEYSER -- MODIFIED TO ALWAYS OUTPUT RECORDS -C CONTAINING A 4-DIGIT YEAR (REGARDLESS OF INPUT) -C 2000-03-09 D. A. KEYSER -- MODIFIED TO RUN ON IBM-SP; CORRECTED -C PROBLEM FROM EARLIER CRAY VERSION WHICH RESULTED -C IN AN INCORRECT JOINING OF PIECES IF THE SAME -C 2-PIECE BULLETIN IS DUPLICATED IN THE ORIGINAL FILE -C THAT IS READ IN BY THIS PROGRAM -C 2013-02-22 D. C. STOKES -- MINOR DOC CHANGES. (WCOSS TRANSIITON) -C -C USAGE: -C INPUT FILES: -C UNIT 11 - FILE CONTAINING JTWC/FNMOC BULLETINS -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C UNIT 51 - FILE CONTAINING JTWC/FNMOC BULLETINS NOW JOINED -C TOGETHER -C -C SUBPROGRAMS CALLED: -C UNIQUE: - NONE -C LIBRARY: -C W3NCO - W3TAGB W3TAGE ERREXIT -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN, DATA RETRIEVED -C = 1 - SUCCESSFUL RUN -- NO DATA RETRIEVED -C = 20 - TROUBLE - EITHER READ ERROR WITHIN PROGRAM OR -C NUMBER OF RECORDS IN INPUT FILE EXCEEDS PROGRAM -C LIMIT. -C -C REMARKS: THE Y2K-COMPLIANT VERSION IS SET-UP TO READ RECORDS WITH -C EITHER A 2-DIGIT YEAR STARTING IN COLUMN 20 OR A 4-DIGIT -C YEAR STARTING IN COLUMN 20. THIS WILL ALLOW THIS PROGRAM -C TO RUN PROPERLY WHEN JTWC/FNMOC TRANSITIONS RECORDS TO -C A 4-DIGIT YEAR. -C -C ATTRIBUTES: -C LANGUAGE FORTRAN 90 -C MACHINE: IBM SP and IBM iDataPlex -C -C$$$ - PROGRAM SYNDAT_GETJTBUL - - PARAMETER (NBULS=200) - - CHARACTER*1 INL1(80) - CHARACTER*9 STNAME - CHARACTER*18 HEAD(NBULS),CHEKHED - CHARACTER*37 ENDMSG - CHARACTER*80 INL,INLS(NBULS) - CHARACTER*80 DUMY2K - CHARACTER*95 OUTL - - INTEGER LINE(NBULS) - - EQUIVALENCE (INL1,INL) - - DATA IIN/11/,IOUT/51/,LINE/NBULS*0/ - - CALL W3TAGB('SYNDAT_GETJTBUL',2013,0053,0050,'NP23 ') - - WRITE(6,*) ' ' - WRITE(6,*) '===> WELCOME TO SYNDAT_GETJTBUL - F90/Y2K VERSION ', - $ '02-22-2013' - WRITE(6,*) ' ' - WRITE(6,*) ' ' - - NLINE = 0 - - DO N=1,NBULS - INL1=' ' - READ(IIN,2,END=100,ERR=200) INL - 2 FORMAT(A80) - NLINE = N - -C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20 -c OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR -c BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF -c LATITUDE BLANK CHARACTER TO FIND OUT ... - - IF(INL1(26).EQ.' ') THEN - -c ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR - -c ... THIS PROGRAM WILL NOW CONVERT THE RECORD TO A 4-DIGIT YEAR USING -c THE "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> This is an old-format record with a 2-digit ', - $ 'year "',INL(20:21),'"' - PRINT *, ' ' - DUMY2K(1:19) = INL(1:19) - IF(INL(20:21).GT.'20') then - DUMY2K(20:21) = '19' - ELSE - DUMY2K(20:21) = '20' - ENDIF - DUMY2K(22:80) = INL(20:80) - INL= DUMY2K - PRINT *, ' ' - PRINT *, '==> 2-digit year converted to 4-digit year "', - $ INL(20:23),'" via windowing technique' - PRINT *, ' ' - - ELSE - -c ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR -c ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> This is an new-format record with a 4-digit ', - $ 'year "',INL(20:23),'"' - PRINT *, ' ' - PRINT *, '==> No conversion necessary' - PRINT *, ' ' - end if - - WRITE(6,3) NLINE,INL - 3 FORMAT(' ...Bulletin line number',I4,' is....',A80,'...') - INLS(NLINE)=INL - HEAD(NLINE)=INL(1:18) - WRITE(6,4) NLINE,HEAD(NLINE) - 4 FORMAT(' ... Header for line number',I4,' is ...',A18,'...') - ENDDO - -C Come here if no. of records in input file exceeds pgm limit ("NBULS") -C --------------------------------------------------------------------- - - WRITE(6,301) NBULS - 301 FORMAT(' **** Number of records in input File exceeds program ', - $ 'limit of',I4,'. Abort') - ICODE=20 - ENDMSG='SYNDAT_GETJTBUL TERMINATED ABNORMALLY' - GO TO 900 - - 100 CONTINUE - -C All records read in -C ------------------- - - IF(NLINE.EQ.0) THEN - -C Come here if ZERO records were read from input file -C --------------------------------------------------- - - ICODE=1 - WRITE(6,101) - 101 FORMAT(' ...No Bulletins available.') - ENDMSG='SYNDAT_GETJTBUL TERMINATED NORMALLY ' - GO TO 900 - ENDIF - - IF(MOD(NLINE,2).NE.0) THEN - -C Come here if number of records read was not even -C ------------------------------------------------ - - WRITE(6,111) NLINE - 111 FORMAT(' **** Number of records read in (=',I4,') is not ', - $ 'even. Abort') - ICODE=20 - ENDMSG='SYNDAT_GETJTBUL TERMINATED ABNORMALLY' - GO TO 900 - ENDIF - - PRINT *, ' ' - PRINT *, ' ' - NBULT=NLINE/2 - NBUL=0 - LOOP1: DO NL=1,NLINE - IF(LINE(NL).EQ.1) CYCLE LOOP1 - CHEKHED=HEAD(NL) - IFND = 0 - LOOP1n1: DO NB=NL+1,NLINE - IF(LINE(NB).EQ.1) CYCLE LOOP1n1 - NBSAV=NB - WRITE(6,11) CHEKHED,INLS(NB)(1:18) - 11 FORMAT(' ...message parts are ...',A18,'...',A18,'...') - IF(CHEKHED .EQ. INLS(NB)(1:18)) THEN - LINE(NL) = 1 - LINE(NB) = 1 - IFND = 1 - EXIT LOOP1n1 - ENDIF - ENDDO LOOP1n1 - IF(IFND.EQ.1) THEN - WRITE(6,131) INLS(NL)(10:10) - 131 FORMAT(' ...inls(nl)(10:10)=',A1,'...') - IF(INLS(NL)(10:10).eq.' ') THEN - LOOP 1n2: DO IB=11,18 - IS=IB - IF(INLS(NL)(IS:IS).NE.' ') EXIT LOOP 1n2 - ENDDO LOOP 1n2 - STNAME=' ' - STNAME=INLS(NL)(IS:18) - INLS(NL)(10:18)=STNAME - ENDIF - OUTL=INLS(NL)(1:66)//INLS(NBSAV)(33:61) - WRITE(6,145) OUTL - 145 FORMAT(' ...Complete bulletin is ...',A95,'...') - WRITE(IOUT,22) OUTL - 22 FORMAT(A95) - NBUL=NBUL+1 - ENDIF - IF(NBUL .EQ. NBULT) GO TO 150 - ENDDO LOOP1 - - 150 CONTINUE - WRITE(6,151) NBUL - 151 FORMAT(' ...',I4,' bulletins have been made.') - ICODE=0 - ENDMSG='SYNDAT_GETJTBUL TERMINATED NORMALLY ' - GO TO 900 - - 200 continue - -C Come here if error reading a record from input file -C --------------------------------------------------- - - WRITE(6,201) - 201 FORMAT(' **** ERROR READING RECORD FROM INPUT FILE. ABORT') - ICODE=20 - ENDMSG='SYNDAT_GETJTBUL TERMINATED ABNORMALLY' - - 900 CONTINUE - - WRITE(6,*) ENDMSG - - CALL W3TAGE('SYNDAT_GETJTBUL') - - IF(ICODE.GT.0) CALL ERREXIT(ICODE) - - STOP - - END diff --git a/sorc/syndat_getjtbul.fd/makefile b/sorc/syndat_getjtbul.fd/makefile deleted file mode 100755 index 3ac5730f31..0000000000 --- a/sorc/syndat_getjtbul.fd/makefile +++ /dev/null @@ -1,23 +0,0 @@ -SHELL= /bin/sh -#LIBS= -L/nwprod/lib -lw3nco_v2.0.5_4 -#LIBS= -L/contrib/nceplibs/nwprod/lib -lw3nco_v2.0.5_4 -FC= ifort -#DEBUG = -ftrapuv -check all -fp-stack-check -fstack-protector -##DEBUG = -ftrapuv -fp-stack-check -fstack-protector -FFLAGS= -O3 -g -traceback -assume noold_ldout_format $(DEBUG) -LDFLAGS= -SRCS= getjtbul.f -OBJS= getjtbul.o -CMD= syndat_getjtbul - -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(LIBS_SYN_GET) - -clean: - -rm -f $(OBJS) - -install: - -mv $(CMD) ../../exec/$(CMD) - diff --git a/sorc/syndat_maksynrc.fd/CMakeLists.txt b/sorc/syndat_maksynrc.fd/CMakeLists.txt deleted file mode 100644 index 38893bbeb0..0000000000 --- a/sorc/syndat_maksynrc.fd/CMakeLists.txt +++ /dev/null @@ -1,15 +0,0 @@ -list(APPEND fortran_src - maksynrc.f -) - -if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -assume noold_ldout_format") -endif() - -set(exe_name syndat_maksynrc.x) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - w3nco::w3nco_4) - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/syndat_maksynrc.fd/makefile b/sorc/syndat_maksynrc.fd/makefile deleted file mode 100755 index 9adcb17e26..0000000000 --- a/sorc/syndat_maksynrc.fd/makefile +++ /dev/null @@ -1,21 +0,0 @@ -SHELL= /bin/sh -#LIBS= -L/nwprod/lib -lw3nco_v2.0.5_4 -lbacio_v2.0.1_4 -##LIBS_SYN_MAK= -L/contrib/nceplibs/nwprod/lib -lw3nco_v2.0.5_4 -lbacio_v2.0.1_4 -FC= ifort -#DEBUG = -ftrapuv -check all -check nooutput_conversion -fp-stack-check -fstack-protector -FFLAGS= -O3 -g -traceback -assume noold_ldout_format $(DEBUG) -LDFLAGS= -SRCS= maksynrc.f -OBJS= maksynrc.o -CMD= syndat_maksynrc - -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(LIBS_SYN_MAK) - -clean: - -rm -f $(OBJS) - -install: - mv $(CMD) ../../exec/$(CMD) diff --git a/sorc/syndat_maksynrc.fd/maksynrc.f b/sorc/syndat_maksynrc.fd/maksynrc.f deleted file mode 100755 index dca5de2575..0000000000 --- a/sorc/syndat_maksynrc.fd/maksynrc.f +++ /dev/null @@ -1,472 +0,0 @@ -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C -C MAIN PROGRAM: SYNDAT_MAKSYNRC MAKE SYNDAT RECORD FROM HUMAN INPUT -C PRGMMR: STOKES ORG: NP23 DATE: 2013-03-15 -C -C ABSTRACT: QUERIES HUMAN INPUT FOR INFORMATION TO CONSTRUCT TROPICAL -C CYCLONE SYNTHETIC DATA RECORD AND WRITES RECORD TO FORTRAN -C UNIT 51 -C -C PROGRAM HISTORY LOG: -C 1997-06-26 S. J. LORD ---- ORIGINAL AUTHOR -C 1998-11-23 D. A. KEYSER -- FORTRAN 90 AND Y2K COMPLIANT -C 1998-12-30 D. A. KEYSER -- MODIFIED TO OUTPUT RECORDS CONTAINING A -C 4-DIGIT YEAR -C 2000-03-03 D. A. KEYSER -- CONVERTED TO RUN ON IBM-SP MACHINE -C 2013-03-15 D. C. STOKES -- Modified some stdout writes to display -C cleanly as part of WCOSS transition. -C -C USAGE: -C INPUT FILES: -C UNIT 05 - INPUT FILE FOR HUMAN (KEYBOARD ENTRY) -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C UNIT 51 - SYNTHETIC DATA RECORD (ONE PER RUN) -C -C SUBPROGRAMS CALLED: -C UNIQUE: - BEGINE ENDE MAKVIT NSEW -C LIBRARY: -C W3LIB: - W3TAGB W3TAGE -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE FORTRAN 90 -C MACHINE: IBM-SP, IBM-iDataPlex -C -C$$$ - program SYNDAT_MAKSYNRC - logical fstflg - character rsmc*4,stmnam*9,stmid*3 - data iuntvi/51/,fstflg/.false./ - - CALL W3TAGB('SYNDAT_MAKSYNRC',2013,0074,0000,'NP23 ') - - write(6,*) "Welcome to the Synthetic Data Record Maker" - write(6,*) "+++ FORTRAN 90 / Y2K VERSION +++" - write(6,*) "+++ 03 March 2000 +++" - write(6,*) "Please follow all directions carefully, paying" - write(6,*) "careful attention to the Units as units" - write(6,*) "conversions are hardwired" - - call begine - write(6,*) 'Enter Storm Name (UPPER CASE)' - read(5,1) stmnam - 1 format(a) - write(6,2) stmnam - 2 format(' Storm name is:',a9) - call ende - - call begine - write(6,*) 'Enter Storm Identifier (e.g. 03P)' - read(5,11) stmid - 11 format(a) - write(6,12) stmid - 12 format(' Storm Identifier is:',a3) - call ende - - call begine - write(6,*) 'Enter Organization ID (e.g. NHC, JTWC)' - read(5,11) rsmc - write(6,13) rsmc - 13 format(' Organization Identifier is:',a4) - call ende - - call begine - write(6,*) 'Enter date (yyyymmdd)' - read(5,*) idate - write(6,*) 'Date is: ',idate - call ende - - call begine - write(6,*) 'Enter hour (hh)' - read(5,*) ihour - iutc=ihour*100 - write(6,*) 'Hour is: ',ihour - call ende - - call begine - write(6,*) 'Enter storm latitude (negative for south)' - read(5,*) stmlat - write(6,'(x,a,f5.1)') 'Storm latitude is: ',stmlat - call ende - - call begine - write(6,*) 'Enter storm longitude (DEG EAST)' - read(5,*) stmlon - write(6,'(x,a,f5.1)') 'Storm longitude is: ',stmlon - call ende - - call begine - write(6,*) 'Enter storm direction (DEG FROM NORTH)' - read(5,*) stmdir - write(6,'(x,a,f4.0)') 'Storm direction is: ',stmdir - call ende - - call begine - write(6,*) 'Enter storm speed (KNOTS)' - read(5,*) stmspd - write(6,'(x,a,f6.2)') 'Storm speed is: ',stmspd - stmspd=stmspd/1.94 - call ende - - call begine - write(6,*) 'Enter storm central pressure (MB)' - read(5,*) pcen - write(6,'(x,a,f5.0)') 'Storm central pressure is: ',pcen - call ende - - call begine - write(6,*) 'Enter storm environmental pressure (MB)' - read(5,*) penv - write(6,'(x,a,f5.0)') 'Storm environmental pressure is: ',penv - call ende - - call begine - write(6,*) 'Enter estimated maximum wind (KNOTS)' - read(5,*) vmax - write(6,'(x,a,f4.0)') 'Estimated maximum wind (KNOTS) is: ',vmax - vmax=vmax/1.94 - call ende - - call begine - write(6,*) 'Enter estimated radius of outermost closed ', - 1'isobar (ROCI), i.e. size of the storm circulation (KM)' - read(5,*) rmax - write(6,'(x,a,f5.0)') 'Estimated ROCI (KM) is: ',rmax - call ende - - call begine - write(6,*) 'Enter estimated radius of maximum wind (KM)' - read(5,*) rmw - write(6,'(x,a,f5.0)') - 1 'Estimated radius of maximum wind (KM) is: ',rmw - call ende - - call begine - call nsew - write(6,*) 'Enter estimated radius of 15 m/s (35 knot) winds (KM)' - write(6,*) - 1 'in each each of the following quadrants (e.g. 290 222 200 180)' - write(6,*) 'Note: numbers must be separated by blanks' - write(6,*) 'Note: numbers must be in the order NE SE SW NW and be' - 1 ,' separated by blanks' - write(6,*) 'Note: enter all negative numbers to denote no ', - 1'estimate' - read(5,*) r15ne,r15se,r15sw,r15nw - write(6,'(x,a,4f8.0)') - 1 'Estimated radius of 15 m/s (35 knot) winds is: ', - 2 r15ne,r15se,r15sw,r15nw - call ende - - call begine - call nsew - write(6,*) 'Enter estimated radius of 26 m/s (55 knot) winds (KM)' - write(6,*) - 1 'in each each of the following quadrants (e.g. 50 50 50 50)' - write(6,*) 'Note: numbers must be separated by blanks' - write(6,*) 'Note: numbers must be in the order NE SE SW NW and be' - 1'separated by blanks' - write(6,*) 'Note: enter all negative numbers to denote no ', - 1'estimate' - read(5,*) r26ne,r26se,r26sw,r26nw - write(6,'(x,a,4f8.0)') - 1 'Estimated radius of 26 m/s (35 knot) winds is: ', - 2 r26ne,r26se,r26sw,r26nw - call ende - - call begine - write(6,*) 'Enter estimated top of cyclonic circulation (mb)' - read(5,*) ptop - write(6,'(x,a,f7.1)') - 1 'Estimated top of cyclonic circulation (mb) is: ',ptop - call ende - - call begine - write(6,*) 'Enter estimated latitude at maximum forecast time ' - write(6,*) '(negative for south)' - write(6,*) 'Note: enter -99.0 to denote no estimate' - read(5,*) fclat - write(6,'(x,a,f5.1)') - 1 'Estimated latitude at maximum forecast time is: ', fclat - call ende - - call begine - write(6,*) 'Enter estimated longitude at maximum forecast time ' - write(6,*) '(DEG EAST)' - write(6,*) 'Note: enter a negative number to denote no estimate' - read(5,*) fclon - write(6,'(x,a,f5.1)') - 1 'Estimated longitude at maximum forecast time is: ', fclon - call ende - - call begine - write(6,*) 'Enter maximum forecast time (hours, e.g. 72)' - write(6,*) 'Note: enter a negative number to denote no estimate' - read(5,*) fcstp - write(6,'(x,a,f4.0)') 'Maximum forecast time is: ',fcstp - call ende - - CALL MAKVIT(IUNTVI,IDATE,IUTC,STMLAT,STMLON,STMDIR,STMSPD, - 1 PCEN,PENV,RMAX,VMAX,RMW,R15NE,R15SE,R15SW, - 2 R15NW,PTOP,STMNAM,STMID,RSMC,FSTFLG,r26ne, - 3 r26se,r26sw,r26nw,fcstp,fclat,fclon) - - CALL W3TAGE('SYNDAT_MAKSYNRC') - stop - end - SUBROUTINE BEGINE - write(6,1) - 1 format(' ') - write(6,11) - 11 format(' *******************************************************') - return - end - - SUBROUTINE ENDE - write(6,1) - 1 format(' *******************************************************') - write(6,11) - 11 format(' ') - return - end -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: MAKVIT CREATES TROP. CYCLONE VITAL. STAT. DATA -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-12-30 -C -C ABSTRACT: CREATES TROPICAL CYCLONE VITAL STATISTICS RECORDS FROM -C RAW INFORMATION SUCH AS LATITUDE, LONGITUDE, MAX. WINDS ETC. -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD ---- ORIGINAL AUTHOR -C 1998-11-23 D. A. KEYSER -- FORTRAN 90 AND Y2K COMPLIANT -C 1998-12-30 D. A. KEYSER -- MODIFIED TO OUTPUT RECORDS CONTAINING A -C 4-DIGIT YEAR -C -C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... ) -C INPUT ARGUMENT LIST: -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C DDNAME1 - GENERIC NAME & CONTENT -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE -C FT06F001 - INCLUDE IF ANY PRINTOUT -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: CRAY, SGI -C -C$$$ - SUBROUTINE MAKVIT(IUNTVI,IDATE,IUTC,STMLAT,STMLON,STMDIR,STMSPD, - 1 PCEN,PENV,RMAX,VMAX,RMW,R15NE,R15SE,R15SW, - 2 R15NW,PTOP,STMNAM,STMID,RSMC,FSTFLG,r26ne, - 3 r26se,r26sw,r26nw,fcstp,fclat,fclon) -C - SAVE -C - CHARACTER *(*) RSMC,STMNAM,STMID - LOGICAL FSTFLG -C - PARAMETER (MAXCHR=129) - PARAMETER (MAXVIT=22) - PARAMETER (MAXTPC= 3) -C - CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1, - 1 SHALO*1,MEDIUM*1, - 2 DEEP*1,LATNS*1,LONEW*1,FMTVIT*6,FMTMIS*4,BUFINZ*129, - 3 RELOCZ*1,STMTPC*1,EXE*1, - 7 latnsf,lonewf -C - DIMENSION IVTVAR(MAXVIT),VITVAR(MAXVIT),VITFAC(MAXVIT), - 1 ISTVAR(MAXVIT),IENVAR(MAXVIT),STMTOP(0:MAXTPC) -C - DIMENSION BUFIN(MAXCHR),STMTPC(0:MAXTPC),FMTVIT(MAXVIT), - 1 MISSNG(MAXVIT),FMTMIS(MAXVIT) -C - EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ), - 1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ), - 2 (BUFIN(37),LATNS),(BUFIN(43),LONEW), - 3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ), - 4 (BUFIN(123),LATNSF),(BUFIN(129),LONEWF) -C - EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ) -C - EQUIVALENCE (VITVAR( 3),STMLTZ),(VITVAR( 4),STMLNZ), - 1 (VITVAR( 5),STMDRZ),(VITVAR( 6),STMSPZ), - 2 (VITVAR( 7),PCENZ), (VITVAR( 8),PENVZ), - 3 (VITVAR( 9),RMAXZ), (VITVAR(10),VMAXZ), - 4 (VITVAR(11),RMWZ), (VITVAR(12),R15NEZ), - 5 (VITVAR(13),R15SEZ),(VITVAR(14),R15SWZ), - 6 (VITVAR(15),R15NWZ),(VITVAR(16),R26NEZ), - 7 (VITVAR(17),R26SEZ),(VITVAR(18),R26SWZ), - 8 (VITVAR(19),R26NWZ),(VITVAR(20),FCSTPZ), - 9 (VITVAR(21),FCLATZ),(VITVAR(22),FCLONZ) -C - EQUIVALENCE (STMTPC(0), EXE),(STMTPC(1),SHALO),(STMTPC(2),MEDIUM), - 1 (STMTPC(3),DEEP) -C - DATA SHALO/'S'/,MEDIUM/'M'/,DEEP/'D'/,EXE/'X'/, - 2 VITFAC/2*1.0,2*0.1,1.0,0.1,14*1.0,2*0.1/, - 3 FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)', - 4 3*'(I4.4)','(I2.2)','(I3.3)',8*'(I4.4)','(I2.2)', - 5 '(I3.3)','(I4.4)'/, - 6 FMTMIS/'(I8)','(I4)','(I3)','(I4)',2*'(I3)',3*'(I4)', - 7 '(I2)','(I3)',8*'(I4)','(I2)','(I3)','(I4)'/, - 8 MISSNG/-9999999,-999,-99,-999,2*-99,3*-999,-9,-99,8*-999,-9, - 9 -99,-999/, - O ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90, 97,102, - O 107,112,117,120,125/, - 1 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93,100,105, - 1 110,115,118,122,128/, - 3 STMTOP/-99.0,700.,400.,200./ -C - BUFINZ=' ' - RSMCZ=RSMC -cvvvvvy2k - -C NOTE: This program OUTPUTS a record containing a 4-digit year - for -C example: - -C NHC 13L MITCH 19981028 1800 164N 0858W 270 010 0957 1008 0371 51 019 0278 0278 0185 0185 D -C 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345 ... -C 1 2 3 4 5 6 7 8 9 ... - -C This program will truncate the integer work containing the -C date in the form yyyymmdd to the form yymmdd prior to writing -C it into the output record. -cppppp - print *, ' ' - print *, ' ' - print *, '==> tcvitals file can now contain a 4-digit year, so ', - $ 'no conversion is necessary since 4-digit year is input' - print *, ' ' - print *, ' ' -cppppp -caaaaay2k - IDATEZ=IDATE - IUTCZ=IUTC - STMNMZ=STMNAM - STMIDZ=STMID - STMLTZ=STMLAT -C - IF(STMLTZ .GE. 0.0) THEN - LATNS='N' - ELSE - LATNS='S' - STMLTZ=ABS(STMLTZ) - ENDIF -C - IF(STMLON .GE. 180.) THEN - STMLNZ=360.-STMLON - LONEW='W' -C - ELSE - STMLNZ=STMLON - LONEW='E' - ENDIF -C - IF(fclat .GE. 0.0) THEN - fclatz=fclat - latnsf='N' - ELSE if (fclat .gt. -90.) then - latnsf='S' - fclatz=ABS(fclat) -c - else - latnsf='S' - fclatz=-99.9 - ENDIF -C - IF(fclon .GE. 180.) THEN - fclonz=360.-fclon - lonewf='W' -C - ELSE if (fclon .gt. 0.) then - fclonz=fclon - lonewf='E' -c - else - fclonz=-999.9 - lonewf='E' - ENDIF -C - STMDRZ=STMDIR - STMSPZ=STMSPD - PCENZ =PCEN - PENVZ =PENV - RMAXZ =RMAX - VMAXZ =VMAX - RMWZ =RMW - R15NEZ=R15NE - R15SEZ=R15SE - R15SWZ=R15SW - R15NWZ=R15NW - r26nez=r26ne - r26sez=r26se - r26swz=r26sw - r26nwz=r26nw - fcstpz=fcstp -C - FSTFLZ=' ' - IF(FSTFLG) FSTFLZ=':' -C - DO IV=1,2 - IF(IVTVAR(IV) .GE. 0) THEN - WRITE(BUFINZ(ISTVAR(IV):IENVAR(IV)),FMTVIT(IV)) IVTVAR(IV) - ELSE - WRITE(BUFINZ(ISTVAR(IV):IENVAR(IV)),FMTMIS(IV)) MISSNG(IV) - ENDIF - ENDDO -C - DO IV=3,MAXVIT - IF(VITVAR(IV) .GE. 0) THEN - IVTVAR(IV)=NINT(VITVAR(IV)/VITFAC(IV)) - WRITE(BUFINZ(ISTVAR(IV):IENVAR(IV)),FMTVIT(IV)) IVTVAR(IV) - ELSE - WRITE(BUFINZ(ISTVAR(IV):IENVAR(IV)),FMTMIS(IV)) MISSNG(IV) - ENDIF - ENDDO -C - DO ITOP=0,MAXTPC - IF(PTOP .EQ. STMTOP(ITOP)) THEN - STMDPZ=STMTPC(ITOP) - GO TO 31 - ENDIF - ENDDO - - 31 CONTINUE -C - IF(IUNTVI .GT. 0) THEN - WRITE(IUNTVI,41) BUFINZ - 41 FORMAT(A) - WRITE(6,43) BUFINZ - 43 FORMAT(' ...',A,'...') - ELSE - WRITE(6,43) BUFINZ - ENDIF -C - RETURN - END - - SUBROUTINE NSEW - write(6,*) ' Quadrants' - write(6,*) ' NW : NE' - write(6,*) '----------- Order of quadrants: NE SE SW NW' - write(6,*) ' SW : SE' - return - end diff --git a/sorc/syndat_qctropcy.fd/CMakeLists.txt b/sorc/syndat_qctropcy.fd/CMakeLists.txt deleted file mode 100644 index b8814c29ca..0000000000 --- a/sorc/syndat_qctropcy.fd/CMakeLists.txt +++ /dev/null @@ -1,17 +0,0 @@ -list(APPEND fortran_src - qctropcy.f -) - -if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -i8 -r8 -assume byterecl -assume noold_ldout_format") -elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-integer-8 -fdefault-real-8") -endif() - -set(exe_name syndat_qctropcy.x) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - w3nco::w3nco_8) - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/syndat_qctropcy.fd/makefile b/sorc/syndat_qctropcy.fd/makefile deleted file mode 100755 index d667c26cbe..0000000000 --- a/sorc/syndat_qctropcy.fd/makefile +++ /dev/null @@ -1,23 +0,0 @@ -SHELL= /bin/sh -#LIBS= -L/nwprod/lib -lw3nco_v2.0.5_8 -##LIBS= -L/contrib/nceplibs/nwprod/lib -lw3nco_v2.0.5_8 -FC= ifort -#DEBUG = -ftrapuv -check all -check noarg_temp_created -fp-stack-check -fstack-protector -## if '-check all' enabled, include '-check noarg_temp_created' to avoid warning msgs indicating -## slight performance hit due to chosen method of passing array arguments to w3difdat -FFLAGS= -O3 -g -traceback -r8 -i8 -assume byterecl -assume noold_ldout_format $(DEBUG) -LDFLAGS= -SRCS= qctropcy.f -OBJS= qctropcy.o -CMD= syndat_qctropcy - -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(LIBS_SYN_QCT) - -clean: - -rm -f $(OBJS) - -install: - mv $(CMD) ../../exec/$(CMD) diff --git a/sorc/syndat_qctropcy.fd/qctropcy.f b/sorc/syndat_qctropcy.fd/qctropcy.f deleted file mode 100755 index e6bfadebd4..0000000000 --- a/sorc/syndat_qctropcy.fd/qctropcy.f +++ /dev/null @@ -1,12099 +0,0 @@ -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C -C MAIN PROGRAM: SYNDAT_QCTROPCY PERFORMS QC ON TROP. CYCLONE BULLETINS -C PRGMMR: KEYSER ORG: NP22 DATE: 2008-07-10 -C -C ABSTRACT: PERFORMS QUALITY CONTROL ON TROPICAL CYCLONE POSITION -C AND INTENSITY INFORMATION (T. C. VITAL STATISTICS). CHECKS -C PERFORMED ARE: DUPLICATE RECORDS, APPROPRIATE DATE/TIME, PROPER -C RECORD STRUCTURE (BLANKS IN PROPER PLACE AND NO IMPROPER NON- -C INTEGER NUMBERS), STORM NAME/ID NUMBER, RECORDS FROM MULTIPLE -C INSTITUTIONS, SECONDARY VARIABLES (E.G. CENTRAL PRESSURE), -C STORM POSITION AND DIRECTION/SPEED. EMPHASIS IS ON INTERNAL -C CONSISTENCY BETWEEN REPORTED STORM LOCATION AND PRIOR MOTION. -C -C PROGRAM HISTORY LOG: -C 1991-03-27 S. J. LORD -C 1991-07-18 S. J. LORD ADDED ROUTINE FSTSTM, MODIFIED ADFSTF -C 1992-01-22 S. J. LORD CHANGED W3FS12,W3FS13 CALLS TO W3FS19, W3FS17 -C 1992-02-19 S. J. LORD ADDED MULTIPLE RSMC CHECK -C 1992-04-09 S. J. LORD CHANGED SLMASK TO T126 FROM T80 -C 1992-05-20 S. J. LORD CORRECTED BUG IN SELACK CALL -C 1992-06-09 J. JOHNSON CHANGED COND=10 TO COND=4 FOR SUCCESSFUL RUN -C BUT WITH EMPTY INPUT FILES -C 1992-07-01 S. J. LORD ADDED DATE CHECK AND REVISED RITCUR -C 1992-07-10 S. J. LORD REVISED STIDCK TO DISMANTLE CONSISTENCY -C CHECKS IN THE CASE OF NUMBERED DEPRESSIONS -C 1992-07-16 S. J. LORD FIXED SOME BUGS IN RSMCCK -C 1992-08-20 S. J. LORD ADDED THE JTWC MEMORIAL SWITCH CHECK -C 1992-08-20 S. J. LORD MODIFIED DUPCHK TO ADD A NEW INPUT UNIT -C 1992-09-04 S. J. LORD ADDED PRESSURE WIND RELATIONSHIP TO SECVCK -C 1992-09-09 S. J. LORD ADDED CENTRAL PACIFIC NAMES AND NAME CHECK -C 1992-09-18 S. J. LORD ADDED CHECK FOR CORRECT MISSING DATA IN READCK -C 1992-10-28 S. J. LORD ADDED GREEK ALPHABET STORM NAMES -C 1992-12-14 S. J. LORD MODIFIED CONSOLE MESSAGE FOR ISTOP=4 -C 1993-03-05 S. J. LORD IMPLEMENTED STORM CATALOG (RCNCIL) -C 1993-03-31 S. J. LORD IMPLEMENTED READING STORM NAMES FROM EXTERNAL -C FILE IN STIDCK -C 1993-04-08 S. J. LORD IMPLEMENTED WEST PACIFIC CLIPER -C 1993-08-25 S. J. LORD ADDER RETURN CODE OF 10 FOR RCNCIL LOGICAL -C ERROR -C 1993-08-25 S. J. LORD UPGRADED STORM ID CHECKING FOR STORMS CHANGING -C 1994-06-20 S. J. LORD MODIFIED MAXCHK FOR THE GFDL FORMAT -C 1996-04-12 S. J. LORD REMOVED CALL TO DRSPCK -C 1997-06-24 S. J. LORD ADDED NEW UNIT FOR MANUALLY ENTERED MESSAGES -C 1998-03-24 S. J. LORD MODIFIED VITDATN.INC AND VITFMTN.INC TO -C RECOGNIZE RSMC ID "NWOC" (THIS HAD BEEN UNRECOGNIZED -C AND HAD CAUSED THE PROGRAM TO STOP 20); REMOVED -C UNINITIALIZED VARIABLES THAT WERE CAUSING COMPILER -C WARNINGS -C 1998-06-05 D.A. KEYSER - FORTRAN 90 AND Y2K COMPLIANT -C 1998-06-18 S.J. LORD - FORTRAN 90 AND Y2K COMPLIANT (vitfmt.inc) -C 1998-08-16 S.J. LORD - FORTRAN 90 AND Y2K COMPLIANT (completed) -C 1998-12-14 D. A. KEYSER - Y2K/F90 COMPLIANCE, STREAMLINED CODE; -C 2000-03-03 D. A. KEYSER - CONVERTED TO RUN ON IBM-SP MACHINE -C 2001-02-07 D. A. KEYSER - EXPANDED TEST STORM ID RANGE FROM 90-99 -C TO 80-99 AT REQUEST FOR JIM GROSS AT TPC {NOTE: IF THIS -C EVER HAS TO BE DONE AGAIN, THE ONLY LINES THAT NEED TO -C BE CHANGED ARE COMMENTED AS "CHG. TESTID" - ALSO MUST -C CHANGE PROGRAM bulls_bufrcyc WHICH GENERATES GTS -C MESSAGES, CHANGE UTILITY PROGRAM trpsfcmv WHICH -C GENERATES CHARTS FOR THE TROPICS (although technically -C trpsfcmv reads in q-c'd tcvitals files output by this -C program and thus they should not have test storms in -C them), and changes scripts: util/ush/extrkr.sh and -C ush/relocate_extrkr.sh} -C 2004-06-08 D. A. KEYSER - WHEN INTEGER VALUES ARE DECODED FROM -C CHARACTER-BASED RECORD VIA INTERNAL READ IN SUBR. DECVAR, -C IF BYTE IN UNITS DIGIT LOCATION IS ERRONEOUSLY CODED AS -C BLANK (" "), IT IS REPLACED WITH A "5" IN ORDER TO -C PREVENT INVALID VALUE FROM BEING RETURNED (I.E., IF -C "022 " WAS READ, IT WAS DECODED AS "22", IT IS NOW -C DECODED AS "225" - THIS HAPPENED FOR VALUE OF RADIUS OF -C LAST CLOSED ISOBAR FOR JTWC RECORDS FROM 13 JULY 2000 -C THROUGH FNMOC FIX ON 26 MAY 2004 - THE VALUE WAS REPLACED -C BY CLIMATOLOGY BECAUSE IT FAILED A GROSS CHECK, HAD THIS -C CHANGE BEEN IN PLACE THE DECODED VALUE WOULD HAVE BEEN -C W/I 0.5 KM OF THE ACTUAL VALUE) -C 2008-07-10 D. A. KEYSER - CORRECTED MEMORY CLOBBERING CONDITION -C IN SUBR. STIDCK RELATED TO ATTEMPTED STORAGE OF MORE WEST -C PACIFIC STORM NAMES FROM FILE syndat_stmnames (144) THAN -C ALLOCATED BY PROGRAM AND IN syndat_stmnames (140), THIS -C LED TO OVERWRITING OF FIRST FOUR syndat_stmnames STORM -C NAMES IN ATLANTIC BASIN FOR 2002, 2008, 2014 CYCLE - -C DISCOVERED BECAUSE 2008 STORM BERTHA (STORM #2 IN -C ATLANTIC BASIN LIST IN syndat_stmnames) WAS NOT BEING -C RECOGNIZED AND THUS NOT PROCESSED INTO OUTPUT TCVITALS -C FILE - CORRECTED BY LIMITING STORAGE OF WEST PACIFIC -C STORM NAMES TO EXACTLY THE MAXIMUM IN PROGRAM (AND NUMBER -C IN syndat_stmnames) (CURRENTLY 140), ALSO GENERALIZED -C CODE TO ENSURE THAT IS WILL NEVER CLOBBER MEMORY READING -C AND STORING STORM NAMES IN ANY OF THE BASINS EVEN IF THE -C NUMBER OF STORM NAMES IN syndat_stmnames INCREASE (AS -C LONG AS THE MAXIMUM VALUE IS .GE. TO THE NUMBER OF STORM -C NAMES FOR THE BASIN IN FILE syndat_stmnames) -C 2013-03-17 D. C. STOKES - CHANGED SOME LIST DIRECTED OUTPUT TO -C FORMATTED TO PREVENT UNNDECSSARY WRAPPING ON WCOSS. -C 2013-03-24 D. C. STOKES - INITIALIZE VARIABLES THAT WERE NOT GETTING -C SET WHEN THERE ARE NO RECORDS TO PROCESS. -C 2013-10-10 D. C. STOKES - ADDED NON-HYPHNATED CARDINAL NUMBERS IN -C ORDER TO RECOGNIZE SUCH NAMED STORMS IN BASINS L, E, C, W, -C AND TO RECOGNIZE NAME CHANGES OF SUCH IN THE OTHER BASINS. -C ALSO EXTENDED THAT LIST (FROM 36 TO 39). -C -C -C INPUT FILES: -C (Note: These need to be double checked) -C UNIT 03 - TEXT FILE ASSOCIATING UNIT NUMBERS WITH FILE NAMES -C UNIT 05 - NAMELIST: VARIABLES APPROPRIATE TO THIS Q/C PROGRAM: -C MAXUNT: NUMBER OF INPUT FILES -C FILES: LOGICAL VARIABLE CONTROLLING FINAL -C COPYING OF RECORDS AND FILE MANIPULATION. -C FOR NORMAL OPERATIONAL USAGE, SHOULD BE TRUE. -C WHEN TRUE, INPUT FILES (UNIT 30, UNIT 31, -C ETC) WILL ZEROED OUT. FOR MULTIPLE RUNS -C OVER THE SAME INPUT DATA SET, FILES MUST BE -C FALSE. FOR DEBUGGING, IT IS HIGHLY -C RECOMMENDED THAT FILES BE SET TO FALSE. -C LNDFIL: TRUE IF RECORDS OF STORMS OVER COASTAL -C POINTS ARE NOT COPIED TO THE FILE OF -C CURRENT QUALITY CONTROLLED RECORDS. -C RUNID: RUN IDENTIFIER (e.g., 'GDAS_TM00_00'). -C WINCUR: TIME WINDOW FOR WRITING CURRENT FILE -C NVSBRS: NUMBER OF VARIABLES ALLOWED FOR SUBSTITUTION -C IVSBRS: INDICES OF VARIABLES ALLOW FOR SUBSTITUTION -C UNIT 11 - APPROPRIATE T126 32-BIT GLOBAL SEA/LAND MASK FILE ON -C GAUSSIAN GRID -C UNIT 12 - RUN DATE FILE ('YYYYMMDDHH') -C UNIT 14 - DATA FILE CONTAINING STORM NAMES -C UNIT 20 - SCRATCH FILE CONTAINING PRELIMINARY Q/C RECORDS -C UNIT 21 - ORIGINAL SHORT-TERM HISTORY, CONTAINS ORIGINAL RECORDS -C BACK A GIVEN NUMBER (WINMIN) DAYS FROM PRESENT -C UNIT 22 - ALIASED SHORT-TERM HISTORY, CONTAINS ALIAS RECORDS -C BACK A GIVEN NUMBER (WINMIN) DAYS FROM PRESENT -C UNIT 25 - ALIAS FILE CONTAINING EQUIVALENT STORM IDS -C FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S -C UNIT 26 - NEW ALIAS FILE CONTAINING EQUIVALENT STORM IDS -C FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S -C NOTE: UCL SHOULD COPY THIS FILE TO UNIT 22 (THE OLD -C ALIAS FILE) AT THE END OF EXECUTION. -C UNIT 30 - STARTING POINT FOR FILES CONTAINING NEW RECORDS TO BE -C etc. QUALITY CONTROLLED. ADDITIONAL INPUT FILES ARE UNIT -C 31, UNIT 32 ETC. THE NUMBER OF THESE FILES IS -C CONTROLLED BY THE NAMELIST INPUT VARIABLE "MAXUNT" -C MENTIONED UNDER UNIT 05 ABOVE. AN EXAMPLE OF AN INPUT -C FILE IS: /tpcprd/atcf/ncep/tcvitals. THIS FILE IS -C WRITTEN BY A REMOTE JOB ENTRY (RJE) AT MIAMI AFTER ALL -C TROPICAL CYCLONE FIXES ARE ESTABLISHED FOR THE ATLANTIC -C AND EAST PACIFIC BY NHC(TPC). THIS FILE IS TYPICALLY -C UPDATED (cat'ed) AT 0230, 0830, 1430, AND 2030 UTC -C (I.E. 2.5 HOURS AFTER SYNOPTIC TIME), 4 TIMES DAILY. -C RECORDS APPROPRIATE TO A FUTURE CYCLE ARE WRITTEN BACK -C TO THE APPROPRIATE FILE. -C -C OUTPUT FILES: -C (Note: These need to be double checked) -C UNIT 06 - STANDARD OUTPUT PRINT -C UNIT 20 - SCRATCH FILE CONTAINING PRELIMINARY Q/C RECORDS -C UNIT 21 - SHORT-TERM HISTORY, RECORDS BACK 4 DAYS FROM PRESENT -C UNIT 22 - NEW ALIAS FILE CONTAINING EQUIVALENT STORM IDS -C FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S -C UNIT 27 - STORM CATALOG FILE CONTAINING STORM NAME, ALIAS INFO -C FIRST AND LAST DATA OBSERVED -C UNIT 28 - SCRATCH FILE CONTAINING TEMPORARY CATALOG -C UNIT 30 - SEE INPUT FILES ABOVE. RECORDS APPROPRIATE TO A FUTURE -C etc. CYCLE ARE WRITTEN BACK TO THE APPROPRIATE FILE -C UNIT 54 - RUN DATE FILE FOR DATE CHECK ('YYYYMMDDHH') -C UNIT 60 - FILE CONTAINING QUALITY CONTROLLED RECORDS -C UNIT 61 - CONTAINS HISTORY OF ALL RECORDS THAT ARE OPERATED ON BY -C THIS PROGRAM -C -C SUBPROGRAMS CALLED: -C UNIQUE: - RSMCCK BASNCK AKASUB TCCLIM RCNCIL -C MNMXDA SCLIST AKLIST STCATI STCATN -C ADFSTF FSTSTM RITCUR RITSTH RITHIS -C FNLCPY CPYREC DUPCHK BLNKCK READCK -C DTCHK SETMSK STIDCK FIXDUP FIXNAM -C SECVCK WRNING F1 F2 SLDATE -C FIXSLM GAULAT BSSLZ1 TRKSUB NEWVIT -C DECVAR TIMSUB YTIME SORTRL DS2UV -C ATAN2D SIND COSD DISTSP AVGSUB -C ABORT1 OFILE0 -C LIBRARY: -C COMMON - IARGC GETARG INDEX -C W3LIB - W3TAGB W3TAGE W3DIFDAT W3MOVDAT W3UTCDAT -C - ERREXIT -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN. NO RECORDS WITH ERRORS -C = 1 - SUCCESSFUL RUN. FOUND RECORDS WITH STORM ID>=80 -C CHG. TESTID -C = 2 - SUCCESSFUL RUN. FOUND RECORDS WITH ERRORS -C = 3 - BOTH 1 AND 2 ABOVE -C = 4 - SUCCESSFUL RUN, BUT NO INPUT RECORDS FOUND -C = 5 - PROGRAM HAS BEEN RUN PREVIOUSLY -C =10 - LOGICAL INCONSISTENCY IN SUBROUTINE RCNCIL (??) -C =20 - FATAL ERROR (SEE STDOUT PRINT FOR MORE DETAILS) -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - PROGRAM SYNDAT_QCTROPCY - - PARAMETER (MAXCHR=95) - PARAMETER (MAXREC=1000) - PARAMETER (MAXCKS=8) - PARAMETER (MAXRC=MAXREC*(MAXCKS+1)) - PARAMETER (MAXTBP=20) - PARAMETER (MAXFIL=99) - PARAMETER (IVSBMX=14,IVSBM1=IVSBMX+1) - - CHARACTER FILNAM*128 - - DIMENSION FILNAM(0:MAXFIL) - - CHARACTER TSTREC(0:MAXREC)*100,OKAREC(MAXREC)*100, - 1 BADREC(MAXREC)*100,DUMREC*100,SCRREC(0:MAXREC)*9, - 2 XXXREC*27,ZZZREC*100,NNNREC*100,TBPREC(MAXTBP)*100, - 3 SCRATC(MAXREC)*100 - - DIMENSION IEFAIL(MAXREC,0:MAXCKS),NUMOKA(MAXREC),NUMBAD(MAXREC), - 1 NUMTST(MAXREC),NUMTBP(MAXTBP),IDUPID(MAXREC), - 2 IUNTIN(MAXREC) - -C IUNTSL: UNIT NUMBER FOR READING T126 32-BIT SEA-LAND MASK -C ON GAUSSIAN GRID -C IUNTDT: UNIT NUMBER FOR READING RUN DATE ('YYYYMMDDHH') -C IUNTDC: UNIT NUMBER FOR RUN DATE ('YYYYMMDDHH') CHECK -C IUNTOK: UNIT NUMBER FOR PRELIMINARY QUALITY-CONTROLLED -C RECORDS. ***NOTE: AT THE END OF THIS PROGRAM, -C IUNTOK CONTAINS THE SHORT-TERM -C HISTORICAL RECORDS FOR THE NEXT -C INPUT TIME. -C IUNTAL: UNIT NUMBER FOR ALIAS FILE WHICH CONTAINS STORM IDS -C FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S -C IUNTAN: UNIT NUMBER FOR NEW ALIAS FILE -C IUNTCA: UNIT NUMBER FOR STORM CATALOG FILE WHICH CONTAINS -C CURRENT LISTING OF ALL STORMS, THEIR NAMES, DATES -C IDS AND ALIASES -C IUNTCN: UNIT NUMBER FOR SCRATCH STORM CATALOG -C IUNTCU: UNIT NUMBER FOR FINAL QUALITY-CONTROLLED RECORDS -C (CURRENT FILE) -C IUNTHO: UNIT NUMBER FOR THE SHORT-TERM HISTORICAL (ORIGINAL) -C VITAL STATISTICS RECORDS. LENGTH OF HISTORY -C CONTROLLED BY WINMIN. THESE ARE ORIGINAL RECORDS AND -C NOT ALIASED RECORDS! -C IUNTHA: UNIT NUMBER FOR THE SHORT-TERM HISTORICAL (ALIAS) -C VITAL STATISTICS RECORDS. LENGTH OF HISTORY -C CONTROLLED BY WINMIN. THESE ARE ALIAS RECORDS IF -C MULTIPLE OBSERVERS FOR A GIVEN STORM ARE PRESENT! -C IUNTHL: UNIT NUMBER FOR THE LONG-TERM HISTORICAL (PREVIOUS) -C VITAL STATISTICS RECORDS. ALL RECORDS, AND QUALITY -C CONTROL FLAGS ARE PUT INTO THIS FILE. -C IUNTVI: UNIT NUMBER FOR RAW VITAL STATISTICS FILE (NEITHER -C QUALITY CONTROLLED NOR CHECKED FOR DUPLICATES) -C WINMIN: WINDOW FOR SHORT-TERM HISTORY FILE (FRACTIONAL DAYS) -C WINMX1: WINDOW FOR MAXIMUM ACCEPTABLE DATE (FRACTIONAL DAYS) -C FOR RECORD PROCESSING -C WINCUR: WINDOW FOR WRITING CURRENT FILE (FRACTIONAL DAYS) -C FILES: TRUE IF NEW SHORT-TERM HISTORY FILE IS CREATED AND -C ALL NEW RECORD FILES ARE ZEROED OUT -C LNDFIL: TRUE IF RECORDS OF STORMS OVER COASTAL POINTS ARE -C NOT COPIED TO THE FILE OF CURRENT QUALITY CONTROLLED -C RECORDS. - - DIMENSION RINC(5) - - DIMENSION IVSBRS(0:IVSBMX) - LOGICAL FILES,LNDFIL - CHARACTER RUNID*12 - - NAMELIST/INPUT/IDATEZ,IUTCZ,RUNID,FILES,LNDFIL,MAXUNT,WINMIN, - 1 NVSBRS,IVSBRS,WINCUR - - DATA IUNTSL/11/,IUNTDT/12/,IUNTDC/54/,IUNTOK/20/,IUNTHO/21/, - 1 IUNTVI/30/,MAXUNT/2/,IUNTCU/60/,IUNTHL/61/,WINMIN/4./, - 2 WINMX1/0.0833333/,IEFAIL/MAXRC*0/,LNDFIL/.TRUE./,IUNTOP/3/, - 3 IUNTHA/22/,IUNTAL/25/,IUNTAN/26/,NVSBRS/0/,IVSBRS/IVSBM1*0/, - 4 WINCUR/0.25/,FIVMIN/3.4722E-3/,FILES/.FALSE./,IUNTCA/27/, - 5 IUNTCN/28/,IUNTSN/14/ - DATA NNNREC/'12345678901234567890123456789012345678901234567890123 - 1456789012345678901234567890123456789012345*****'/ - DATA ZZZREC/'RSMC#SID#NAMEZZZZZ#YYYYMMDD#HHMM#LATZ#LONGZ#DIR#SPD#P - 1CEN#PENV#RMAX#VM#RMW#15NE#15SE#15SW#15NW#D*****'/ - DATA - 1 XXXREC/' FL BL RD DT LL ID MR SV DS'/ - - CALL W3TAGB('SYNDAT_QCTROPCY',2013,0053,0050,'NP22 ') - -C INITIALIZE SOME VARIABLES THAT MIGHT GET USED BEFORE GETTING SET -C UNDER CERTAIN CONDITIONS - IERCHK=0 - IERRCN=0 - NTBP=0 - -C OPEN FILES - - filnam(0)='fildef.vit' - CALL OFILE0(IUNTOP,MAXFIL,NFTOT,FILNAM) - -C READ RUN DATE AND CONVERT TO FLOATING POINT DATE. -C THE RUN DATE ACCEPTANCE WINDOW IS NOT SYMMETRIC ABOUT -C THE CURRENT RUN DATE - - READ(5,INPUT) - WRITE(6,INPUT) - -C GET CURRENT RUN DATE AND OFFSET IN SJL FORMAT -C OFFSET ROUNDED TO THE NEAREST HOUR FROM W3 CALLS - - IOFFTM = 0 - - IF(IDATEZ .LT. 0) THEN - CALL SLDATE(IUNTDC,IDATCK,IUTCCK,IOFFTM) - CALL SLDATE(IUNTDT,IDATEZ,IUTCZ,IOFFTM) - IF(FILES .AND. IDATCK .EQ. IDATEZ .AND. IUTCCK .EQ. IUTCZ) THEN - WRITE(6,1) FILES,IDATCK,IUTCCK - 1 FORMAT(/'######WITH FILES=',L2,' THIS PROGRAM HAS RUN PREVIOUSLY', - 1 ' FOR DATE,TIME=',I9,I5) - ISTOP=5 - GO TO 1000 - ENDIF - ENDIF - - CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAY0) - HROFF =IOFFTM*.01 - CYCOFF=(1.0+HROFF)/24. - IF(HROFF .GT. 24.) HROFF=-99.99 - - WRITE(6,2) IOFFTM,CYCOFF - 2 FORMAT(/'...OFFTIM,CYCOFF=',I12,F12.5) - -C THE MINIMUM WINDOW DETERMINES THE OLDEST RECORD THAT CAN -C BE PROCESSED BY QUALITY CONTROL. IT IS ALSO THE TIME COVERED -C BY THE SHORT-TERM HISTORICAL STORMS IN THE WORKING FILE. - -C THERE ARE TWO MAXIMUM WINDOWS: THE SHORT ONE (DAYMX1=2 HR) IS -C FOR PROCESSING RECORDS NO LATER THAN THE CYCLE TIME. THE -C LARGER ONE (DAYMX2) EXTENDS TO THE CURRENT TIME (THE TIME AT -C WHICH THIS PROGRAM IS RUN) PLUS 1 HOUR. RECORDS LATER THAN -C DAYMX1 BUT EARLIER THAN DAYMX2 WILL BE "THROWN BACK INTO -C THE POND" AND WILL BE PROCESSED AT THE NEXT CYCLE. - - DAYMIN=DAY0-WINMIN - DAYMX1=DAY0+WINMX1 - DAYMX2=DAY0+CYCOFF - DAYCUR=DAY0-WINCUR - DAYOFF=0.0 - - DAYMX1=DAYMX1+DAYOFF - - WRITE(6,3) WINMIN,WINMX1,DAYMIN,DAYMX1,DAYMX2 - 3 FORMAT(/'...WINMIN,WINMX1,DAYMIN,DAYMX1,DAYMX2=',/,4X,5F12.3) - - WRITE(6,5) IDATEZ,IUTCZ,DAY0,RUNID,LNDFIL,FILES - 5 FORMAT(20X,'***********************************************'/ - 1 20X,'***********************************************'/ - 2 20X,'**** WELCOME TO SYNDAT_QCTROPCY ****'/ - 3 20X,'**** Y2K/F90 VERSION - 17 MARCH 2013 ****'/ - 4 20X,'**** ****'/ - 5 20X,'**** VITAL STATISTICS RECORD CHECKER ****'/ - 6 20X,'**** FOR DATE=',I8,' UTC=',I4.4,10X,'****'/ - 7 20X,'**** JULIAN DAY=',F10.3,16X,'****'/ - 8 20X,'**** RUNID=',A12,' LNDFIL=',L1,' FILES=',L1,4X,'****'/ - 9 20X,'**** 1) INPUT RECORDS ARE CHECKED FOR ****'/ - O 20X,'**** EXACT DUPLICATES ****'/ - 1 20X,'**** 2) QUALITY CONTROL CHECKS. ****'/ - 2 20X,'**** FIRST: PRIMARY INFORMATION ****'/ - 3 20X,'**** (RECOVERY IS ESSENTIAL) ****'/ - 4 20X,'**** A) ALL COLUMNS ****'/ - 5 20X,'**** B) DATE/TIME ****'/ - 6 20X,'**** C) POSITION ****'/ - 7 20X,'**** SECOND: SECONDARY INFO. ****') - WRITE(6,6) - 6 FORMAT(20X,'**** (RECOVERY FROM PERSIS.) ****'/ - 1 20X,'**** D) DIRECTION/SPEED ****'/ - 2 20X,'**** E) RMAX, PENV, PCEN, STM DEPTH ****'/ - 3 20X,'**** THIRD: TERTIARY INFORMATION ****'/ - 4 20X,'**** (RECOVERY DESIRABLE) ****'/ - 5 20X,'**** F) VMAX, RMW ****'/ - 6 20X,'**** G) R15 NE, SE, SW, NW ****'/ - 7 20X,'**** ****'/ - 8 20X,'***********************************************'/ - 9 20X,'***********************************************'/) - - WRITE(6,7) IUNTSL,IUNTDT,IUNTSN,IUNTOK,IUNTCU,IUNTAL,IUNTAN, - 1 IUNTCA,IUNTCN,IUNTHO,IUNTHA,IUNTHL,IUNTVI - 7 FORMAT(20X,'I/O UNITS ARE:'/ - 1 22X,'SEA/LAND MASK =IUNTSL =',I3/ - 2 22X,'RUN DATE (YYYYMMDDHH) =IUNTDT =',I3/ - 3 22X,'STORM NAMES =IUNTSN =',I3/ - 4 22X,'PRELIMINARY Q/C RECORDS =IUNTOK =',I3/ - 5 22X,'FINAL Q/C RECORDS =IUNTCU =',I3/ - 6 22X,'STORM ID ALIAS =IUNTAL =',I3/ - 7 22X,'NEW STORM ID ALIAS =IUNTAN =',I3/ - 8 22X,'STORM CATALOG =IUNTCA =',I3/ - 9 22X,'SCRATCH STORM CATALOG =IUNTCN =',I3/ - O 22X,'SHORT TERM HIST. (ORIG.)=IUNTHO =',I3/ - 1 22X,'SHORT TERM HIST. (ALIAS)=IUNTHA =',I3/ - 2 22X,'LONG TERM HIST. =IUNTHL =',I3/ - 3 22X,'NEW RECORDS =IUNTVI>=',I3) - -C SET UP THE T126 32-BIT SEA-LAND MASK ON GAUSSIAN GRID -C NTEST,NOKAY,NBAD ARE ALL MEANINGLESS NUMBERS AT THIS POINT - - NTEST=1 - NOKAY=1 - NBAD =1 - CALL SETMSK(IUNTSL,NTEST,NOKAY,NBAD,IECOST,IEFAIL(1:MAXREC,4), - 1 NUMTST,NUMOKA,NUMBAD,ZZZREC,NNNREC,TSTREC,BADREC, - 2 OKAREC) - -C INITIAL CHECKS ARE FOR EXACT DUPLICATES AND BLANKS IN THE -C CORRECT SPOT - - NOKAY=0 - NBAD=0 - CALL DUPCHK(IUNTVI,MAXUNT,MAXREC,IERCHK,NTEST,IEFAIL(1:MAXREC,0), - 1 NUMTST,DUMREC,TSTREC,BADREC,*500) - -C SAVE THE INPUT UNIT NUMBERS FOR ALL RECORDS - - IUNTIN(1:NTEST)=IEFAIL(1:NTEST,0) -C - CALL BLNKCK(NTEST,NOKAY,NBAD,IEFAIL(1:MAXREC,1),NUMTST,NUMOKA, - 1 NUMBAD,ZZZREC,NNNREC,TSTREC,BADREC,OKAREC) - -C RELOAD THE TEST RECORDS - - NTEST=NOKAY - NUMTST(1:NOKAY)=NUMOKA(1:NOKAY) - TSTREC(1:NOKAY)=OKAREC(1:NOKAY) - NOKAY=0 - - CALL READCK(NTEST,NOKAY,NBAD,IEFAIL(1:MAXREC,2),NUMTST,NUMOKA, - 1 NUMBAD,ZZZREC,NNNREC,TSTREC,BADREC,OKAREC) - -C RELOAD THE TEST RECORDS AGAIN - - NTEST=NOKAY - NUMTST(1:NOKAY)=NUMOKA(1:NOKAY) - TSTREC(1:NOKAY)=OKAREC(1:NOKAY) - NOKAY=0 - NTBP=MAXTBP -C - CALL DTCHK(NTEST,NOKAY,NBAD,NTBP,IEFAIL(1:MAXREC,3),NUMTST,NUMOKA, - 1 NUMBAD,NUMTBP,DAYMIN,DAYMX1,DAYMX2,DAYOFF,TSTREC, - 2 BADREC,OKAREC,TBPREC) - -C ENCORE, UNE FOIS - - NTEST=NOKAY - NUMTST(1:NOKAY)=NUMOKA(1:NOKAY) - TSTREC(1:NOKAY)=OKAREC(1:NOKAY) - NOKAY=0 - - CALL LLCHK(IUNTSL,NTEST,NOKAY,NBAD,IEFAIL(1:MAXREC,4),NUMTST, - 1 NUMOKA,NUMBAD,ZZZREC,NNNREC,TSTREC,BADREC,OKAREC) - -C ONE MORE TIME (POUR CEUX QUI NE PARLE PAS FRANCAIS) - - NTEST=NOKAY - NUMTST(1:NOKAY)=NUMOKA(1:NOKAY) - TSTREC(1:NOKAY)=OKAREC(1:NOKAY) - NOKAY=0 - - CALL STIDCK(IUNTHO,IUNTSN,IUNTCA,NTEST,IYR,MAXREC,NOKAY,NBAD, - 1 IEFAIL(1:MAXREC,5),IDUPID,NUMTST,NUMOKA,NUMBAD,ZZZREC, - 2 NNNREC,TSTREC,BADREC,OKAREC,SCRATC) - - -C ***************************************************************** -C ***************************************************************** -C **** **** -C **** END OF THE FIRST PHASE OF ERROR CHECKING. FROM NOW **** -C **** ON, THE ORIGINAL RECORD SHORT-TERM HISTORY FILE IS **** -C **** CLOSED AND THE ALIAS SHORT-TERM HISTORY FILE IS OPEN. **** -C **** SOME INPUT RECORDS MAY BE CHANGED DUE TO SUBSTITUTION **** -C **** OF MISSING VALUES OR AVERAGING OF MULTIPLE STORM **** -C **** REPORTS. **** -C **** **** -C ***************************************************************** -C ***************************************************************** - -C MULTIPLE RSMC CHECK: SAME STORM REPORTED BY MORE THAN ONE -C TROPICAL CYCLONE WARNING CENTER. - -C CHECK FOR: -C 1) MULTIPLE STORM REPORTS BY DIFFERENT RSMC'S AT THE SAME TIME -C 2) TIME SERIES OF REPORTS ON THE SAME STORM BY DIFFERENT RSMC'S -C RECONCILE THE ABOVE: -C 1) ASSIGN A COMMON STORM ID -C 2) REMOVE MULTIPLE REPORTS IN FAVOR OF A SINGLE REPORT WITH THE -C COMMON STORM ID AND COMBINED (AVERAGED) PARAMETERS IF -C NECESSARY - -CCCC NTEST=NOKAY -CCCC WRITE(6,61) XXXREC -CCC61 FORMAT(///'...THE FOLLOWING ACCEPTABLE RECORDS ARE ELIGIBLE FOR ', -CCCC 1 'THE MULTIPLE RSMC CHECK.'/4X,'ERROR CODES ARE:'/21X, -CCCC 2 '=0: NO ERRORS OCCURRED'/21X,'<0: SUCCESSFUL ERROR ', -CCCC 3 'RECOVERY',55X,A/) - -CCCC DO NOK=1,NOKAY -CCCC NUMTST(NOK)=NUMOKA(NOK) -CCCC TSTREC(NOK)=OKAREC(NOK) -CCCC WRITE(6,67) NOK,OKAREC(NOK)(1:MAXCHR),(IEFAIL(NUMOKA(NOK),ICK), -CCCC 1 ICK=0,MAXCKS) - 67 FORMAT('...',I3,'...',A,'...',I2,8I3) -CCCC ENDDO -CCCC NOKAY=0 -CCCC REWIND IUNTOK - -c Stopgap measure is to not allow records to be written into -c the alias short-term history file (17 Sept. 1998) - NRCOVR=0 -CCCC CALL RSMCCK(IUNTHO,IUNTHA,IUNTAL,IUNTAN,IUNTCA,IUNTOK,NVSBRS, -CCCC 1 IVSBRS,MAXREC,NTEST,NOKAY,NBAD,NRCOVR, -CCCC 2 IEFAIL(1:MAXREC,6),NUMTST,NUMOKA,NUMBAD,IDUPID,TSTREC, -CCCC 3 BADREC,OKAREC,SCRATC) - -C COPY ALIAS SHORT-TERM HISTORY RECORDS FROM THE PRELIMINARY -C (SCRATCH) FILE TO THE ALIAS SHORT-TERM HISTORY FILE ONLY -C WHEN WE WISH TO UPDATE THE SHORT-TERM HISTORY FILE. - - IF(FILES) THEN - ICALL=1 - REWIND IUNTHA - WRITE(6,93) - 93 FORMAT(/'...THE FOLLOWING RECORDS WILL BE COPIED FROM THE ', - 1 'PRELIMINARY QUALITY CONTROLLED FILE TO THE ALIAS ', - 2 'SHORT-TERM HISTORICAL FILE:') - - CALL CPYREC(ICALL,IUNTOK,IUNTHA,NOKAY,DAYMIN,DUMREC,OKAREC) - ENDIF - -C BEGIN CHECKS FOR SECONDARY STORM INFORMATION WHICH INCLUDES: -C 1) DIRECTION, SPEED -C 2) PCEN, PENV, RMAX, STORM DEPTH -C THESE NUMBERS ARE NEEDED BY YOGI. IF MISSING, WE TRY TO -C FILL THEM IN BY PERSISTENCE. - -C FIRST, COPY HISTORICAL RECORDS TO THE PRELIMINARY QUALITY -C CONTROLLED FILE AND THEN COPY THE RECORDS FROM THE CURRENT FILE. - -C COPY HISTORICAL RECORDS TO PRELIMINARY FILE, CHECK FOR DUPLICATES - - REWIND IUNTOK - IF(FILES) THEN - ICALL=3 - WRITE(6,95) DAYMIN,ICALL - 95 FORMAT(/'...THE FOLLOWING RECORDS, HAVING DATES GREATER THAN ', - 1 'OR EQUAL TO DAY',F10.3,', WILL BE CHECKED FOR EXACT ', - 2 'AND PARTIAL DUPLICATES '/4X,'(ICALL=',I2,')', - 3 'AND COPIED FROM THE ALIAS SHORT-TERM HISTORICAL FILE ', - 4 'TO THE PRELIMINARY QUALITY CONTROLLED FILE WHICH NOW ', - 5 'WILL CONTAIN '/4X,'ALIAS RECORDS:'/) - - CALL CPYREC(ICALL,IUNTHA,IUNTOK,NOKAY,DAYMIN,DUMREC,OKAREC) - - ELSE - WRITE(6,97) - 97 FORMAT(/'...THE FOLLOWING RECORDS WILL BE COPIED FROM THE ', - 1 'SCRATCH ARRAY TO THE PRELIMINARY QUALITY CONTROLLED ', - 2 'FILE:') - DO NRC=1,NRCOVR - WRITE(6,105) SCRATC(NRC) - 105 FORMAT(' ...',A,'...') - WRITE(IUNTOK,107) SCRATC(NRC) - 107 FORMAT(A) - ENDDO - ENDIF - -C OH NO, NOT AGAIN!!! - - NTEST=NOKAY - write(6,1011) ntest - 1011 format(/'***debug ntest=nokay=',i4/) - WRITE(6,111) - 111 FORMAT(/'...IN PREPARATION FOR SECONDARY VARIABLE CHECKING, THE ', - 1 'FOLLOWING ACCEPTABLE RECORDS WILL BE '/4X,'ADDED TO THE', - 2 ' PRELIMINARY,QUALITY CONTROLLED FILE:'/) - DO NOK=1,NOKAY - NUMTST(NOK)=NUMOKA(NOK) - TSTREC(NOK)=OKAREC(NOK) - WRITE(6,113) NOK,NUMOKA(NOK),OKAREC(NOK) - 113 FORMAT(' ...',I4,'...',I4,'...',A) - WRITE(IUNTOK,119) OKAREC(NOK) - 119 FORMAT(A) - ENDDO - - NOKAY=0 - CALL SECVCK(IUNTOK,NTEST,NOKAY,NBAD,NUMTST,NUMOKA,NUMBAD,DAY0, - 1 DAYMIN,DAYMX1,DAYOFF,IEFAIL(1:MAXREC,7),ZZZREC,NNNREC, - 2 SCRREC,TSTREC,BADREC,OKAREC) - -C COPY HISTORICAL RECORDS TO PRELIMINARY FILE, CHECK FOR DUPLICATES - - REWIND IUNTOK - IF(FILES) THEN - ICALL=3 - WRITE(6,95) DAYMIN,ICALL - CALL CPYREC(ICALL,IUNTHA,IUNTOK,NOKAY,DAYMIN,DUMREC,OKAREC) - - ELSE - WRITE(6,97) - DO NRC=1,NRCOVR - WRITE(6,105) SCRATC(NRC) - WRITE(IUNTOK,107) SCRATC(NRC) - ENDDO - ENDIF - - NTEST=NOKAY - WRITE(6,201) - 201 FORMAT(//'...THE FOLLOWING ACCEPTABLE RECORDS WILL BE ADDED TO ', - 1 'THE PRELIMINARY QUALITY CONTROLLED FILE '/4X,'IN ', - 2 'PREPARATION FOR DIRECTION/SPEED CHECKING.'/) - DO NOK=1,NOKAY - NUMTST(NOK)=NUMOKA(NOK) - TSTREC(NOK)=OKAREC(NOK) - WRITE(6,203) NOK,OKAREC(NOK) - 203 FORMAT(' ...',I4,'...',A) - WRITE(IUNTOK,207) OKAREC(NOK) - 207 FORMAT(A) - ENDDO - - NOKAY=0 - -C SEA/LAND MASK CHECK - - CALL SELACK(NTEST,NOKAY,NBAD,IECOST,IEFAIL(1:MAXREC,4),NUMTST, - 1 NUMOKA,NUMBAD,LNDFIL,ZZZREC,NNNREC,TSTREC,BADREC, - 2 OKAREC) - - WRITE(6,301) XXXREC - 301 FORMAT(/'...THE SECONDARY VARIABLE, DIR/SPD AND SEA/LAND ', - 1 'CHECKING HAVE CONCLUDED. ERROR CHECKING HAS ENDED.'/4X, - 2 'OKAY RECORDS AND ERROR CODES ARE:',69X,A/) - - DO NOK=1,NOKAY - WRITE(6,67) NOK,OKAREC(NOK)(1:MAXCHR),IEFAIL(NUMOKA(NOK),0), - 1 (-IABS(IEFAIL(NUMOKA(NOK),ICK)), - 1 ICK=1,MAXCKS) - ENDDO - - WRITE(6,311) XXXREC - 311 FORMAT(/'...BAD RECORDS AND ERROR CODES ARE:',71X,A/) - - DO NBA=1,NBAD - WRITE(6,67) NBA,BADREC(NBA)(1:MAXCHR),IEFAIL(NUMBAD(NBA),0), - 1 (IEFAIL(NUMBAD(NBA),ICK),ICK=1,MAXCKS) - - ENDDO - -C RECONCILE THE STORM IDS WITH THE STORM CATALOG - -C LET'S PRETEND WE'RE NOT GOING TO DO IT, BUT DO IT ANYWAY - - NTEST=NOKAY+NBAD - WRITE(6,401) XXXREC - 401 FORMAT(///'...THE FOLLOWING ACCEPTABLE RECORDS WILL BE ', - 1 'RECONCILED WITH THE STORM CATALOG.'/4X,'ERROR CODES ', - 2 'ARE:'/21X,'=0: NO ERRORS OCCURRED'/21X,'<0: ', - 3 'SUCCESSFUL ERROR RECOVERY',56X,A/) - - DO NOK=1,NOKAY - NUMTST(NOK)=NUMOKA(NOK) - TSTREC(NOK)=OKAREC(NOK) - WRITE(6,67) NOK,OKAREC(NOK)(1:MAXCHR),IEFAIL(NUMOKA(NOK),0), - 1 (IEFAIL(NUMOKA(NOK),ICK),ICK=1,MAXCKS) - ENDDO - WRITE(6,411) XXXREC - 411 FORMAT(//'...THE FOLLOWING BAD RECORDS WILL BE RECONCILED WITH ', - 1 'THE STORM CATALOG FOR OVERLAND OR OVERLAPPING STORM ', - 2 'CASES.'/4X,'ERROR CODES ARE:'/21X,'>0: ERROR FOUND',70X, - 3 A/) - DO NBA=1,NBAD - NUMTST(NOKAY+NBA)=NUMBAD(NBA) - TSTREC(NOKAY+NBA)=BADREC(NBA) - IF(IEFAIL(NUMBAD(NBA),4) .EQ. 5 .OR. - 1 IEFAIL(NUMBAD(NBA),4) .EQ. 6 .OR. - 2 IEFAIL(NUMBAD(NBA),6) .EQ. 22) THEN - WRITE(6,67) NBA+NOKAY,BADREC(NBA)(1:MAXCHR),IEFAIL(NUMBAD(NBA),0), - 1 (IEFAIL(NUMBAD(NBA),ICK),ICK=1,MAXCKS) - ENDIF - ENDDO - - call rcncil(iuntca,iuntcn,iuntal,ntest,nokay,nbad,maxrec,maxcks, - 1 iefail,ierrcn,idupid,numtst,numoka,numbad,tstrec, - 2 badrec,okarec) - -C CLEAR OUT THE TEMPORARY ALIAS FILE; AKAVIT IS IN ITS FINAL FORM. - - REWIND IUNTAN - END FILE IUNTAN - -C ERROR CHECKING HAS FINALLY ENDED - - 500 WRITE(6,501) XXXREC - 501 FORMAT(//'...THE FINAL ERROR CHECKING HAS ENDED. BAD RECORDS ', - 1 'AND ERROR CODES ARE:',36X,A/) - ISTP90=0 - ISTPBR=0 - DO NBA=1,NBAD - DO NCK=1,MAXCKS - -C SELECT APPROPRIATE CONDITION CODE FOR STOP - - IF(IEFAIL(NUMBAD(NBA),NCK) .EQ. 2 .AND. NCK .EQ. 5) THEN - ISTP90=1 - ELSE IF(IEFAIL(NUMBAD(NBA),NCK) .NE. 0) THEN - ISTPBR=2 - ENDIF - ENDDO - - WRITE(6,543) NBA,BADREC(NBA)(1:MAXCHR),(IEFAIL(NUMBAD(NBA),ICK), - 1 ICK=0,MAXCKS) - 543 FORMAT(' ...',I3,'...',A,'...',I2,8I3) - ENDDO - ISTOP=ISTP90+ISTPBR - IF(IERCHK .EQ. 161) ISTOP=04 - IF(IERRCN .NE. 0) ISTOP=10 - WRITE(6,551) ISTP90,ISTPBR,IERRCN,ISTOP - 551 FORMAT(/'...STOP CODES ARE: ISTP90,ISTPBR,IERRCN,ISTOP=',4I3) - -C ADD FIRST OCCURRENCE FLAGS BY CHECKING THE SHORT-TERM HISTORY -C FILE - - CALL ADFSTF(IUNTHA,NOKAY,NBAD,MAXREC,MAXCKS,IECOST,NUMBAD,IEFAIL, - 1 DUMREC,OKAREC,BADREC) - -C WRITE THE RESULTS OF THE Q/C PROGRAM TO A LONG-TERM HISTORICAL -C FILE - - NRTOT=NOKAY+NBAD - CALL RITHIS(-IUNTHL,IEFAIL,NRTOT,IDATEZ,IUTCZ,NUMOKA,NOKAY,MAXREC, - 1 MAXCKS,HROFF,WINCUR,RUNID,LNDFIL,FILES,OKAREC,ZZZREC, - 2 XXXREC) - CALL RITHIS(IUNTHL,IEFAIL,NRTOT,IDATEZ,IUTCZ,NUMBAD,NBAD,MAXREC, - 1 MAXCKS,HROFF,WINCUR,RUNID,LNDFIL,FILES,BADREC,ZZZREC, - 2 ZZZREC) - -C UPDATE THE SHORT-TERM HISTORY FILES. -C **** IMPORTANT NOTE: ALL INFORMATION FROM TSTREC,OKAREC,BADREC, -C NUMTST,NUMOKA,NUMBAD WILL BE LOST **** -C **** PRENEZ GARDE **** - - IF(FILES) THEN - CALL RITSTH(IUNTHA,IUNTHO,IUNTOK,NOKAY,NBAD,DAYMIN,IECOST,MAXCKS, - 1 MAXREC,NUMBAD,IEFAIL,DUMREC,OKAREC,BADREC) - - CALL FNLCPY(IUNTVI,MAXUNT,IUNTOK,IUNTHA,MAXREC,NTBP,NUMTBP,IUNTIN, - 1 TBPREC,DUMREC) - NTEST=0 - NOKAY=0 - IUNTRD=IUNTOK - -C NOPE: SORRY, ONE LAST TIME, BUT ONLY FOR FILES=.FALSE. - - ELSE - NTEST=NOKAY - IUNTRD=IUNTHA - NUMTST(1:NOKAY)=NUMOKA(1:NOKAY) - TSTREC(1:NOKAY)=OKAREC(1:NOKAY) - NOKAY=0 - - ENDIF - -C WRITE THE FILE CONTAINING ALL CURRENT QUALITY CONTROLLED RECORDS - - CALL YTIME(IYR,DAYCUR+FIVMIN,IDATCU,JUTCCU) - CALL RITCUR(IUNTRD,IUNTCU,NTEST,NOKAY,NBAD,IDATCU,JUTCCU,DAYCUR, - 1 MAXREC,IEFAIL(1:MAXREC,4),NUMTST,NUMOKA,NUMBAD,FILES, - 2 LNDFIL,ZZZREC,NNNREC,DUMREC,SCRREC,TSTREC,OKAREC, - 3 BADREC) - -C CLEAN OUT THE SCRATCH FILE - - REWIND IUNTOK - END FILE IUNTOK - - 1000 CONTINUE - IF(FILES) CALL SLDTCK(IUNTDC) - - WRITE(6,1115) - 1115 FORMAT(////20X,'*******************************************' - 1 /20X,'*******************************************' - 2 /20X,'**** ****' - 3 /20X,'**** SUCCESSFUL COMPLETION OF ****' - 4 /20X,'**** SYNDAT_QCTROPCY ****' - 5 /20X,'**** ****' - 6 /20X,'*******************************************' - 7 /20X,'*******************************************') - - CALL W3TAGE('SYNDAT_QCTROPCY') - -ccccc IF(ISTOP .EQ. 0) THEN - STOP -ccccc ELSE IF(ISTOP .EQ. 1) THEN -ccccc call ERREXIT (1) -ccccc ELSE IF(ISTOP .EQ. 2) THEN -ccccc call ERREXIT (2) -ccccc ELSE IF(ISTOP .EQ. 3) THEN -ccccc call ERREXIT (3) -ccccc ELSE IF(ISTOP .EQ. 04) THEN -ccccc call ERREXIT (4) -ccccc ELSE IF(ISTOP .EQ. 05) THEN -ccccc call ERREXIT (5) -ccccc ELSE IF(ISTOP .EQ. 10) THEN -ccccc call ERREXIT (10) -ccccc ENDIF - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: RSMCCK CHECKS FOR MULTIPLE STORM REPORTS -C PRGMMR: S. LORD ORG: NP22 DATE: 1992-02-19 -C -C ABSTRACT: INPUT RECORDS ARE CHECKED FOR MULTIPLE REPORTS ON THE SAME -C STORM FROM DIFFERENT RSMC'S. THE FOLLOWING ACTIONS ARE -C TAKEN: -C 1) MULTIPLE STORM REPORTS BY DIFFERENT RSMC'S AT THE SAME -C TIME ARE REMOVED -C 2) TIME SERIES OF REPORTS ON THE SAME STORM BY DIFFERENT -C RSMC'S ARE DISCOVERED -C TO RECONCILE THE ABOVE: -C 1) A COMMON STORM ID IS ASSIGNED -C 2) MULTIPLE REPORTS ARE REMOVED IN FAVOR OF A SINGLE -C REPORT WITH THE COMMON STORM ID AND COMBINED -C (AVERAGED) PARAMETERS IF NECESSARY -C -C PROGRAM HISTORY LOG: -C 1992-02-19 S. LORD -C 1992-07-16 S. LORD FIXED SOME BUGS (390); ADDED RETURN CODE 2. -C 1993-03-09 S. LORD ADDED CODE FOR COMPATIBILITY WITH RCNCIL -C 2013-10-10 D. C. STOKES - ADDED NON-HYPHNATED CARDINAL NUMBER NAMES -C ALSO EXTENDED THAT LIST (FROM 36 TO 39). -C -C USAGE: CALL RSMCCK(IUNTHO,IUNTHA,IUNTAL,IUNTAN,IUNTOK,NVSBRS,IVSBRS, -C MAXOVR,NTEST,NOKAY,NBAD,NRCOVR,IFRSMC,NUMTST, -C NUMOKA,NUMBAD,IOVRLP,TSTREC,BADREC,OKAREC,OVRREC) -C INPUT ARGUMENT LIST: -C IUNTHO - UNIT NUMBER FOR SHORT-TERM HISTORY FILE OF ORIGINAL -C - RECORDS. -C IUNTHA - UNIT NUMBER FOR SHORT-TERM HISTORY FILE OF ALIASED -C - RECORDS. -C IUNTAL - UNIT NUMBER FOR ALIAS FILE. -C IUNTAN - UNIT NUMBER FOR NEW ALIAS FILE. -C IUNTOK - UNIT NUMBER FOR SCRATCH FILE. -C NVSBRS - NUMBER OF ALLOWABLE VARIABLES FOR SUBSTITUTION. -C IVSBRS - INDEX OF ALLOWABLE VARIABLES FOR SUBSTITUTION. -C MAXOVR - DIMENSION FOR SCRATCH SPACE. -C NTEST - NUMBER OF CURRENT RECORDS TO BE TESTED. -C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD -C - TO BE TESTED. -C IOVRLP - SCRATCH ARRAY. -C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED. -C -C OUTPUT ARGUMENT LIST: -C NOKAY - NUMBER OF RECORDS THAT PASSED THE RSMC CHECK. -C NBAD - NUMBER OF RECORDS THAT FAILED THE RSMC CHECK. -C NRCOVR - NUBER OF RECORDS RETURNED IN OVRREC. THESE CONTAIN -C - UPDATED ALIAS SHORT-TERM HISTORY RECORDS FOR USE WHEN -C - FILES=F. -C IFRSMC - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT -C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES. -C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD -C - RECORD. -C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD -C - RECORD. -C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED -C - THE RSMC CHECK. -C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED -C - THE RSMC CHECK. -C OVRREC - CHARACTER ARRAY CONTAINING UPDATED ALIAS SHORT-TERM -C - HISTORY RECORDS. -C -C INPUT FILES: -C UNIT 20 - SCRATCH FILE CONTAINING SHORT-TERM HISTORY RECORDS -C UNIT 21 - ORIGINAL SHORT-TERM HISTORY FILE CONTAINING RECORDS -C PROCESSED BY THIS PROGRAM FOR THE LAST SEVERAL DAYS. -C IN THIS FILE, THE ORIGINAL RSMC AND STORM ID ARE KEPT. -C UNIT 22 - ALIAS SHORT-TERM HISTORY FILE CONTAINING RECORDS -C PROCESSED BY THIS PROGRAM FOR THE LAST SEVERAL DAYS. -C IN THIS FILE, THE RSMC AND STORM ID HAVE BEEN UNIFIED. -C UNIT 25 - ALIAS FILE CONTAINING EQUIVALENT STORM IDS -C - FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S -C - DCB: LRECL=255, BLKSIZE=23400, RECFM=VB -C UNIT 26 - NEW ALIAS FILE CONTAINING EQUIVALENT STORM IDS -C - FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C UNIT 20 - SCRATCH FILE CONTAINING SHORT-TERM HISTORY RECORDS -C UNIT 25 - ALIAS FILE CONTAINING EQUIVALENT STORM IDS -C - FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S -C - DCB: LRECL=255, BLKSIZE=23400, RECFM=VB -C UNIT 26 - NEW ALIAS FILE CONTAINING EQUIVALENT STORM IDS -C - FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S -C - NOTE: UCL SHOULD COPY THIS FILE TO FT22F001 (THE OLD -C - ALIAS FILE) AT THE END OF EXECUTION. -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE RSMCCK(IUNTHO,IUNTHA,IUNTAL,IUNTAN,IUNTCA,IUNTOK, - 1 NVSBRS,IVSBRS,MAXOVR,NTEST,NOKAY,NBAD,NRCOVR, - 2 IFRSMC,NUMTST,NUMOKA,NUMBAD,IOVRLP,TSTREC, - 3 BADREC,OKAREC,OVRREC) - - PARAMETER (NERCRS=10) - PARAMETER (MAXSTM=70) - PARAMETER (NOVRMX=MAXSTM) - PARAMETER (NADDMX=10) - PARAMETER (MAXREC=1000) - - SAVE - - CHARACTER*(*) TSTREC(0:NTEST),BADREC(MAXREC),OKAREC(NTEST), - 1 ERCRS(NERCRS)*60,OVRREC(MAXOVR) - CHARACTER*100 DUMY2K - - PARAMETER (MAXCHR=95) - PARAMETER (MAXVIT=15) - PARAMETER (NBASIN=11) - PARAMETER (NRSMCX=4) - PARAMETER (NRSMCW=2) - PARAMETER (NCRDMX=57) - - CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1, - 1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1,NAMVAR*5, - 2 IDBASN*1,NABASN*16,RSMCID*4,RSMCAP*1,CARDNM*9 - - DIMENSION IVTVAR(MAXVIT),VITVAR(MAXVIT),VITFAC(MAXVIT), - 1 ISTVAR(MAXVIT),IENVAR(MAXVIT) - - DIMENSION NAMVAR(MAXVIT+1),IDBASN(NBASIN),NABASN(NBASIN), - 1 BUFIN(MAXCHR),FMTVIT(MAXVIT), - 2 RSMCID(NRSMCX),RSMCAP(NRSMCX),RSMCPR(NBASIN), - 3 RSMCWT(NRSMCW),CARDNM(NCRDMX) - - EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ), - 1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ), - 2 (BUFIN(37),LATNS),(BUFIN(43),LONEW), - 3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ) - - EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ) - - EQUIVALENCE (VITVAR( 3),STMLTZ),(VITVAR( 4),STMLNZ), - 1 (VITVAR( 5),STMDRZ),(VITVAR( 6),STMSPZ), - 2 (VITVAR( 7),PCENZ), (VITVAR( 8),PENVZ), - 3 (VITVAR( 9),RMAXZ) - - CHARACTER STMNAM*9,STMID*3,RSMC*4 - - DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM), - 1 IDATE(MAXSTM),IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM), - 2 PCEN(MAXSTM),RSMC(MAXSTM),STMID(MAXSTM) - - DIMENSION IFRSMC(MAXREC),NUMOKA(NTEST),NUMBAD(MAXREC), - 1 NUMTST(NTEST),IOVRLP(MAXOVR),IVSBRS(0:NVSBRS) - - DIMENSION IVTVRX(MAXVIT),VITVRX(MAXVIT) - - DIMENSION IPRIOR(NOVRMX),AVWT(NOVRMX),RSMCAL(NOVRMX), - 1 STIDAL(NOVRMX),STNMAD(NOVRMX),IRSMC(4),SRTDAY(NOVRMX), - 2 IDASRT(NOVRMX),INDSAM(NOVRMX),DAYZAD(NADDMX), - 3 RSMCOV(NOVRMX),STIDOV(NOVRMX), - 4 RSMCAD(NADDMX),STIDAD(NADDMX) - - DIMENSION RINC(5) - - CHARACTER BUFCK(MAXCHR)*1,RSMCX*4,RELOCX*1,STMIDX*3,BUFINX*100, - 1 STMNMX*9,LATNSX*1,LONEWX*1,BSCOFL*2,RPCOFL*2,STNMAL*9, - 2 RSMCAL*4,STIDAL*3,STNMAD*9,RSMCOV*4,STIDOV*3,STNMOV*9, - 3 STIDAD*3,RSMCAD*4,STHCH*21 - - LOGICAL OSTHFL - - EQUIVALENCE (BUFCK(1),RSMCX),(BUFCK(5),RELOCX),(BUFCK(6),STMIDX), - 1 (BUFCK(1),BUFINX),(BUFCK(10),STMNMX), - 2 (BUFCK(35),LATNSX),(BUFCK(41),LONEWX) - - EQUIVALENCE (IVTVRX(1),IDATEX),(IVTVRX(2),IUTCX), - 1 (VITVRX(3),STMLTX),(VITVRX(4),STMLNX), - 2 (VITVRX(5),STMDRX),(VITVRX(6),STMSPX), - 3 (VITVRX(7),PCENX), (VITVRX(8),PENVX), - 4 (VITVRX(9),RMAXX) - - DATA VITFAC/2*1.0,2*0.1,1.0,0.1,9*1.0/, - 1 FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)', - 2 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/, - 3 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/, - 4 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/ - - DATA IDBASN/'L','E','C','W','O','T','U','P','S','B','A'/ - - DATA NABASN/'ATLANTIC ','EAST PACIFIC ', - 1 'CENTRAL PACIFIC ','WEST PACIFIC ', - 2 'SOUTH CHINA SEA ','EAST CHINA SEA ', - 3 'AUSTRALIA ','SOUTH PACIFIC ', - 4 'SOUTH INDIAN OCN','BAY OF BENGAL ', - 5 'NRTH ARABIAN SEA'/ - - DATA RSMCID/'NHC ','JTWC','ADRM','JMA '/, - 1 RSMCAP/'N','W','A','J'/,RSMCPR/3*1,3*2,3,4*2/, - 2 RSMCWT/1.0,0.25/ - - DATA NAMVAR/'DATE ','TIME ','LAT. ','LONG.','DIR ','SPEED', - 1 'PCEN ','PENV ','RMAX ','VMAX ','RMW ','R15NE', - 2 'R15SE','R15SW','R15NW','DEPTH'/ - -C CARDINAL NUMBER STORM NAMES FOR UNNAMED ATLANTIC AND EAST PACIFIC -C STORMS - - DATA CARDNM/'ONE ','TWO ','THREE ', - 1 'FOUR ','FIVE ','SIX ', - 2 'SEVEN ','EIGHT ','NINE ', - 3 'TEN ','ELEVEN ','TWELVE ', - 4 'THIRTEEN ','FOURTEEN ','FIFTEEN ', - 5 'SIXTEEN ','SEVENTEEN','EIGHTEEN ', - 6 'NINETEEN ','TWENTY ','TWENTY-ON', - 7 'TWENTY-TW','TWENTY-TH','TWENTY-FO', - 8 'TWENTY-FI','TWENTY-SI','TWENTY-SE', - 9 'TWENTY-EI','TWENTY-NI','THIRTY ', - O 'THIRTY-ON','THIRTY-TW','THIRTY-TH', - 1 'THIRTY-FO','THIRTY-FI','THIRTY-SI', - 2 'THIRTY-SE','THIRTY-EI','THIRTY-NI', - 3 'TWENTYONE','TWENTYTWO','TWENTYTHR', - 4 'TWENTYFOU','TWENTYFIV','TWENTYSIX', - 5 'TWENTYSEV','TWENTYEIG','TWENTYNIN', - 6 'THIRTYONE','THIRTYTWO','THIRTYTHR', - 7 'THIRTYFOU','THIRTYFIV','THIRTYSIX', - 8 'THIRTYSEV','THIRTYEIG','THIRTYNIN'/ - -C BUFZON: BUFFER ZONE REQUIRED BY SYNTHETIC DATA PROGRAM (SYNDATA) -C DEGLAT: ONE DEGREE LATITUDE IN KM -C RMAXMN: MINIMUM ALLOWABLE VALUE OF RMAX -C DTOVR : MINIMUM WINDOWN (FRACTIONAL DAYS) FOR OVERLAPPING STORMS -C EXTRAPOLATED TO A COMMON TIME. -C IPRT : CONTROLS PRINTOUT IN SUBROUTINE BASNCK -C FACSPD: CONVERSION FACTOR FOR R(DEG LAT)=V(M/S)*T(FRAC DAY)* -C FACSPD - - DATA BUFZON/1.0/,DEGLAT/111.1775/,RMAXMN/100./,DTOVR/1.0/, - 1 IPRT/0/,FIVMIN/3.4722E-3/,FACSPD/0.77719/ - - DATA ERCRS - 1 /' 1: CANNOT RESOLVE: SAME RSMC REPORTED OVERLAPPING STORMS ', - 2 '10: RESOLVED: SAME RSMC REPORTED OVERLAPPING STORMS ', - 3 ' 2: CANNOT RESOLVE: DIFF. RSMCS REPORTED DIFF. OVERL. STMS.', - 4 '21: DIFFERENT RSMCS REPORTED SAME OVERLAPPING STORMS (CUR) ', - 5 '22: DIFFERENT RSMCS REPORTED SAME OVERLAPPING STORMS (OSTH)', - 6 '30: UNIFIED RECORD CREATED FOR SINGLY OBSERVED STORM ', - 7 ' 3: STORM IS NOT IN A BASIN DEFINED BY BASNCK ', - 8 ' 4: RSMC IS NOT AMONG LISTED CENTERS (NO ERROR RECOVERY) ', - 9 ' 5: DIFFERENT RSMCS REPORTED DIFFERENT OVERLAPPING STORMS ', - O ' 6: SINGLE RSMC HAS TWO STORM IDS FOR THE SAME STORM '/ - -C ERROR CODES FOR BAD RECORDS RETURNED IN IFRSMC ARE AS FOLLOWS: -C 1: CANNOT RESOLVE: SAME RSMC REPORTED OVERLAPPING STORMS -C 10: RESOLVED: SAME RSMC REPORTED OVERLAPPING STORMS -C 2: CANNOT RESOLVE: DIFF. RSMCS REPORTED DIFF. OVERL. STMS. -C 21: DIFFERENT RSMCS REPORTED SAME OVERLAPPING STORMS (CUR) -C 22: DIFFERENT RSMCS REPORTED SAME OVERLAPPING STORMS (OSTH) -C 30: UNIFIED RECORD CREATED FOR SINGLY OBSERVED STORM -C 3: STORM IS NOT IN A BASIN DEFINED BY BASNCK -C 4: RSMC IS NOT AMONG LISTED CENTERS (NO ERROR RECOVERY) -C 5: TWO DIFFERENT RSMCS REPORT DIFFERENT OVERLAPPING STORMS -C 6: SINGLE RSMC HAS TWO STORM IDS FOR THE SAME STORM - - WRITE(6,1) NTEST,NOKAY,NBAD - 1 FORMAT(//'...ENTERING RSMCCK, LOOKING FOR MULTIPLE STORM ', - 1 'REPORTS. NTEST,NOKAY,NBAD=',3I5/) - - CALL WRNING('RSMCCK') - WRITE(6,3) NVSBRS,(NAMVAR(IVSBRS(NV)),NV=1,NVSBRS) - 3 FORMAT(/'...NUMBER OF ALLOWABLE VARIABLES FOR SUBSTITUTION ', - 1 'IS:',I3,' VARIABLES ARE:'/4X,10(A,1X)) - - NADD=0 - NSUBR=0 - NUNIFY=0 - NALADD=0 - REWIND IUNTAN - OVRREC(1:NTEST)=' ' - IOVRLP(1:NTEST)=0 - IFRSMC(NUMTST(1:NTEST))=0 - -C FOR COMPLETE COTEMPORANEOUS CHECKS, WE MUST MAKE AVAILABLE THE -C ORIGINAL SHORT-TERM HISTORY RECORDS. WE STORE THEM AT THE END -C OF THE OVRREC ARRAY. - - REWIND IUNTHO - NRECHO=0 - WRITE(6,13) IUNTHO - 13 FORMAT(/'...READING FROM ORIGINAL SHORT-TERM HISTORY FILE ', - 1 '(UNIT',I3,') INTO SCRATCH SPACE: RECORD #, STORAGE ', - 2 'INDEX, RECORD=') - - 20 CONTINUE - - READ(IUNTHO,21,END=25) OVRREC(MAXOVR-NRECHO) - 21 FORMAT(A) - -C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20 -C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR -C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF -C LATITUDE N/S INDICATOR TO FIND OUT ... - - if(OVRREC(MAXOVR-NRECHO)(35:35).eq.'N' .or. - 1 OVRREC(MAXOVR-NRECHO)(35:35).eq.'S') then - -C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR - -C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE -C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 2-digit year "',OVRREC(MAXOVR-NRECHO)(20:21),'"' - PRINT *, ' ' - PRINT *, 'From unit ',iuntho,'; OVRREC(MAXOVR-NRECHO)-2: ', - $ OVRREC(MAXOVR-NRECHO) - PRINT *, ' ' - DUMY2K(1:19) = OVRREC(MAXOVR-NRECHO)(1:19) - IF(OVRREC(MAXOVR-NRECHO)(20:21).GT.'20') THEN - DUMY2K(20:21) = '19' - ELSE - DUMY2K(20:21) = '20' - ENDIF - DUMY2K(22:100) = OVRREC(MAXOVR-NRECHO)(20:100) - OVRREC(MAXOVR-NRECHO) = DUMY2K - PRINT *, ' ' - PRINT *, '==> 2-digit year converted to 4-digit year "', - $ OVRREC(MAXOVR-NRECHO)(20:23),'" via windowing technique' - PRINT *, ' ' - PRINT *, 'From unit ',iuntho,'; OVRREC(MAXOVR-NRECHO)-2: ', - $ OVRREC(MAXOVR-NRECHO) - PRINT *, ' ' - - ELSE IF(OVRREC(MAXOVR-NRECHO)(37:37).eq.'N' .OR. - 1 OVRREC(MAXOVR-NRECHO)(37:37).eq.'S') THEN - -C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR -C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT '(a,a,a)', '==> Read in RECORD from tcvitals file -- ', - $ ' contains a 4-digit year "',OVRREC(MAXOVR-NRECHO)(20:23),'"' - PRINT *, ' ' - PRINT '(a,i2,a,a)', - $ 'From unit ',iuntho,'; OVRREC(MAXOVR-NRECHO)-2: ', - $ OVRREC(MAXOVR-NRECHO) - PRINT *, ' ' - PRINT *, '==> No conversion necessary' - PRINT *, ' ' - - ELSE - - PRINT *, ' ' - PRINT *, '***** Cannot determine if this record contains ', - $ 'a 2-digit year or a 4-digit year - skip it and try reading ', - $ 'the next record' - PRINT *, ' ' - GO TO 20 - - END IF - - WRITE(6,23) NTEST+NRECHO+1,MAXOVR-NRECHO,OVRREC(MAXOVR-NRECHO) - 23 FORMAT(' ...',I4,'...',I4,'...',A) - NRECHO=NRECHO+1 - - IF(NRECHO .GE. MAXOVR-NTEST) THEN - WRITE(6,24) NRECHO,MAXOVR,NTEST - 24 FORMAT(/'******INSUFFICIENT SCRATCH SPACE TO STORE ORIGINAL ', - 1 'SHORT-TERM HISTORICAL RECORDS IN OVRREC. NRECHO,', - 2 'MAXOVR,NTEST=',3I3) - CALL ABORT1(' RSMCCK',24) - ENDIF - - GO TO 20 - 25 CONTINUE - WRITE(6,26) NRECHO - 26 FORMAT(' ...',I3,' RECORDS READ FROM ORIGINAL SHORT-TERM ', - 1 'HISTORY FILE.') - -C PART I: -C CHECK COTEMPORANEOUS RECORDS FOR STORMS WITHIN EACH OTHER'S RMAX - - WRITE(6,27) - 27 FORMAT(//'...BEGINNING RSMCCK PART I: COTEMPORANEOUS CHECKS FOR ', - 1 'OVERLAPPING STORMS.') - - DO NREC=1,NTEST - - IETYP=0 - IEROVR=0 - NOVRLP=1 - NRECSV=NREC - -C RECORDS THAT WERE PROCESSED AS COTEMPORANEOUS OVERLAPS PREVIOUSLY -C DO NOT GET FURTHER PROCESSING - - IF(IFRSMC(NUMTST(NREC)) .NE. 0) GO TO 400 - -C RECOVER DATE, UTC, LAT/LON AND RMAX - - BUFINZ=TSTREC(NREC) - - DO IV=1,MAX(9,IVSBRS(NVSBRS)) - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 TSTREC(NREC)) - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 BUFINZ) - ENDDO - - VITVAR(3:MAX(9,IVSBRS(NVSBRS)))= - $ REAL(IVTVAR(3:MAX(9,IVSBRS(NVSBRS))))* - $ VITFAC(3:MAX(9,IVSBRS(NVSBRS))) - IF(LATNS .EQ. 'S') STMLTZ=-STMLTZ - IF(LONEW .EQ. 'W') STMLNZ=360.-STMLNZ - -C STORE NEEDED VARIABLES FOR LATER REFERENCE - - STMNAM(1)=STMNMZ - STMID (1)=STMIDZ - RSMC (1)=RSMCZ - STMLAT(1)=STMLTZ - STMLON(1)=STMLNZ - RMAX (1)=RMAXZ - PCEN (1)=PCENZ - PENV (1)=PENVZ - IOVRLP(1)=NREC - OVRREC(1)=BUFINZ - CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYZ) - - IF(RMAXZ .LT. 0.0) THEN - DO NBA=1,NBASIN - IF(STMIDZ(3:3) .EQ. IDBASN(NBA)) THEN - IBASN=NBA - GO TO 46 - ENDIF - ENDDO - 46 CONTINUE - RMAXZ=TCCLIM(9,IBASN) - WRITE(6,47) NREC,RMAXZ,NABASN(IBASN) - 47 FORMAT(' ###RMAXZ MISSING FOR COTEMPORANEOUS CHECK ON RECORD',I3, - 1 '.'/4X,'REPLACEMENT VALUE WILL BE A CLIMATOLOGICAL ', - 2 'GUESS OF ',F6.1,' KM FOR BASIN ',A,'.') - ENDIF - -C NOW COMPARE WITH ALL REMAINING STORM REPORTS THAT HAVE NOT BEEN -C MARKED OFF AS ERRONEOUS - - NRECHZ=-1 - DO NTST=NREC+1,NTEST+NRECHO - - IF(NTST .LE. NTEST .AND. IFRSMC(NUMTST(NTST)) .NE. 0) GO TO 100 - - IF(NTST .LE. NTEST) THEN - INDTST=NTST - BUFINX=TSTREC(NTST) - OSTHFL=.FALSE. - ELSE - NRECHZ=NRECHZ+1 - INDTST=MAXOVR-NRECHZ - BUFINX=OVRREC(INDTST) - OSTHFL=.TRUE. - ENDIF - - DO IV=1,MAX(9,IVSBRS(NVSBRS)) - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV), - 1 BUFINX) - ENDDO - - VITVRX(3:MAX(9,IVSBRS(NVSBRS)))= - $ REAL(IVTVRX(3:MAX(9,IVSBRS(NVSBRS))))* - $ VITFAC(3:MAX(9,IVSBRS(NVSBRS))) - - IF(LATNSX .EQ. 'S') STMLTX=-STMLTX - IF(LONEWX .EQ. 'W') STMLNX=360.-STMLNX - -C COTEMPORANEOUS CHECK - - IF(IDATEX .EQ. IDATEZ .AND. IUTCX .EQ. IUTCZ) THEN - - RMAXSV=RMAXX - IF(RMAXX .LT. 0.0) THEN - DO NBA=1,NBASIN - IF(STMIDX(3:3) .EQ. IDBASN(NBA)) THEN - IBASN=NBA - GO TO 66 - ENDIF - ENDDO - 66 CONTINUE - RMAXX=TCCLIM(9,IBASN) - WRITE(6,75) NTST,RMAXX,NABASN(IBASN) - 75 FORMAT(' ###RMAXX MISSING FOR COTEMPORANEOUS CHECK ON RECORD',I3, - 1 '.'/4X,'REPLACEMENT VALUE WILL BE A CLIMATOLOGICAL ', - 2 'GUESS OF ',F6.1,' KM FOR BASIN ',A,'.') - ENDIF - - DISTZ=DISTSP(STMLTZ,STMLNZ,STMLTX,STMLNX)*1.E-3 - -C OVERLAP CHECK. BUFFER ZONE CORRESPONDS TO SYNDATA CONDITION - - IF(DISTZ .LE. RMAXZ+RMAXX+BUFZON*DEGLAT) THEN - -C IF THE MATCHING RECORD IS FROM THE SAME RSMC AND THE STORM -C ID IS THE SAME AND THE RECORD WAS IN THE ORIGINAL SHORT-TERM -C HISTORY FILE, WE ASSUME THE RECORD (NREC) IS AN UPDATE TO THE -C EARLIER RECORD. THE ERROR FLAG IS RESET TO INDICATE NO ERROR. - - IF(RSMCZ .EQ. RSMCX .AND. - 1 STMIDZ .EQ. STMIDX .AND. OSTHFL) THEN - WRITE(6,76) NREC,INDTST,NREC,BUFINZ,INDTST,BUFINX - 76 FORMAT(/'###RECORD IN ORIGINAL SHORT-TERM HISTORY FILE HAS ', - 1 'PROBABLY BEEN UPDATED . NREC,INDTST=',2I4, - 2 '. RECORDS ARE:'/2(4X,'...',I4,'...',A/)) - GO TO 100 - - ELSE - -C STORE NEEDED VARIABLES FOR LATER REFERENCE. DON'T USE THE -C CLIMATOLOGICAL VALUE! - - NOVRLP=NOVRLP+1 - IOVRLP(NOVRLP)=NTST - OVRREC(NOVRLP)=BUFINX - STMNAM(NOVRLP)=STMNMX - STMID (NOVRLP)=STMIDX - RSMC (NOVRLP)=RSMCX - STMLAT(NOVRLP)=STMLTX - STMLON(NOVRLP)=STMLNX - RMAX (NOVRLP)=RMAXSV - PCEN (NOVRLP)=PCENX - PENV (NOVRLP)=PENVX - - WRITE(6,77) DISTZ,NREC,NTST,INDTST,BUFINZ,BUFINX - 77 FORMAT(//'...TWO STORMS REPORTED AT THE SAME DATE/TIME WITHIN ', - 1 'THE OTHERS CIRCULATION. DISTZ,NREC,NTST,INDTST=',F7.1,2 - 2 I4,I5/2(4X,'...',A,'...'/)) - -C SAME OR DIFFERENT RSMC? - - IF(RSMCZ .EQ. RSMCX) THEN - IETYP=1 - ELSE - IETYP=2 - ENDIF - - IF(NOVRLP .EQ. 2) THEN - IEROVR=IETYP - - ELSE - IF(IETYP .NE. IEROVR) THEN - IOVRLP(NOVRLP)=-IABS(IOVRLP(NOVRLP)) - WRITE(6,71) NREC,NTST - 71 FORMAT(' ###WARNING: MULTIPLE OVERLAP TYPES FOR NREC=',I3/4X, - 1 'ERROR RECOVERY CURRENTLY WORKS ON A SINGLE OVERLAP TYPE ', - 2 'SO THIS RECORD=#',I3,' WILL BE AUTOMATICALLY DISCARDED.') - ENDIF - ENDIF - - ENDIF - ENDIF - ENDIF - 100 CONTINUE - ENDDO - IF(IETYP .EQ. 0) GO TO 390 - -C ERROR RECOVERY FOR PART I: - - WRITE(6,103) NREC,IEROVR,NOVRLP-1,(IOVRLP(NOVR),NOVR=2,NOVRLP) - 103 FORMAT(' ...SUMMARY OF OVERLAPS FOR NREC=',I3,'. OVERLAP ', - 1 'TYPE=',I3,' AND NUMBER OF OVERLAPS=',I3, - 2 ' OVERLAP INDICES ARE:'/4X,'(NEGATIVE OVERLAP ', - 3 'INDICES MEAN THAT THE OVERLAP TYPE DIFFERS FROM ', - 4 'THE PRIMARY ONE WHICH IS IEROVR)'/4X,10I3) - -C **************************************************** -C **************************************************** -C **** **** -C **** MULTIPLE REPORTS BY THE SAME INSTITUTION **** -C **** **** -C **************************************************** -C **************************************************** - - IF(IEROVR .EQ. 1) THEN - IVR=9 - WRITE(6,107) IETYP - 107 FORMAT(' ******STORMS ARE REPORTED BY THE SAME RSMC, WHICH ', - 1 'IS A LOGICAL ERROR. IETYP=',I2/4X,'WE PROCEED TO ', - 2 'RECOVER THIS ERROR BY REDUCING THE RMAX OF THE LARGEST ', - 3 'STORM SO THAT OVERLAP WILL NOT OCCUR.') - - IF(NOVRLP .GT. 2) WRITE(6,109) - 109 FORMAT(' ###WARNING, NOVRLP > 2 SO THAT PROCESSING WILL ', - 1 'OCCUR FOR ONLY THE LARGEST AND SMALLEST STORMS. ', - 2 'OTHERS WILL BE AUTOMATICALLY MARKED ERRONEOUS.') - -C PICK OUT THE LARGEST AND SMALLEST STORMS - - INDXZ=1 - INDXX=1 - RMAXZ=RMAX(1) - RMAXX=RMAX(1) - DO NOVR=2,NOVRLP - IF(IOVRLP(NOVR) .GT. 0) THEN - IF(RMAX(NOVR) .GT. RMAXZ) THEN - RMAXZ=RMAX(NOVR) - INDXZ=NOVR - ENDIF - IF(RMAX(NOVR) .LT. RMAXX) THEN - RMAXX=RMAX(NOVR) - INDXX=NOVR - ENDIF - ENDIF - ENDDO - - DISTZX=DISTSP(STMLAT(INDXZ),STMLON(INDXZ), - 1 STMLAT(INDXX),STMLON(INDXX))*1.E-3 - EXCESS=RMAXZ+RMAXX+BUFZON*DEGLAT-DISTZX - WRITE(6,121) INDXZ,INDXX,STMID(INDXZ),RMAXZ,STMID(INDXX),RMAXX, - 1 DISTZX,EXCESS - 121 FORMAT('...INDXZ,INDXX,STMID(INDXZ),RMAX(INDXZ),STMID(INDXX),', - 1 'RMAX(INDXX)=',2I3,2(1X,A,F7.1),' DISTZX,EXCESS=',2F9.1) - RMAXZT=RMAXZ-EXCESS - -C RECOVERY METHOD 1: SUBTRACT EXCESS FROM LARGEST RMAX BUT MAINTAIN -C RELATIVE SIZE - - IF(RMAXZT .GT. RMAXX) THEN - WRITE(OVRREC(INDXZ)(ISTVAR(IVR):IENVAR(IVR)),FMTVIT(IVR)) - 1 NINT(RMAXZT) - OVRREC(INDXZ)(ISTVAR(IVR)-1:ISTVAR(IVR)-1)='O' - OVRREC(INDXX)=TSTREC(IOVRLP(INDXX)) - WRITE(6,123) IOVRLP(INDXZ),RMAXZ,RMAXZT,INDXZ,OVRREC(INDXZ) - 123 FORMAT(' ###IMPORTANT NOTE: FOR RECORD',I3,' RMAXZ=',F7.1, - 1 ' WILL BE SUBSTITUTED BY RMAXZT=',F7.1,' FOR INDXZ=',I3, - 2 '. AFTER SUBSTITUTION, OVRREC='/4X,A) - IETYP=-10 - -C RECOVERY METHOD 2: SUBTRACT HALF THE EXCESS FROM EACH RMAX - - ELSE - WRITE(6,125) - 125 FORMAT('...UNABLE TO MAINTAIN RMAXZ>RMAXX. HALF THE ', - 1 'EXCESS WILL BE SUBTRACTED FROM EACH REPORT.') - RMAXZT=RMAXZ-0.5*EXCESS - RMAXXT=RMAXX-0.5*EXCESS - IF(RMAXZT .GE. RMAXMN .AND. RMAXXT .GE. RMAXMN) THEN - WRITE(OVRREC(INDXZ)(ISTVAR(IVR):IENVAR(IVR)),FMTVIT(IVR)) - 1 NINT(RMAXZT) - WRITE(OVRREC(INDXX)(ISTVAR(IVR):IENVAR(IVR)),FMTVIT(IVR)) - 1 NINT(RMAXXT) - OVRREC(INDXX)(ISTVAR(IVR)-1:ISTVAR(IVR)-1)='O' - WRITE(6,123) IOVRLP(INDXZ),RMAXZ,RMAXZT,INDXZ,OVRREC(INDXZ) - WRITE(6,127) IOVRLP(INDXX),RMAXX,RMAXXT,IOVRLP(INDXX), - 1 OVRREC(INDXX) - 127 FORMAT(' ###IMPORTANT NOTE: FOR RECORD',I3,' RMAXX=',F7.1, - 1 ' WILL BE SUBSTITUTED BY RMAXXT=',F7.1,' FOR INDXX=',I3, - 2 '. AFTER SUBSTITUTION, OVRREC='/4X,A) - IETYP=-10 - - ELSE - WRITE(6,129) RMAXZT,RMAXXT,RMAXMN - 129 FORMAT(' ******RMAXZ AND RMAXX REDUCTION METHODS HAVE FAILED. ', - 1 'RMAXZT,RMAXXT=',2F7.1,' < RMAXMN=',F7.1) - ENDIF - ENDIF - - DO NOVR=1,NOVRLP - -C ASSIGN ERROR FLAGS AND UPDATE RECORDS FOR THE TWO RECORDS -C THAT WE TRIED TO CORRECT - - IF(NOVR .EQ. INDXZ .OR. NOVR .EQ. INDXX) THEN - IFRSMC(NUMTST(IOVRLP(NOVR)))=IETYP - IF(IETYP .GT. 0) THEN - NADD=NADD+1 - NUMBAD(NADD+NBAD)=NUMTST(IOVRLP(NOVR)) - BADREC(NADD+NBAD)=TSTREC(IOVRLP(NOVR)) - ELSE - NOKAY=NOKAY+1 - NUMOKA(NOKAY)=NUMTST(IOVRLP(NOVR)) - OKAREC(NOKAY)=OVRREC(NOVR) - ENDIF - -C ASSIGN ERROR FLAGS TO ALL OTHER RECORDS - - ELSE - IFRSMC(NUMTST(IOVRLP(NOVR)))=IETYP - NADD=NADD+1 - NUMBAD(NADD+NBAD)=NUMTST(IOVRLP(NOVR)) - BADREC(NADD+NBAD)=TSTREC(IOVRLP(NOVR)) - ENDIF - ENDDO - GO TO 400 - -C *************************************************** -C *************************************************** -C **** **** -C **** MULTIPLE REPORTS BY TWO DIFFERENT RSMCS **** -C **** **** -C *************************************************** -C *************************************************** - - ELSE IF(IEROVR .EQ. 2) THEN - WRITE(6,201) IETYP - 201 FORMAT('...STORMS ARE REPORTED BY DIFFERENT RSMCS. ', - 1 'WE PROCEED TO SEE IF THEY ARE THE SAME STORM BY ', - 2 'COMPARING NAMES.'/4X,'THEN WE CONSTRUCT A COMMON ', - 3 'STORM ID. PRELIMINARY IETYP=',I2) - - BUFINZ=OVRREC(1) - - NERROR=0 - DO NOVR=2,NOVRLP - IF(STMNAM(NOVR) .EQ. 'NAMELESS' .AND. - 1 STMNMZ .EQ. 'NAMELESS') THEN - WRITE(6,202) STMIDZ,RSMCZ,STMID(NOVR),RSMC(NOVR) - 202 FORMAT(' ###OVERLAPPING NAMELESS STORMS HAVE IDS AND RSMCS=', - 1 2(2(A,1X),2X)) - - ELSE IF(STMNAM(NOVR) .EQ. STMNMZ) THEN - WRITE(6,203) STMNAM(NOVR),NOVR - 203 FORMAT('...STORM NAME=',A,' FOR NOVR=',I3,' MATCHES FIRST ', - 1 'REPORT. THE STORMS ARE THE SAME.') - - ELSE - -C IF ONE RSMC REPORTS A NAMELESS STORM AND THE OTHER RSMCS REPORT -C A NAME, TRANSFER THE STORM NAME TO THE NAMELESS RECORD. - - IF(STMNMZ .EQ. 'NAMELESS') THEN - WRITE(6,205) STMNAM(NOVR),NOVR - 205 FORMAT('...STMNMZ IS NAMELESS. COPYING STMNAM(NOVR)=',A,' TO ', - 1 'STMNMZ. NOVR=',I3) - STMNAM(1)=STMNAM(NOVR) - STMNMZ=STMNAM(NOVR) - OVRREC(1)=BUFINZ - - IF(IOVRLP(1) .LE. NTEST) TSTREC(IOVRLP(1))=BUFINZ - - ELSE IF(STMNAM(NOVR) .EQ. 'NAMELESS') THEN - WRITE(6,207) STMNMZ,NOVR - 207 FORMAT('...STMNAM(NOVR) IS NAMELESS. COPYING STMNMZ=',A,' TO ', - 1 'STMNAM(NOVR). NOVR=',I3) - STMNAM(NOVR)=STMNMZ - BUFINX=OVRREC(NOVR) - STMNMX=STMNMZ - OVRREC(NOVR)=BUFINX - - IF(IOVRLP(NOVR) .LE. NTEST) TSTREC(IOVRLP(NOVR))=BUFINX - -C THERE ARE TWO NAMES, NEITHER OF WHICH IS NAMELESS. THUS THERE IS -C AN UNTREATABLE ERROR - - ELSE - IETYP=5 - NERROR=NERROR+1 - IOVRLP(NOVR)=-IABS(IOVRLP(NOVR)) - WRITE(6,209) NOVR,STMNAM(NOVR),STMNMZ,IETYP - 209 FORMAT(/'******FOR NOVR=',I3,' STORM NAME=',A,' DOES NOT MATCH ', - 1 'NAME FOR THE FIRST REPORT=',A,'.'/4X,' THERE IS NO ', - 2 'ERROR RECOVERY AT THIS TIME. IETYP=',I3) - -C ERROR MARKING OFF ON THE FLY HERE - - IFRSMC(NUMTST(IABS(IOVRLP(NOVR))))=IETYP - NADD=NADD+1 - NUMBAD(NADD+NBAD)=NUMTST(IABS(IOVRLP(NOVR))) - BADREC(NADD+NBAD)=TSTREC(IABS(IOVRLP(NOVR))) - IETYP=IEROVR - ENDIF - ENDIF - ENDDO - -C IF AN ERROR HAS OCCURRED IN THE PREVIOUS PROCESSING REMOVE -C THE ERRONEOUS RECORD FROM THE OVERLAP LIST AND CONTINUE - - IF(NERROR .NE. 0) THEN - NOVRZ=0 - WRITE(6,213) NERROR - 213 FORMAT(' ******',I3,' ERRORS FOUND DURING STORM NAME MATCHING.') - DO NOVR=1,NOVRLP - IF(IOVRLP(NOVR) .GE. 0 .AND. IOVRLP(NOVR) .LE. NTEST) THEN - NOVRZ=NOVRZ+1 - IOVRLP(NOVRZ)=IOVRLP(NOVR) - OVRREC(NOVRZ)=OVRREC(NOVR) - STMNAM(NOVRZ)=STMNAM(NOVR) - STMID (NOVRZ)=STMID(NOVR) - RSMC (NOVRZ)=RSMC(NOVR) - STMLAT(NOVRZ)=STMLAT(NOVR) - STMLON(NOVRZ)=STMLON(NOVR) - RMAX (NOVRZ)=RMAX(NOVR) - PCEN (NOVRZ)=PCEN(NOVR) - PENV (NOVRZ)=PENV(NOVR) - ENDIF - ENDDO - NOVRLP=NOVRZ - IF(NOVRLP .EQ. 1) GO TO 390 - ENDIF - - WRITE(6,221) - 221 FORMAT(' ...THE OBSERVING RSMCS, THEIR ABBREVIATIONS, ', - 1 'PRIORITIES, INDICES AND REPORTED BASINS ARE:'/11X, - 2 'RSMC',3X,'RSMCAP',3X,'PRIORITY',3X,'INDEX',3X,'BASIN',3X, - 3 'BSCOFL',3X,'RPCOFL') - - NERROR=0 - DO NOVR=1,NOVRLP - -C WHICH BASIN ARE WE IN? - - CALL BASNCK(STMID(NOVR),STMLAT(NOVR),STMLON(NOVR),NBA,IPRT,IER) - IF(IER .EQ. 11) THEN - BSCOFL='IB' - ELSE - BSCOFL='CB' - ENDIF - - IF(IER .EQ. 3) THEN - IETYP=IER - NERROR=NERROR+1 - IOVRLP(NOVR)=-IABS(IOVRLP(NOVR)) - -C AGAIN, ERROR MARKING OFF ON THE FLY - - IFRSMC(NUMTST(IABS(IOVRLP(NOVR))))=IETYP - NADD=NADD+1 - NUMBAD(NADD+NBAD)=NUMTST(IABS(IOVRLP(NOVR))) - BADREC(NADD+NBAD)=TSTREC(IABS(IOVRLP(NOVR))) - IETYP=IEROVR - ENDIF - - IF(NOVR .EQ. 1) THEN - NBASV=NBA - RPCOFL='CR' - ELSE - IF(NBA .NE. NBASV) THEN - RPCOFL='IR' - NBA=NBASV - ENDIF - ENDIF - -C IS THIS A REPORT BY THE PRIORITY RSMC FOR THIS BASIN? THE -C PRIORITY FLAG IS TWO DIGITS. THE FIRST DIGIT IS PRIORITY -C (=1 IF THE RSMC IS THE PRIORITY RSMC, =2 OTHERWISE). THE -C SECOND DIGIT IS THE RSMC INDEX - - NRSPRI=RSMCPR(NBA) - NRSMC=-1 - DO NRSZ=1,NRSMCX - IF(RSMCID(NRSZ) .EQ. RSMC(NOVR)) THEN - NRSMC=NRSZ - IF(NRSMC .EQ. NRSPRI) THEN - IPRIOR(NOVR)=10+NRSMC - AVWT(NOVR)=RSMCWT(1) - BUFINZ=OVRREC(NOVR) - ELSE - IPRIOR(NOVR)=20+NRSMC - AVWT(NOVR)=RSMCWT(2) - ENDIF - GO TO 231 - ENDIF - ENDDO - 231 CONTINUE - - IF(NRSMC .GE. 0) THEN - WRITE(6,233) NOVR,RSMC(NOVR),RSMCAP(NRSMC),IPRIOR(NOVR),NRSMC, - 1 NBA,BSCOFL,RPCOFL - 233 FORMAT(' ',5X,I3,2X,A,6X,A,8X,I2,5X,I4,5X,I3,2(7X,A)) - - ELSE - IETYP=4 - NERROR=NERROR+1 - IOVRLP(NOVR)=-IABS(IOVRLP(NOVR)) - WRITE(6,235) RSMC(NOVR),NOVR,IETYP - 235 FORMAT('0******RSMC=',A,' COULD NOT BE FOUND IN RSMCCK. THIS ', - 1 'RECORD IS ERRONEOUS. NOVR=',I3,', IETYP=',I3) - -C AGAIN, ERROR MARKING OFF ON THE FLY - - IFRSMC(NUMTST(IABS(IOVRLP(NOVR))))=IETYP - NADD=NADD+1 - NUMBAD(NADD+NBAD)=NUMTST(IABS(IOVRLP(NOVR))) - BADREC(NADD+NBAD)=TSTREC(IABS(IOVRLP(NOVR))) - ENDIF - - ENDDO - -C IF AN ERROR HAS OCCURRED IN THE PREVIOUS PROCESSING REMOVE -C THE ERRONEOUS RECORD FROM THE OVERLAP LIST AND CONTINUE - - IF(NERROR .NE. 0) THEN - WRITE(6,243) NERROR - 243 FORMAT(' ******',I3,' ERRORS FOUND DURING RSMC VERIFICATION.') - NOVRZ=0 - DO NOVR=1,NOVRLP - IF(IOVRLP(NOVR) .GE. 0 .AND. IOVRLP(NOVR) .LE. NTEST) THEN - NOVRZ=NOVRZ+1 - IOVRLP(NOVRZ)=IOVRLP(NOVR) - IPRIOR(NOVRZ)=IPRIOR(NOVR) - OVRREC(NOVRZ)=OVRREC(NOVR) - STMNAM(NOVRZ)=STMNAM(NOVR) - STMID (NOVRZ)=STMID(NOVR) - RSMC (NOVRZ)=RSMC(NOVR) - STMLAT(NOVRZ)=STMLAT(NOVR) - STMLON(NOVRZ)=STMLON(NOVR) - RMAX (NOVRZ)=RMAX(NOVR) - PCEN (NOVRZ)=PCEN(NOVR) - PENV (NOVRZ)=PENV(NOVR) - AVWT (NOVRZ)=AVWT(NOVR) - ENDIF - ENDDO - NOVRLP=NOVRZ - IF(NOVRLP .EQ. 1) GO TO 390 - ENDIF - - WRITE(6,251) NOVRLP - 251 FORMAT(6X,'KEY: BSCOFL=IB IF REPORTED LAT/LON AND BASIN ', - 1 'ID FROM STORM ID ARE INCONSISTENT.'/18X,'=CB IF ', - 2 'LAT/LON AND BASIN ID ARE CONSISTENT.'/12X,'RPCOFL=', - 3 'CR IF REPORTED BASIN IS THE SAME AS THE FIRST RECORD.' - 4 /18X,'=IR IF REPORTED BASIN IS DIFFERENT FROM THE FIRST ', - 5 'RECORD.'/4X,I3,' OVERLAPPING STORMS HAVE BEEN FOUND.') - -C CHECK THE ALIAS FILE FOR REPORTS UNDER OTHER NAMES - - DO NOVR=1,NOVRLP - NALIAS=0 - NALREC=0 - REWIND IUNTAL - WRITE(6,257) STMNAM(NOVR),STMID(NOVR) - 257 FORMAT(/'...CHECKING THE ALIAS FILE TRYING TO FIND STORM NAME ', - 1 'ID AND RSMC THAT MATCH',3(1X,A)) - - 260 READ(IUNTAL,261,END=300) NALMX,STMNMX,(RSMCAL(NAL),STIDAL(NAL), - 1 NAL=1,MIN(NALMX,NOVRMX)) - 261 FORMAT(I1,1X,A9,10(1X,A4,1X,A3)) - NALREC=NALREC+1 - IF(NOVR .EQ. 1) WRITE(6,267) NALREC,RSMCAL(1),STIDAL(1), - 1 NALMX-1,STMNMX,(RSMCAL(NAL),STIDAL(NAL),NAL=2,MIN(NALMX,NOVRMX)) - 267 FORMAT('...ALIAS RECORD',I3,'=',2(A,1X),' HAS ',I3,' OBSERVERS ', - 1 'AND NAME=',A,' OBSERVERS ARE:'/(14X,2(A,1X))) - -C WRITE(6,293) STMID(NOVR),STIDAL(NAL) -C 293 FORMAT('...CHECKING STORM IDS VERSUS ALIAS FILE. STMID(NOVR),', -C 1 'STIDAL(NAL)=',2(A,1X)) - - IFNDAL=0 - IF(STMNMX .NE. 'NAMELESS' .AND. STMNAM(NOVR) .EQ. STMNMX .AND. - 1 STMID(NOVR)(3:3) .EQ. STIDAL(1)(3:3)) THEN - IFNDAL=1 - WRITE(6,294) STMNMX,STIDAL(1)(3:3) - 294 FORMAT('...EXACT NAME AND BASIN MATCH FOR NAMED STORM=',A,' IN ', - 1 'BASIN ',A,' IN THE ALIAS FILE.') - - ELSE - DO NALZZ=2,MIN(NALMX,NOVRMX) - IF(STMID(NOVR) .EQ. STIDAL(NALZZ) .AND. - 1 RSMC(NOVR) .EQ. RSMCAL(NALZZ)) THEN - IFNDAL=1 - WRITE(6,295) STMNMX,STIDAL(NALZZ),RSMC(NALZZ) - 295 FORMAT('...STORM ID AND RSMC MATCH FOR STORM=',A,' IN THE ', - 1 'ALIAS FILE. ID,RSMC=',2(A,1X)) - ENDIF - ENDDO - ENDIF - - IF(IFNDAL .EQ. 1) THEN - NALIAS=NALMX-1 - -C CHECK THAT THE OBSERVING RSMCS IN THE ALIAS FILE ARE AT LEAST -C THOSE OBSERVING FOR THIS CASE - - NOFIND=0 - DO NOVRZ=1,NOVRLP - DO NALZ=2,MIN(NALMX,NOVRMX) - IF(RSMC(NOVRZ) .EQ. RSMCAL(NALZ)) THEN - NOFIND=0 - GO TO 2294 - ELSE - NOFIND=NOFIND+1 - ENDIF - ENDDO - 2294 CONTINUE - IF(NOFIND .GT. 0) GO TO 2298 - ENDDO - - 2298 IF(NOFIND .EQ. 0) THEN - RSMCZ=RSMCAL(1) - STMIDZ=STIDAL(1) - -C RESET NALIAS TO FORCE A NEW COMBINED RSMC IF THE OBSERVING -C RSMCS AREN'T ON THE ALIAS FILE - - ELSE - WRITE(6,297) - 297 FORMAT('...RESETTING NALIAS=0 TO FORCE NEW ALIAS RECORD ', - 1 'BECAUSE A NEW RSMC HAS OBSERVED THIS STORM.') - NALIAS=0 - ENDIF - GO TO 301 - ENDIF - GO TO 260 - 300 CONTINUE - ENDDO - 301 CONTINUE - -C CONSTRUCT AND WRITE A NEW COMBINED RSMC IF NECESSARY - - IF(NALIAS .EQ. 0) THEN - IF(NALREC .EQ. 0) WRITE(6,303) - 303 FORMAT(/'...THE ALIAS FILE IS EMPTY. WE WILL ADD A NEW ALIAS.') - - IF(IFNDAL .EQ. 0) THEN - RSMCZ='!'//RSMCAP(NRSPRI) - WRITE(6,343) NRSPRI,RSMCAP(NRSPRI),RSMCZ - 343 FORMAT('...CONSTRUCTING NEW COMBINED RSMC FROM PRIORITY RSMC. ', - 1 'NRSPRI,','RSMCAP(NRSPRI),RSMCZ=',I4,2(1X,'...',A,'...')) - NSUB=0 - DO NOVZ=1,MIN0(NOVRLP,3) - IF(IPRIOR(NOVZ)/10 .NE. 1) THEN - NSUB=NSUB+1 - RSMCZ(2+NSUB:2+NSUB)=RSMCAP(IPRIOR(NOVZ)-10*(IPRIOR(NOVZ)/10)) - WRITE(6,349) RSMCZ(2+NSUB:2+NSUB),RSMCZ - 349 FORMAT('...ADDING RSMCAP=',A,', RSMCZ=',A) - ENDIF - ENDDO - - NSUB=1 - DO NOVZ=1,MIN(NOVRLP,NOVRMX-1) - NSUB=NSUB+1 - RSMCAL(NSUB)=RSMC(NOVZ) - STIDAL(NSUB)=STMID(NOVZ) - IF(IPRIOR(NOVZ)/10 .EQ. 1) THEN - RSMCAL(1)=RSMCZ - STIDAL(1)=STMIDZ - ENDIF - ENDDO - NOVRAD=NOVRLP+1 - -C CHECK THE CHOICE OF STORM ID VERSUS THE CATALOG. MAKE ANOTHER -C CHOICE IF THE FIRST CHOICE IS TAKEN. - - WRITE(6,361) STIDAL(1),(STMID(NOVZ),RSMC(NOVZ),NOVZ=1,NOVRLP) - 361 FORMAT('...CHECKING THE CATALOG TO SEE THE IF STORM IS IN ', - 1 'THERE. FIRST CHOICE IS: ',A/4X, - 2 'POSSIBLE IDS AND RSMCS ARE:'/(14X,2(A,2X))) - - read(stidal(1)(1:2),3333) minid - 3333 format(i2.2) - write(6,3334) minid - 3334 FORMAT('...ID OF FIRST CHOICE STORM ID=',I3) - - do novz=1,novrlp - call stcati(iuntca,stmid(novz),rsmc(novz),stmidx,ifnd) - if(ifnd .eq. 1) then - stidal(1)=stmidx - write(6,3335) stidal(1) - 3335 format('...Eureka, this storm is in the catalog with id=',a) - go to 3341 - - else - -c Pick out the maximum storm id from the priority basin - - if(stmid(novz)(3:3) .eq. stidal(1)(3:3)) then - read(stmid(novz)(1:2),3333) minidz - minid=max0(minid,minidz) - endif - - endif - enddo - 3341 continue - - if(ifnd .eq. 0) then - write(stidal(1)(1:2),3333) minid - write(6,3351) stidal(1) - 3351 format('...This storm is not in the catalog. Assign a unique ', - 1 'id that is the smallest for the overlapping storms=',a) - endif - stmidz=stidal(1) - - ELSE - WRITE(6,3357) RSMCAL(1),STIDAL(1),NALMX,(RSMCAL(NN), - 1 STIDAL(NN),NN=2,NALMX) - 3357 FORMAT('...COPYING RSMC =(',A,') AND STORM ID =(',A,') FROM ', - 1 'ALIAS FILE AND ADDING NEW RSMCS.'/4X,'NEW RSMCS AND ', - 2 'STORM IDS WILL NOW BE ADDED. CURRENT NUMBER IS',I3, - 3 ' OTHER RSMCS, STORM IDS ARE:'/(10X,2(A,1X))) - -C ADD NEW RSMCS AND ALIASES AS APPROPRIATE - - NADDRS=0 - - DO NOVR=1,NOVRLP - - DO NRSZA=1,NRSMCX - IF(RSMCID(NRSZA) .EQ. RSMC(NOVR)) THEN - NRSAPA=NRSZA - WRITE(6,3359) NOVR,RSMC(NOVR),NRSAPA - 3359 FORMAT('...FOR OVERLAP RECORD',I3,' RSMC AND INDEX ARE ',A,I4) - GO TO 3361 - ENDIF - ENDDO - 3361 CONTINUE - - IADRMS=1 - LNRSMC=INDEX(RSMCAL(1),' ')-1 - DO LENG=2,LNRSMC - WRITE(6,3377) LENG,RSMCAL(1)(LENG:LENG),RSMCAP(NRSAPA) - 3377 FORMAT('...TRYING TO MATCH RSMC ON ALIAS RECORD WITH OVERLAP ', - 1 'RECORD, LENG,RSMCAL,RSMCAP=',I3,2(1X,A)) - IF(RSMCAL(1)(LENG:LENG) .EQ. RSMCAP(NRSAPA)) THEN - IADRMS=0 - ENDIF - ENDDO - - IF(IADRMS .GT. 0) THEN - NADDRS=NADDRS+1 - RSMCAL(1)(LNRSMC+NADDRS:LNRSMC+NADDRS)=RSMCAP(NRSAPA) - STIDAL(NALMX+NADDRS)=STMID(NOVR) - RSMCAL(NALMX+NADDRS)=RSMC(NOVR) - WRITE(6,3391) NADDRS,NALMX+NADDRS,RSMCAL(1) - 3391 FORMAT('...ADDING RSMC, NADDRS,NALMX+NADDRS,RSMCAL(1)=', - 1 2I4,1X,A) - ENDIF - ENDDO - NOVRAD=NALMX+NADDRS - STMIDZ=STIDAL(1) - RSMCZ=RSMCAL(1) - ENDIF - -C WRITE A NEW RECORD TO THE ALIAS FILE IF THERE ISN'T AN EARLIER -C ONE IN THE NEW ALIAS FILE ALREADY - - IFND=0 - DO NADDZ=1,NALADD - IF(STNMAD(NADDZ) .EQ. STMNAM(NOVR) .OR. - 1 (STIDAD(NADDZ) .EQ. STIDAL(1) .AND. - 2 RSMCAD(NADDZ) .EQ. RSMCAL(1)) .AND. - 3 DAYZ .GE. DAYZAD(NADDZ)) THEN - IFND=1 - GO TO 3661 - ENDIF - ENDDO - 3661 CONTINUE - - IF(IFND .EQ. 0) THEN - WRITE(6,3401) NOVRAD,NADDRS,RSMCAL(1),STIDAL(1),(RSMCAL(NN), - 1 STIDAL(NN),NN=2,NOVRAD) - 3401 FORMAT('...READY TO ADD MODIFIED ALIAS RECORD: NOVRAD,NADDRS,', - 1 'PRIMARY RSMC,STORM ID=',2I4,2(1X,A),' SECONDARY ', - 2 'RSMC, ID:'/(10X,2(A,1X))) - NALADD=NALADD+1 - STNMAD(NALADD)=STMNAM(1) - STIDAD(NALADD)=STIDAL(1) - RSMCAD(NALADD)=RSMCAL(1) - DAYZAD(NALADD)=DAYZ - NAKA=MIN(NOVRAD,NOVRMX) - CALL AKASAV(NALADD,NAKA,DAYZ,STNMAD(NALADD),RSMCAL,STIDAL) - ENDIF - - ENDIF - -C CALCULATE AVERAGE LAT/LON, RMAX -C THEN SUBSTITUTE THE STORM ID, RSMC, LAT/LON, RMAX - - WRITE(6,362) (NO,STMLAT(NO),STMLON(NO),RMAX(NO),PCEN(NO), - 1 PENV(NO),NO=1,NOVRLP) - 362 FORMAT(/'...READY FOR AVERAGING OVER COTEMPORANEOUS STORMS. ', - 1 9X,'LAT',5X,'LON',4X,'RMAX',4X,'PCEN',4X,'PENV ARE:' - 2 /(54X,I3,5F8.1)) - - CALL WTAVRG(STMLAT,AVWT,NOVRLP,STMLTZ) - CALL WTAVRG(STMLON,AVWT,NOVRLP,STMLNZ) - CALL WTAVGP(RMAX,AVWT,NOVRLP,RMAXZ) - CALL WTAVGP(PCEN,AVWT,NOVRLP,PCENZ) - CALL WTAVGP(PENV,AVWT,NOVRLP,PENVZ) - IF(STMLTZ .GE. 0) THEN - LATNS='N' - ELSE - LATNS='S' - STMLTZ=ABS(STMLTZ) - ENDIF - IF(STMLNZ .GT. 180.) THEN - LONEW='W' - ELSE - LONEW='E' - ENDIF - WRITE(6,363) LATNS,LONEW,STMLTZ,STMLNZ,RMAXZ,PCENZ,PENVZ - 363 FORMAT('...AVERAGE STORM VALUES ARE:',2X,'(LATNS,LONEW=',2A2,')' - 1 /57X,5F8.1) - - IF(NVSBRS .NE. 0) THEN - - DO IVR=1,NVSBRS - IVSB=IVSBRS(IVR) - IVTVAR(IVSB)=NINT(VITVAR(IVSB)/VITFAC(IVSB)) - ENDDO - - ELSE - WRITE(6,3364) - 3364 FORMAT(' ###THESE AVERAGE VALUES WILL NOT BE SUBSTITUTED.') - ENDIF - - WRITE(6,365) STMIDZ,RSMCZ - 365 FORMAT(' ...SUBSTITUTING COMBINED STORM ID=',A,' AND RSMC=',A, - 1 ' INTO OVERLAP RECORDS.',/,4X,'AFTER SUBSTITUTION, ', - 2 'INDEX, INPUT RECORD#, RECORD ARE : (~~ INDICATES ', - 3 'RECORD FROM ORIGINAL SHORT-TERM HISTORY FILE)') - ICURR=0 - DO NOVR=1,NOVRLP -C WRITE(6,367) NOVR,STMIDZ,RSMCZ,OVRREC(NOVR) -C 367 FORMAT('...BEFORE SUBSTITUTION,NOVR,STMIDZ,RSMCZ,OVRREC=', -C 1 I3,2(1X,A)/4X,A,'...') - -C COUNT THE NUMBER OF CURRENT OVERLAPPING RECORDS - - IF(IOVRLP(NOVR) .LE. NTEST) THEN - ICURR=ICURR+1 - STHCH=' ' - ELSE - STHCH='~~' - ENDIF - - BUFINX=OVRREC(NOVR) - STMIDX=STMIDZ - RSMCX=RSMCZ - LATNSX=LATNS - LONEWX=LONEW - OVRREC(NOVR)=BUFINX - DO IVR=1,NVSBRS - IVSB=IVSBRS(IVR) - WRITE(OVRREC(NOVR)(ISTVAR(IVSB):IENVAR(IVSB)),FMTVIT(IVSB)) - 1 IVTVAR(IVSB) - OVRREC(NOVR)(ISTVAR(IVSB)-1:ISTVAR(IVSB)-1)='A' - ENDDO - WRITE(6,369) NOVR,IOVRLP(NOVR),STHCH,OVRREC(NOVR) - 369 FORMAT(' ...',2I3,'...',A,'...',A,'...') - ENDDO - -C FINAL ASSIGNMENT OF ERROR CODE: -C =21 IF ALL OVERLAPPING RECORDS ARE CURRENT -C =22 IF ONE OF THE OVERLAPPING RECORDS WAS FROM THE ORIGINAL -C SHORT TERM HISTORY FILE. IN THIS CASE ITS TOO LATE TO USE -C THE CURRENT RECORD ANYWAY. - - IF(ICURR .EQ. NOVRLP) THEN - IETYP=IETYP*10+1 - ELSE - IETYP=IETYP*10+2 - ENDIF - -C ONLY RECORDS FROM THE CURRENT TEST ARRAY CAN BE SPLIT INTO OKAY -C AND BAD RECORDS. - - DO NOVR=1,NOVRLP - IF(IOVRLP(NOVR) .LE. NTEST) THEN - IFRSMC(NUMTST(IOVRLP(NOVR)))=IETYP - NADD=NADD+1 - NUMBAD(NADD+NBAD)=NUMTST(IOVRLP(NOVR)) - BADREC(NADD+NBAD)=TSTREC(IOVRLP(NOVR)) - IF(IETYP .NE. 0 .AND. IPRIOR(NOVR)/10 .EQ. 1) THEN - NSUBR=NSUBR+1 - NOKAY=NOKAY+1 - NUMOKA(NOKAY)=NUMTST(IOVRLP(NOVR)) - OKAREC(NOKAY)=OVRREC(NOVR) - ENDIF - ENDIF - ENDDO - - GO TO 400 - ENDIF - -C OTHER ERROR PROCESSING - - 390 CONTINUE - - IFRSMC(NUMTST(NRECSV))=IETYP - IF(IETYP .GT. 0) THEN - NADD=NADD+1 - NUMBAD(NADD+NBAD)=NUMTST(NRECSV) - BADREC(NADD+NBAD)=TSTREC(NRECSV) - ELSE - NOKAY=NOKAY+1 - NUMOKA(NOKAY)=NUMTST(NRECSV) - OKAREC(NOKAY)=TSTREC(NRECSV) - ENDIF - - 400 CONTINUE - ENDDO - -C DUMP ALIAS RECORDS TO NEW ALIAS FILE - - CALL AKADMP(IUNTAN) - - WRITE(6,401) - 401 FORMAT(//'...BEGINNING RSMCCK PART II: UNIFY STORM ID ACROSS ALL', - 1 ' CURRENT AND HISTORICAL OCCURRENCES.') - -C COPY ALIAS FILE (AKAVIT) TO NEW ALIAS FILE. DON'T COPY RECORDS -C THAT ALREADY EXIST IN NEW ALIAS FILE. - - REWIND IUNTAL - CALL AKACPY(IUNTAL,IUNTAN) - -C CHECK ALL RECORDS IN THE ALIAS SHORT-TERM HISTORY FILE VERSUS -C RECORDS THAT ARE OK SO FAR. FIRST, COPY ALL OKAY RECORDS -C INTO WORKING SPACE. - - NCHECK=NOKAY+1 - REWIND IUNTHA - WRITE(6,503) - 503 FORMAT(/'...COPYING OKAY RECORDS TO OVRREC ARRAY: RECORD #, ', - 1 'RECORD=') - DO NOK=1,NOKAY - IOVRLP(NOK)=0 - OVRREC(NOK)=OKAREC(NOK) - WRITE(6,505) NOK,OVRREC(NOK) - 505 FORMAT('...',I3,'...',A,'...') - ENDDO - WRITE(6,511) NOKAY - 511 FORMAT('...',I3,' OKAY RECORDS HAVE BEEN COPIED.') - - WRITE(6,513) IUNTHA - 513 FORMAT(/'...READING FROM ALIAS SHORT-TERM HISTORY FILE (UNIT',I3, - 1 ') INTO OVRREC ARRAY: RECORD #, RECORD='/4X,A) - - 520 CONTINUE - - READ(IUNTHA,521,END=540) OVRREC(NCHECK) - 521 FORMAT(A) - -C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20 -C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR -C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF -C LATITUDE N/S INDICATOR TO FIND OUT ... - - IF(OVRREC(NCHECK)(35:35).EQ.'N' .OR. - 1 OVRREC(NCHECK)(35:35).EQ.'S') THEN - -C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR - -C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE -C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 2-digit year "',OVRREC(NCHECK)(20:21),'"' - PRINT *, ' ' - PRINT *, 'From unit ',iuntha,'; OVRREC(NCHECK)-3: ', - $ OVRREC(NCHECK) - PRINT *, ' ' - DUMY2K(1:19) = OVRREC(NCHECK)(1:19) - IF(OVRREC(NCHECK)(20:21).GT.'20') THEN - DUMY2K(20:21) = '19' - ELSE - DUMY2K(20:21) = '20' - ENDIF - DUMY2K(22:100) = OVRREC(NCHECK)(20:100) - OVRREC(NCHECK) = DUMY2K - PRINT *, ' ' - PRINT *, '==> 2-digit year converted to 4-digit year "', - $ OVRREC(NCHECK)(20:23),'" via windowing technique' - PRINT *, ' ' - PRINT *, 'From unit ',iuntha,'; OVRREC(NCHECK)-3: ', - $ OVRREC(NCHECK) - PRINT *, ' ' - - ELSE IF(OVRREC(NCHECK)(37:37).EQ.'N' .OR. - 1 OVRREC(NCHECK)(37:37).EQ.'S') THEN - -C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR -C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 4-digit year "',OVRREC(NCHECK)(20:23),'"' - PRINT *, ' ' - PRINT *, 'From unit ',iuntha,'; OVRREC(NCHECK)-3: ', - $ OVRREC(NCHECK) - PRINT *, ' ' - PRINT *, '==> No conversion necessary' - PRINT *, ' ' - - ELSE - - PRINT *, ' ' - PRINT *, '***** Cannot determine if this record contains ', - $ 'a 2-digit year or a 4-digit year - skip it and try reading ', - $ 'the next record' - PRINT *, ' ' - GO TO 520 - - END IF - - IOVRLP(NCHECK)=0 - WRITE(6,505) NCHECK,OVRREC(NCHECK) - NCHECK=NCHECK+1 - GO TO 520 - - 540 CONTINUE - NCHECK=NCHECK-1 - WRITE(6,541) NCHECK-NOKAY - 541 FORMAT('...',I3,' SHORT-TERM HISTORY RECORDS HAVE BEEN READ.') - - REWIND IUNTAL - NALADD=0 - DO NOK=1,NOKAY - -C DO ONLY RECORDS THAT HAVE NOT BEEN PROCESSED PREVIOUSLY - - IF(IOVRLP(NOK) .LT. 0) GO TO 700 - BUFINZ=OKAREC(NOK) - WRITE(6,543) NOK,STMNMZ,STMIDZ,RSMCZ - 543 FORMAT(//'...READY TO CHECK OKAY RECORD',I3,' WITH STMNAM,ID,', - 1 'RSMC=',3(1X,A)) - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 BUFINZ) - ENDDO - CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYZ) - - IBANG=0 - NSAME=1 - STMID(NSAME)=STMIDZ - STMNAM(NSAME)=STMNMZ - RSMC (NSAME)=RSMCZ - IOVRLP(NOK)=-NOK - INDSAM(NSAME)=NOK - IDATE(NSAME)=IDATEZ - IUTC(NSAME)=IUTCZ - IDASRT(NSAME)=NSAME - SRTDAY(NSAME)=DAYZ - IF(RSMC(NSAME)(1:1) .EQ. '!') IBANG=NSAME - -C LOOK IN THE ALIAS FILE TO SEE IF THIS STORM HAS BEEN ALIASED -C BEFORE. - - NALSAV=NOVRMX - CALL AKAFND(IUNTAN,STMNMZ,RSMCZ,STMIDZ,NALSAV,STNMAL,RSMCAL, - 1 STIDAL,IFNDAL) - - IF(IFNDAL .NE. 0) THEN - NALMX=NALSAV - WRITE(6,557) STMNMZ,STMIDZ,NALMX - 557 FORMAT('...STORM NAME,ID=',2(1X,A),' HAS BEEN ASSIGNED AN ALIAS ', - 1 'NAME PREVIOUSLY.',I3,' ALIASES EXIST.') - ELSE - NALMX=1 - WRITE(6,559) STMNMZ - 559 FORMAT('...STORM ',A,' CANNOT BE FOUND IN THE ALIAS FILE.') - ENDIF - -C ACCUMULATE ALL OBSERVATIONAL REPORTS FOR THIS STORM. - - DO NCK=NOK+1,NCHECK - IF(IOVRLP(NCK) .GE. 0) THEN - IFNDX=0 - BUFINX=OVRREC(NCK) - -C NO MATCH FOR BOTH STORMS THAT ARE NAMED. - - IF(STMNMZ .NE. 'NAMELESS' .AND. STMNMX .NE. 'NAMELESS') THEN - IF(STMNMX .EQ. STMNMZ) then - if(STMIDX(3:3) .EQ. STMIDZ(3:3)) then - IFNDX=1 - else - icmat=0 - do nc=1,ncrdmx - if(stmnmx .eq. cardnm(nc)) icmat=1 - enddo - if(icmat .eq. 0) ifndx=1 - endif - endif - -C POSSIBLE MATCH REMAINS: MATCH STORM ID FOR THE SAME RSMC. IF -C STORM WAS IN ALIAS FILE, TRY TO MATCH ANY OF ITS ALIASES. IF -C STORM WAS NOT IN ALIAS FILE, TRY TO MATCH STORM ID AND RSMC. -C WARNING: THIS IS NOT A COMPLETE TEST!!! - - ELSE - IF(IFNDAL .NE. 0) THEN - - DO NAL=1,NALMX - IF(RSMCX .EQ. RSMCAL(NAL) .AND. STMIDX .EQ. STIDAL(NAL)) THEN - IFNDX=1 - GO TO 561 - ENDIF - ENDDO - - ELSE - IF(RSMCX .EQ. RSMCZ .AND. STMIDX .EQ. STMIDZ) THEN - IFNDX=1 - GO TO 561 - ENDIF - - ENDIF - - 561 CONTINUE - ENDIF - -C CONTINUE PROCESSING IF SAME STORM HAS BEEN FOUND. - - IF(IFNDX .NE. 0) THEN - - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV), - 1 BUFINX) - ENDDO - CALL ZTIME(IDATEX,IUTCX,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYX) - -C CHECK FOR RECORDS THAT HAVE THE SAME DATE/TIME - - DO NSZ=1,NSAME - IF(ABS(DAYX-SRTDAY(NSZ)) .LT. FIVMIN) THEN - WRITE(6,567) NSZ,INDSAM(NSZ),BUFINX - 567 FORMAT('###RECORD HAS SAME DATE/TIME AS RECORD #',I3,' WHICH ', - 1 'IS INDEX#',I3,'. IT WILL NOT BE SAVED.',/,4X,A) - IOVRLP(NCK)=-999 - GO TO 570 - ENDIF - ENDDO - - NSAME=NSAME+1 - IDATE(NSAME)=IDATEX - IUTC(NSAME)=IUTCX - IOVRLP(NCK)=-NCK - INDSAM(NSAME)=NCK - STMID(NSAME)=STMIDX - STMNAM(NSAME)=STMNMX - RSMC (NSAME)=RSMCX - IDASRT(NSAME)=NSAME - SRTDAY(NSAME)=DAYX - IF(RSMC(NSAME)(1:1) .EQ. '!') IBANG=NSAME - - ENDIF - ENDIF - 570 CONTINUE - ENDDO - - WRITE(6,571) NSAME-1,STMNMZ,STMIDZ,(INDSAM(NS),NS=2,NSAME) - 571 FORMAT(/'...',I3,' MATCHING STORMS WERE FOUND FOR ',A,' WITH ', - 1 'ID=',A,' BY NAME OR STORM ID MATCHING. INDICES OF ', - 2 'MATCHING STORMS ARE:'/(4X,30I4)) - -C FINAL CHECK: FIND THE CLOSEST STORMS TO EACH OF THE STORMS -C THAT WERE DETERMINED TO BE THE SAME USING THE ABOVE PROCEDURE. -C COMPARE POSITIONS EXTRAPOLATED TO THE COMMON TIMES. - - NSVSAM=NSAME - DO NS=1,NSVSAM - ISAME=0 - DISTMN=1.E10 - -C RECOVER DATE, UTC, LAT/LON, STORM MOTION FOR SUBJECT STORM - - BUFINZ=OVRREC(INDSAM(NS)) - - DO IV=1,9 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 BUFINZ) - VITVAR(IV)=REAL(IVTVAR(IV))*VITFAC(IV) - ENDDO - IF(LATNS .EQ. 'S') STMLTZ=-STMLTZ - IF(LONEW .EQ. 'W') STMLNZ=360.-STMLNZ - DAYZ=SRTDAY(NS) - WRITE(6,1521) NS,NCHECK,STMNMZ,STMIDZ,IDATEZ,IUTCZ,STMLTZ, - 1 STMLNZ,STMDRZ,STMSPZ,DAYZ,RMAXZ - 1521 FORMAT(/'...BEGINNING PROXIMITY CHECK WITH INDEX=',I3,' AND ', - 1 'NUMBER OF STORMS TO COMPARE=',I3/4X,'STORM=',A,'WITH ID', - 2 '=',A,'. IDATEZ,IUTCZ,STMLTZ,STMLNZ,STMDRZ,STMSPZ,DAYZ,', - 3 'RMAXZ='/3X,I9,I5,6F12.3) - - DO 1580 NCK=1,NCHECK - -C PICK ONLY STORMS THAT HAVEN'T YET BEEN RECOGNIZED AS BEING THE -C SAME AND THAT ARE NOT THEMSELVES. - - IF(IOVRLP(NCK) .LT. 0 .OR. NCK .EQ. INDSAM(NS)) GO TO 1580 - -C RECOVER DATE, UTC, LAT/LON, STORM MOTION AND RMAX FOR COMPARISON -C STORM - - BUFINX=OVRREC(NCK) - DO IV=1,9 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV), - 1 BUFINX) - VITVRX(IV)=REAL(IVTVRX(IV))*VITFAC(IV) - ENDDO - IF(LATNSX .EQ. 'S') STMLTX=-STMLTX - IF(LONEWX .EQ. 'W') STMLNX=360.-STMLNX - CALL ZTIME(IDATEX,IUTCX,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYX) - -C PICK ONLY STORMS THAT ARE NOT COTEMPORANEOUS. - - IF(ABS(DAYX-SRTDAY(NS)) .LT. FIVMIN) THEN -C WRITE(6,1553) NCK,INDSAM(NS) -C1553 FORMAT('###RECORD ',I3,' HAS SAME DATE/TIME AS RECORD #',I3,'. ', -C 1 'IT SHOULD HAVE BEEN TREATED BY THE COTEMPORANEOUS CHECK.') - GO TO 1580 - ENDIF - - IF(STMNMZ .NE. 'NAMELESS' .AND. STMNMX .NE. 'NAMELESS') THEN -C WRITE(6,1557) NCK,INDSAM(NS) -C1557 FORMAT('###RECORDS ',I3,' AND',I3,' BOTH HAVE NAMES. THEY ', -C 1 'SHOULD HAVE BEEN TREATED BY THE PREVIOUS MATCHING CHECK.') - GO TO 1580 - ENDIF - -C CAN THEY CAN BE DEFINITIVELY PROVEN NOT TO BE THE SAME STORM? -C IF THEY ARE BOTH BANG STORMS OR BOTH NOT BANG STORMS, THE RSMCS -C AND STORMS IDS CAN BE COMPARED DIRECTLY. OTHERWISE, WE MUST LOOK -C IN THE ALIAS FILE TO SEE IF THE SAME RSMC HAS OBSERVED EACH. - - IF(RSMCZ .EQ. RSMCX .AND. STMIDZ .NE. STMIDX) THEN -C WRITE(6,2551) RSMCZ,STMIDZ,STMIDX -C2551 FORMAT('...DIRECT COMPARISON OF STORM IDS FOR THE SAME RSMC ', -C 1 'GIVES UNAMBIGUOUSLY DIFFERENT STORMS, RSMC,STORM IDS=', -C 2 3(A,1X)) - GO TO 1580 - ENDIF - -C LOOK IN THE ALIAS FILE - - IFNDOV=0 - IRECOV=0 - REWIND IUNTAN - 2552 READ(IUNTAN,261,END=2560) NALOV,STNMOV,(RSMCOV(NAL),STIDOV(NAL), - 1 NAL=1,NALOV) - IRECOV=IRECOV+1 - - DO NALX=1,NALOV - IF((RSMCX(1:1) .EQ. '!' .AND. STMIDX .EQ. STIDOV(NALX)) .OR. - 1 (RSMCX(1:1) .NE. '!' .AND. - 2 RSMCX .EQ. RSMCOV(NALX) .AND. STMIDX .EQ. STIDOV(NALX))) THEN - IFNDOV=1 - DO NALZ=2,NALOV - IF(RSMCZ .EQ. RSMCOV(NALZ) .AND. STMIDZ .NE. STIDOV(NALZ)) THEN -C WRITE(6,2553) IRECOV,RSMCX,STMIDX,NALZ,RSMCOV(NALZ),STIDOV(NALZ) -C 1 STMIDZ -C 2553 FORMAT('###ALIAS RECORD',I3,' MATCHES POTENTIAL OVERLAPPING ', -C 1 'STORM WITH RSMC,ID=',2(A,1X,)/4X,'BUT FOR ALIAS #',I3, -C 2 ' RSMC=',A,' IS THE SAME BUT STORM IDS=',2(A,1X),' ARE ', -C 3 'DIFFERENT.') - GO TO 1580 - ENDIF - ENDDO - ENDIF - ENDDO - GO TO 2552 - - 2560 CONTINUE - - IF(IFNDOV .EQ. 0 .AND. RSMCX(1:1) .EQ. '!') THEN - WRITE(6,2561) STMNMX,RSMCX,STMIDX - 2561 FORMAT('...STORM ',A,' WITH RSMC AND ID=',2(A,1X),' WAS NOT ', - 1 'FOUND IN THE ALIAS FILE. ABORT1') - CALL ABORT1(' RSMCCK',2561) - ENDIF - - ISAME=ISAME+1 - DISTZX=DISTSP(STMLTZ,STMLNZ,STMLTX,STMLNX)*1.E-3 - -C WRITE(6,1571) STMNMX,STMIDX,NCK,IDATEX,IUTCX,STMLTX,STMLNX, -C 1 STMDRX,STMSPX,DAYX,DISTZX,RMAXX -C1571 FORMAT('...BEGINNING COMPARISON WITH STORM=',A,'WITH ID=',A,'. ', -C 1 'INDEX,IDATEX,IUTCX,STMLTX,STMLNX,STMDRX,STMSPX,DAYX,', -C 2 'DISTZX,RMAXX='/4X,I3,I10,I5,7F12.3) - IF(DISTZX .LT. DISTMN) THEN - DISTMN=DISTZX - NCLOSE=NCK - DAYSAV=DAYX - IUTCSV=IUTCX - IDATSV=IDATEX - STLTSV=STMLTX - STLNSV=STMLNX - STDRSV=STMDRX - STSPSV=STMSPX - RMAXSV=RMAXX - ENDIF - 1580 CONTINUE - - IF(ISAME .GT. 0) THEN - WRITE(6,1581) NS,NCLOSE,DISTMN,OVRREC(INDSAM(NS)),OVRREC(NCLOSE) - 1581 FORMAT(/'...FOR NS=',I3,', CLOSEST STORM IS INDEX=',I3,' WITH ', - 1 'DISTANCE=',F8.1,' KM. RECORDS ARE:'/4X,'Z...',A/4X, - 2 'X...',A/) - - BUFINX=OVRREC(NCLOSE) - - IF(RMAXZ .LT. 0.0) THEN - DO NBA=1,NBASIN - IF(STMIDZ(3:3) .EQ. IDBASN(NBA)) THEN - IBASN=NBA - GO TO 1546 - ENDIF - ENDDO - 1546 CONTINUE - RMAXZ=TCCLIM(9,IBASN) - WRITE(6,1583) NREC,RMAXZ,NABASN(IBASN) - 1583 FORMAT('###RMAXZ MISSING FOR PROXIMITY CHECK ON RECORD',I3,'.'/4X, - 1 'REPLACEMENT VALUE WILL BE A CLIMATOLOGICAL GUESS OF ', - 2 F6.1,' KM FOR BASIN ',A,'.') - ENDIF - - IF(RMAXSV .LT. 0.0) THEN - DO NBA=1,NBASIN - IF(STMIDX(3:3) .EQ. IDBASN(NBA)) THEN - IBASN=NBA - GO TO 1556 - ENDIF - ENDDO - 1556 CONTINUE - RMAXSV=TCCLIM(9,IBASN) - WRITE(6,1584) NREC,RMAXSV,NABASN(IBASN) - 1584 FORMAT('###RMAXSV MISSING FOR PROXIMITY CHECK ON RECORD',I3,'. ', - 1 'REPLACEMENT VALUE WILL BE A CLIMATOLOGICAL GUESS '/4X, - 2 'OF ',F6.1,' KM FOR BASIN ',A,'.') - ENDIF - - DTXZ=DAYSAV-DAYZ - DSTFAC=DTXZ*FACSPD - CALL DS2UV(USTMZ,VSTMZ,STMDRZ,STMSPZ) - CALL DS2UV(USTMX,VSTMX,STDRSV,STSPSV) - EXTLTZ=STMLTZ+VSTMZ*DSTFAC - EXTLNZ=STMLNZ+USTMZ*DSTFAC/COSD(EXTLTZ) - EXTLTX=STLTSV-VSTMX*DSTFAC - EXTLNX=STLNSV-USTMX*DSTFAC/COSD(EXTLTX) - DSTX2Z=DISTSP(STMLTZ,STMLNZ,EXTLTX,EXTLNX)*1.E-3 - DSTZ2X=DISTSP(STLTSV,STLNSV,EXTLTZ,EXTLNZ)*1.E-3 - -C LAST CRITERION FOR FINDING THE SAME STORM IS DISTANCE - - DSTOLP=RMAXZ+RMAXSV - IF(DSTZ2X .GE. DSTOLP .OR. DSTX2Z .GE. DSTOLP) THEN -C WRITE(6,1585) -C1585 FORMAT(/'...STORMS ARE NOT CONSIDERED THE SAME SINCE NO ', -C 1 'OVERLAPPING IS PRESENT AT A COMMON EXTRAPOLATED TIME.') - - ELSE - WRITE(6,1587) DAYZ,DAYX,DTXZ,DISTMN,STMNMZ,STMIDZ,STMLTZ,EXTLTZ, - 1 STMLNZ,EXTLNZ,DSTZ2X,RMAXZ,STMNMX,STMIDX,STLTSV, - 2 EXTLTX,STLNSV,EXTLNX,DSTX2Z,RMAXSV - 1587 FORMAT(/'...EXTRAPOLATION TABLE TO COMMON TIMES: DAYX,DAYZ,DTXZ', - 1 ',DISTMN=',4F12.3/20X,'SUBJECT (Z) STORM & ID',6X, - 2 'T=0LAT',6X,'T=XLAT',6X,'T=0LON',6X,'T=XLON',2X, - 3 'DISTANCE TO X',3X,'RMAXZ'/2(25X,A,2X,A,3X,6F12.3/),20X, - 4 'COMPARISON (X) STORM & ID',3X, - 5 'T=0LAT',6X,'T=ZLAT',6X,'T=0LON',6X,'T=ZLON',2X, - 6 'DISTANCE TO Z',3X,'RMAXX') - WRITE(6,1589) - 1589 FORMAT(/'###STORMS ARE OVERLAPPED AT A COMMON EXTRAPOLATED TIME.', - 1 ' THEY ARE ASSUMED TO BE THE SAME.###') - - BUFINX=OVRREC(NCLOSE) - NSAME=NSAME+1 - IDATE(NSAME)=IDATSV - IUTC(NSAME)=IUTCSV - IOVRLP(NCLOSE)=-NCLOSE - INDSAM(NSAME)=NCLOSE - STMID(NSAME)=STMIDX - STMNAM(NSAME)=STMNMX - RSMC (NSAME)=RSMCX - IDASRT(NSAME)=NSAME - SRTDAY(NSAME)=DAYSAV - IF(RSMC(NSAME)(1:1) .EQ. '!') IBANG=NSAME - - ENDIF - ENDIF - ENDDO - -C PROCESS ALL RECORDS FOR THE SAME STORM - - IF(NSAME .GT. 1) THEN - BUFINZ=OKAREC(NOK) - WRITE(6,577) NSAME,STMNMZ,STMIDZ,(NS,IDATE(NS),IUTC(NS), - 1 RSMC(NS),STMID(NS),STMNAM(NS),NS=1,NSAME) - 577 FORMAT('...',I3,' RECORDS APPEAR TO BE THE SAME STORM WITH NAME,', - 1 ' ID=',2(1X,A),' AND MUST BE UNIFIED.'/10X,' DATE ', - 2 'UTC RSMC STMID NAME ARE:'/(4X,I3,I10,2X,I5,2X,2(3X, - 3 A),4X,A)) - -c Sort the records by time - - CALL SORTRL(SRTDAY(1:NSAME),IDASRT(1:NSAME),NSAME) - -C LOOK IN THE ALIAS FILE TO SEE WHICH STORM ALIASES CORRESPOND -C TO THE BANG STORM. - - IF(IBANG .NE. 0) THEN - STMIDX=STMID(IBANG) - STMNMX=STMNAM(IBANG) - RSMCX=RSMC (IBANG) - - REWIND IUNTAN - NRECAL=0 - 552 READ(IUNTAN,261,END=555) NALMX,STNMAL,(RSMCAL(NAL),STIDAL(NAL), - 1 NAL=1,NALMX) - NRECAL=NRECAL+1 - -C NO MATCH FOR BOTH STORMS THAT ARE NAMED. - - IF(STMNMX .NE. 'NAMELESS' .AND. - 1 STNMAL .NE. 'NAMELESS' .AND. - 2 STNMAL .NE. STMNMX) GO TO 552 - -C POSSIBLE MATCH REMAINS: MATCH STORM ID ONLY IN THIS CASE SINCE -C THEY ARE BOTH BANG STORMS. - - DO NAL=1,NALMX - IF(STMIDX .EQ. STIDAL(NAL)) THEN - IFNDAL=NRECAL - GO TO 555 - ENDIF - ENDDO - GO TO 552 - - 555 CONTINUE - - IF(IFNDAL .EQ. 0) THEN - WRITE(6,5571) IBANG,STMNMX,RSMCX,STMIDX - 5571 FORMAT('******BANG STORM WITH INDEX=',I3,', NAME,RSMC,ID=', - 1 3(A,1X),' CANNOT BE FOUND IN THE ALIAS FILE. ABORT1') - CALL ABORT1(' RSMCCK',5571) - - ELSE - WRITE(6,5573) IBANG,STMNMX,RSMCX,STMIDX,IFNDAL - 5573 FORMAT('...BANG STORM WITH INDEX=',I3,', NAME,RSMC,ID=',3(A,1X), - 1 ' WAS FOUND AS RECORD#',I4,' IN THE ALIAS FILE. ') - ENDIF - ENDIF - -C LOOK FOR ALL THE RSMCS THAT HAVE OBSERVED THIS STORM SO FAR - - NRSMC=NALMX-1 - NALMXZ=NALMX - -C LOAD RSMCS FROM THE ALIAS FILE, IF ANY - - DO NRS=2,NALMX - DO NRSZ=1,NRSMCX - IF(RSMCAL(NRS) .EQ. RSMCID(NRSZ)) THEN - NRSMCF=NRSZ - ENDIF - ENDDO - IRSMC(NRS-1)=NRSMCF - WRITE(6,6633) NRS-1,RSMCID(NRSMCF) - 6633 FORMAT('...STORING ALIAS #',I3,' WHICH IS ',A) - ENDDO - - DO NS=1,NSAME - - IF(RSMC(NS) (1:1) .EQ. '!') THEN - NPS=2 - NPE=4 - ELSE - NPS=1 - NPE=1 - ENDIF - - DO NP=NPS,NPE - -C COMBINED RSMC CASE - - IF(RSMC(NS) (1:1) .EQ. '!') THEN - DO NRSZ=1,NRSMCX - IF(RSMC(NS)(NP:NP) .EQ. RSMCAP(NRSZ)) THEN - NRSMCF=NRSZ - GO TO 591 - ENDIF - ENDDO - -C INDIVIDUAL RSMC CASE - - ELSE - DO NRSZ=1,NRSMCX - IF(RSMC(NS) .EQ. RSMCID(NRSZ)) THEN - NRSMCF=NRSZ - GO TO 591 - ENDIF - ENDDO - ENDIF - 591 CONTINUE - - - ISAV=0 - DO NRSMS=1,NRSMC - IF(IRSMC(NRSMS) .EQ. NRSMCF) ISAV=ISAV+1 - ENDDO - - IF(ISAV .EQ. 0) THEN - NRSMC=NRSMC+1 - IRSMC(NRSMC)=NRSMCF - -C STORE A NEW RSMC IF NECESSARY. - - IADDAL=0 - DO NAL=2,NALMXZ - IF(RSMCAL(NAL) .EQ. RSMCID(NRSMCF)) IADDAL=IADDAL+1 -C WRITE(6,6441) NAL,RSMCAL(NAL),RSMCID(NRSMCF),IADDAL -C6441 FORMAT('...DEBUGGING, NAL,RSMCAL(NAL),RSMCID(NRSMCF),IADDAL=', -C 1 I3,2(1X,A),I3) - ENDDO - - IF(IADDAL .EQ. 0) THEN - WRITE(6,641) RSMCID(NRSMCF),STMID(NS) - 641 FORMAT('...THE LIST OF OBSERVERS WILL INCLUDE RSMC=',A,' FOR ', - 1 'STORM ID=',A) - NALMXZ=NALMXZ+1 - STIDAL(NALMXZ)=STMID(NS) - RSMCAL(NALMXZ)=RSMCID(NRSMCF) - - ELSE - WRITE(6,643) RSMCID(NRSMCF),STMNMZ - 643 FORMAT('...RSMC=',A,' IS ALREADY IN THE LIST OF OBSERVERS FOR ',A) - ENDIF - - ENDIF - - ENDDO - ENDDO - WRITE(6,651) STMNMZ,STMIDZ,NRSMC,(RSMCID(IRSMC(NRS)),NRS=1,NRSMC) - 651 FORMAT(/'...SUMMARY OF ALL OBSERVING RSMCS FOR STORM WITH NAME,', - 1 'ID=',2(1X,A),'. NUMBER OF RSMCS=',I3/4X,10(A,2X)) - -C IF MORE THAN ONE RSMC HAS OBSERVED STORM, UNIFY THE STORM ID -C AND RSMC IF ANY NEW RSMCS HAVE BEEN ADDED. - - IF(NRSMC .GT. 1 .OR. IFNDAL .NE. 0) THEN - - IF(NALMX .EQ. NALMXZ) THEN - -C NO NEW RSMC NEED BE ADDED. COPY STORM ID AND RSMC FROM A BANG -C RECORD. - - IRITAL=0 - - IF(IFNDAL .NE. 0) THEN - WRITE(6,6653) STMNMZ,STMIDZ,STNMAL,STIDAL(1),RSMCAL(1) - 6653 FORMAT(/'...STORM WITH NAME, ID=',2(1X,A),' WAS FOUND IN ALIAS ', - 1 'FILE WITH NAME=',A,'. ID,RSMC=',2(A,1X)) - STMIDZ=STIDAL(1) - RSMCZ=RSMCAL(1) - STMNMZ=STNMAL - - ELSE IF(IBANG .NE. 0) THEN - WRITE(6,653) - 653 FORMAT('...STORM NOT FOUND IN ALIAS FILE AND NO NEW RSMC HAS ', - 1 'BEEN ADDED. STORE RSMC AND STORM ID FROM A BANG RECORD.') - STMIDZ=STMID(IBANG) - RSMCZ=RSMC(IBANG) - - ELSE - WRITE(6,655) STMNMZ,STMIDZ - 655 FORMAT(/'******STORM WITH NAME, ID=',2(1X,A),' IS NOT LISTED AS ', - 1 'A BANG STORM, CANNOT BE FOUND IN THE ALIAS FILE,'/7X, - 2 'HAS MORE THAN ONE RSMC BUT NONE ARE TO BE ADDED. ABORT1') - CALL ABORT1(' RSMCCK',655) - ENDIF - - ELSE - -C ADD A NEW RSMC. COPY RSMC FROM THE BANG STORM RECORD. THEN ADD -C NEW RSMCS. IF THERE IS NO BANG RECORD, MAKE UP A NEW RSMC -C AND STORM ID BASED ON THE EARLIEST RECORD. - - IRITAL=1 - - NWRSMC=NALMXZ-NALMX - WRITE(6,6657) NWRSMC - 6657 FORMAT('...',I3,' NEW RSMCS WILL BE ADDED.') - -c Mark a relocation flag for the record in which a new -c rsmc has observed storm - - do ns=2,nsame - if(rsmc(idasrt(ns)) .ne. rsmc(idasrt(1))) then - write(6,6679) ns,idasrt(1),rsmc(idasrt(1)),idasrt(ns), - 1 rsmc(idasrt(ns)),nsame - 6679 format('...For ns=',i3,' a new observing rsmc has been detected.', - 1 ' Index,rsmc (first,new)=',2(i3,1x,a)/4x,'Total number ', - 2 'of observed records=',i3,' We insert a relocation flag ', - 3 'in the new record.') - bufinx=ovrrec(indsam(idasrt(ns))) - relocx='R' - ovrrec(indsam(idasrt(ns)))=bufinx - write(6,5509) indsam(idasrt(ns)),bufinx - 5509 format('...Record index and corrected record are:',i3/4x,a) - endif - enddo - - IF(IBANG .NE. 0) THEN - STMIDZ=STMID(IBANG) - RSMCZ=RSMC(IBANG) - LNRSMC=INDEX(RSMCZ,' ')-1 - WRITE(6,657) LNRSMC - 657 FORMAT('...BANG STORM EXISTS: STORE RSMC AND STORM ID FROM A ', - 1 'BANG RECORD, LENGTH IS:',I2) - - NWSLOT=0 - DO NAD=1,NWRSMC - NWSLOT=NWSLOT+1 - - IF(LNRSMC+NWSLOT .LE. 4) THEN - DO NRSZ=1,NRSMCX - IF(RSMCAL(NALMX+NAD) .EQ. RSMCID(NRSZ)) THEN -c write(6,6541) nad,nalmx,nwslot,lnrsmc+nwslot,nrsz, -c 1 rsmcal(nalmx+nad),rsmcid(nrsz) -c6541 format('...debugging, nad,nalmx,nwslot,lnrsmc+nwslot,nrsz,', -c 1 'rsmcal(nalmx+nad),rsmcid(nrsz)'/4x,5i4,2(1x,a)) - NRSMCF=NRSZ - GO TO 6561 - ENDIF - ENDDO - 6561 CONTINUE - RSMCZ(LNRSMC+NWSLOT:LNRSMC+NWSLOT)=RSMCAP(NRSMCF) - WRITE(6,6563) RSMCAP(NRSMCF),RSMCZ - 6563 FORMAT('...ADDING RSMC=',A,' TO AN ALREADY DEFINED BANG STORM ', - 1 'RSMC. UPDATED RSMC=',A) - - ELSE - WRITE(6,6567) NWSLOT,LNRSMC,NWRSMC - 6567 FORMAT('###INSUFFICIENT SPACE TO ADD NEW RSMC, NWSLOT,LNRSMC,', - 1 'NWRSMC=',3I3) - ENDIF - ENDDO - - ELSE - -C IN THIS CASE, NO OBSERVERS ARE BANG RECORDS AND THE STORM IS -C NOT IN THE ALIAS FILE. AN ALIAS RECORD MUST BE CREATED AND -C WRITTEN TO THE ALIAS FILE - - WRITE(6,659) IDASRT(1),STMID(IDASRT(1)),STMNAM(IDASRT(1)) - 659 FORMAT(/'...NO BANG STORMS EXIST. EARLIEST RECORD IS:',I3, - 1 '. STORM ID IS: ',A,' STORM NAME IS: ',A) - -C SUBSTITUTE THE ID OF THE FIRST OBSERVING RSMC AND CONSTRUCT -C A UNIFIED RSMC. SUBSTITUTE STORM NAME IF FIRST OBSERVATION -C DOES NOT HAVE NAMELESS AS A STORM NAME. - - RSMCZ=RSMC(IDASRT(1)) - STMIDZ=STMID(IDASRT(1)) - STMNMZ=STMNAM(IDASRT(1)) - -C FIRST TWO RSMC SLOTS - - IF(RSMCZ(1:1) .EQ. '!') THEN - WRITE(6,663) RSMC(IDASRT(1))(1:2) - 663 FORMAT('...THIS RECORD IS A MULTIPLY OBSERVED STORM. COPY THE ', - 1 'RSMCAP AND BANG FROM THIS RECORD=',A) - RSMCZ(1:2)=RSMC(IDASRT(1))(1:2) - DO NRSZ=1,NRSMCX - IF(RSMC(IDASRT(1))(2:2) .EQ. RSMCAP(NRSZ)) THEN - NRSST=NRSZ - GO TO 661 - ENDIF - ENDDO - 661 CONTINUE - - ELSE - WRITE(6,667) - 667 FORMAT('...THIS RECORD IS A SINGLY OBSERVED STORM. COPY THE ', - 1 'RSMC FROM THIS RECORD.') - RSMCZ(1:1)='!' - DO NRSZ=1,NRSMCX - IF(RSMC(IDASRT(1)) .EQ. RSMCID(NRSZ)) THEN - NRSST=NRSZ - GO TO 671 - ENDIF - ENDDO - 671 CONTINUE - RSMCZ(2:2)=RSMCAP(NRSST) - ENDIF - -C REMAINING RSMC SLOTS - - NID=2 - RSMCZ(3:4)=' ' - DO NRS=1,NRSMC - IF(RSMCID(IRSMC(NRS)) .NE. RSMCID(NRSST)) THEN - NID=NID+1 - IF(NID .GT. 4) GO TO 680 - RSMCZ(NID:NID)=RSMCAP(IRSMC(NRS)) - WRITE(6,679) RSMCAP(IRSMC(NRS)),IRSMC(NRS),NID,RSMCZ - 679 FORMAT('...ADDING RSMCAP ',A,' FOR RSMC ',I2,' IN SLOT ',I3, - 1 ' RSMCZ=',A) - ENDIF - 680 CONTINUE - ENDDO - - ENDIF - - ENDIF - -C HAS THE STORM BEEN NAMED BY SOMEONE OVER ITS HISTORY? IF SO, -C SUBSTITUTE THE NAME FOR THE ALIAS FILE. - - IF(STMNMZ .EQ. 'NAMELESS') THEN - DO NS=1,NSAME - IF(STMNAM(NS) .NE. 'NAMELESS') THEN - STMNMZ=STMNAM(NS) - WRITE(6,6689) STMNAM(NS),NS - 6689 FORMAT('###STORM NAMELESS WILL BE RENAMED ',A,' IN THE ALIAS ', - 1 'FILE. INDEX OF NAMED STORM=',I3) - IRITAL=1 - GO TO 6691 - ENDIF - ENDDO - 6691 CONTINUE - ENDIF - -C IF NECESSARY, WRITE ALIAS RECORD AND SUBSTITUTE UNIFIED RSMC AND -C STORM ID. - - IF(IRITAL .EQ. 1) THEN - WRITE(6,681) STMNMZ,STMIDZ,RSMCZ - 681 FORMAT(/'...WRITING A UNIFIED ALIAS RECORD FOR STORM NAME=',A, - 1 '. STORM ID AND UNIFIED RSMC ARE:',2(1X,A)) - NALADD=NALADD+1 - STIDAL(1)=STMIDZ - RSMCAL(1)=RSMCZ - DAYZ=-999.0 - CALL AKASAV(NALADD,NALMXZ,DAYZ,STMNMZ,RSMCAL,STIDAL) - ENDIF - - DO NS=1,NSAME - BUFINX=OVRREC(INDSAM(NS)) -C WRITE(6,683) NS,INDSAM(NS),BUFINX -C 683 FORMAT('...SUBSTITUTING UNIFIED RSMC AND STMID. NS,INDSAM,RECORD', -C 1 ' ARE:',2I3/' ...',A) - STMIDX=STMIDZ - RSMCX=RSMCZ - OVRREC(INDSAM(NS))=BUFINX -C WRITE(6,683) NS,INDSAM(NS),BUFINX - ENDDO - - ELSE - WRITE(6,693) - 693 FORMAT(/'...ONLY 1 RSMC HAS OBSERVED STORM. THERE IS NO NEED TO', - 1 ' UNIFY THE RSMC AND STORM ID IF STORM IDS ARE THE SAME.' - 2 /4X,'WE PROCEED TO CHECK STORM ID CONSISTENCY.') - - ISAME=0 - DO NS=2,NSAME - IF(STMID(NS) .NE. STMIDZ) THEN - IF(ABS(SRTDAY(NS)-SRTDAY(1)) .LE. DTOVR) THEN - ISAME=ISAME+1 - IETYP=6 - WRITE(6,1683) DTOVR,INDSAM(NS),INDSAM(1),STMID(NS),STMIDZ, - 1 STMNAM(NS),STMNMZ,SRTDAY(NS),SRTDAY(1), - 2 OVRREC(INDSAM(NS)),OVRREC(INDSAM(1)) - 1683 FORMAT(/'###TWO STORMS OBSERVED BY THE SAME RSMC WITH TIMES ', - 1 'DIFFERING BY LESS THAN ',F5.1,' DAYS AND DIFFERENT ', - 2 'STORM ID.'/4X,'THESE ARE PROBABLY THE SAME STORM. IN ', - 3 'ORDER (NS,1), INDEX, STORM ID, STORM NAME, DAY AND ', - 4 'RECORD ARE:'/10X,2I5,4(2X,A),2F12.3/2(4X,A/)) - ELSE - WRITE(6,1687) DTOVR,INDSAM(NS),INDSAM(1),STMID(NS),STMIDZ, - 1 STMNAM(NS),STMNMZ,SRTDAY(NS),SRTDAY(1), - 2 OVRREC(INDSAM(NS)),OVRREC(INDSAM(1)) - 1687 FORMAT(/'###TWO STORMS OBSERVED BY THE SAME RSMC WITH TIMES ', - 1 'DIFFERING BY MORE THAN ',F5.1,' DAYS AND DIFFERENT ', - 2 'STORM ID.'/4X,'THESE ARE PROBABLY NOT THE SAME STORM.', - 3 ' IN ORDER (NS,1), INDEX, STORM ID, STORM NAME, DAY ', - 4 'AND RECORD ARE:'/10X,2I5,4(2X,A),2F12.3/2(4X,A/)) - ENDIF - ENDIF - ENDDO - -C STORMS HAVE ALREADY BEEN SORTED IN CHRONOLOGICAL ORDER SO -C SUBSTITUTE THE STORM ID OF THE EARLIEST STORM. - - IF(ISAME .NE. 0) THEN - - WRITE(6,1695) IDASRT(1),STMID(IDASRT(1)),STMNAM(IDASRT(1)) - 1695 FORMAT(/'...EARLIEST RECORD IS:',I3,'. STORM ID IS: ',A,' STORM ', - 1 'NAME IS: ',A/4X,'THIS STORM ID AND RSMC WILL BE COPIED ', - 2 'TO THE FOLLOWING STORMS:') - DO NS=1,NSAME - BUFINX=OVRREC(INDSAM(NS)) - STMIDX=STMID(IDASRT(1)) - RSMCX =RSMC (IDASRT(1)) - OVRREC(INDSAM(NS))=BUFINX - IF(INDSAM(NS) .LE. NOKAY) IFRSMC(NUMOKA(INDSAM(NS)))=-IETYP - WRITE(6,1697) NS,INDSAM(NS),OVRREC(INDSAM(NS)) - 1697 FORMAT('...',I3,'...',I3,'...',A) - ENDDO - ENDIF - - ENDIF - - ELSE - WRITE(6,697) NOK,OKAREC(NOK) - 697 FORMAT('...OKAY RECORD ',I3,' IS UNIQUE AMONG OKAY AND SHORT-', - 1 'TERM HISTORY RECORDS. NO FURTHER PROCESSING WILL BE ', - 2 'DONE. RECORD IS:'/4X,'...',A,'...') - ENDIF - - 700 CONTINUE - ENDDO - CALL AKADMP(IUNTAL) - -C SAVE AS BAD RECORDS THOSE ORIGINAL RECORDS THAT HAVE BEEN -C UNIFIED, BUT NOT MULTIPLY OBSERVED, SO THAT THEY CAN BE -C COPIED TO THE ORIGINAL SHORT-TERM HISTORY FILE LATER BY RITSTH. - - DO NOK=1,NOKAY - - IF(OKAREC(NOK)(1:1) .NE. '!' .AND. - 1 OVRREC(NOK)(1:1) .EQ. '!') THEN - IETYP=30 - IFRSMC(NUMOKA(NOK))=IETYP - NADD=NADD+1 - NUNIFY=NUNIFY+1 - NUMBAD(NADD+NBAD)=NUMOKA(NOK) - BADREC(NADD+NBAD)=OKAREC(NOK) - ENDIF - - OKAREC(NOK)=OVRREC(NOK) - ENDDO - - WRITE(6,711) IUNTOK - 711 FORMAT(/'...WE HAVE UNIFIED ALL RECORDS AND ARE WRITING THEM TO ', - 1 'THE SCRATCH FILE.'/4X,'THEY WILL BE WRITTEN TO THE ', - 2 'ALIAS SHORT-TERM HISTORY FILE IF UPDATING IS REQUIRED.'/ - 3 4X,'OLD ALIAS SHORT-TERM HISTORY RECORDS WRITTEN TO ', - 4 'IUNTOK=',I3,' ARE:') - NRCOVR=0 - DO NHA=NOKAY+1,NCHECK - IF(IOVRLP(NHA) .NE. -999) THEN - NRCOVR=NRCOVR+1 - WRITE(IUNTOK,521) OVRREC(NHA) - WRITE(6,719) NRCOVR,OVRREC(NHA) - 719 FORMAT('...',I3,'...',A,'...') - OVRREC(NRCOVR)=OVRREC(NHA) - ENDIF - ENDDO - WRITE(6,721) NRCOVR - 721 FORMAT(/'...IMPORTANT NOTE: THE UPDATED OLD ALIAS SHORT-TERM ', - 1 'HISTORY RECORDS ARE RETURNED TO THE MAIN PROGRAM IN ', - 2 'OVRREC.'/4X,'THEY WILL BE COPIED INTO THE SCRATCH FILE ', - 3 '(INSTEAD OF USING CPYREC) WHEN FILES=F.'/4X,'THE NUMBER', - 4 ' OF RECORDS RETURNED IS:',I4) - -C COPY NEW ALIAS FILE TO AKAVIT. DON'T COPY RECORDS -C THAT ALREADY EXIST IN AKAVIT. - - REWIND IUNTAN - CALL AKACPY(IUNTAN,IUNTAL) - -C DO NOT CLEAR OUT THE NEW ALIAS FILE; AKAVIT MAY BE CHANGED BY -C RCNCIL LATER - - WRITE(6,1001) NOKAY,-NSUBR,-NUNIFY,NADD,NTEST, - 1 (ERCRS(NER),NER=1,NERCRS) - 1001 FORMAT(//'...RESULTS OF THE MULTIPLE RSMC CHECK ARE: NOKAY=',I4, - 1 ' NSUBR=',I4,' NUNIFY=',I4,' AND NADD=',I4,' FOR A ', - 2 'TOTAL OF ',I4,' RECORDS.'//4X,'ERROR CODES ARE:'/(6X,A)) - WRITE(6,1003) - 1003 FORMAT(/'...OKAY RECORDS ARE:',100X,'ERC'/) - DO NOK=1,NOKAY - WRITE(6,1009) NOK,NUMOKA(NOK),OKAREC(NOK),-IFRSMC(NUMOKA(NOK)) - 1009 FORMAT(3X,I4,'...',I4,'...',A,'...',I3) - ENDDO - IF(NADD .GT. 0) WRITE(6,1011) (NBAD+NBA,NUMBAD(NBAD+NBA), - 1 BADREC(NBAD+NBA), - 2 IFRSMC(NUMBAD(NBAD+NBA)), - 3 NBA=1,NADD) - 1011 FORMAT(/' ADDED BAD RECORDS ARE:',95X,'ERC'/(3X,I4,'...',I4, - 1 '...',A,'...',I3)) - NBAD=NBAD+NADD - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: BASNCK CHECKS FOR PROPERLY IDENTIFIED BASINS -C PRGMMR: S. LORD ORG: NP22 DATE: 1992-02-24 -C -C ABSTRACT: INPUT RECORDS ARE CHECKED FOR PROPERLY IDENTIFIED BASINS. -C THE INPUT LATIDUDE AND LONGITUDE ARE CHECKED AGAINST -C TABULATED MIN AND MAX LATITUDES AND LONGITUDES FOR THE -C SPECIFIED BASIN. INCONSISTENCIES ARE FLAGGED. -C -C PROGRAM HISTORY LOG: -C 1992-02-19 S. LORD -C -C USAGE: CALL BASNCK(STMIDX,RLTSTM,RLNSTM,NBA,IPRT,IER) -C INPUT ARGUMENT LIST: -C STMIDX - 3 CHARACTER STORM ID. THIRD CHARACTER CARRIES BASIN -C IDENTIFIER -C IPRT - PRINT LEVEL. =1 FOR PRINTOUT; =0 FOR NO PRINTOUT -C -C OUTPUT ARGUMENT LIST: -C NBA - BASIN NUMBER CORRESPONDING TO THE INPUT LAT/LON -C IER - ERROR RETURN CODE: -C 3: STORM IS NOT IN A BASIN DEFINED BY THE TABULATED -C MINIMUM AND MAXIMUM LAT/LON -C 11: BASIN AND BASIN BOUNDARIES DO NOT MATCH. THIS DOES -C NOT NECESSARILY MEAN THERE IS AN ERROR SINCE THE -C STORM COULD HAVE ORIGINATED IN THAT BASIN AND MOVED -C TO ANOTHER -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE BASNCK(STMIDX,RLTSTM,RLNSTM,NBA,IPRT,IER) - - SAVE - - CHARACTER*(*) STMIDX - - PARAMETER (NBASIN=11) - - CHARACTER IDBASN*1 - - DIMENSION IDBASN(NBASIN),BSLTMN(NBASIN),BSLTMX(NBASIN), - 1 BSLNMN(NBASIN),BSLNMX(NBASIN) - - DATA IDBASN/'L','E','C','W','O','T','U','P','S','B','A'/ - -C BASIN BOUNDARIES: MIN AND MAX LATITUDES; MIN AND MAX LONGITUDES -C NOTE: SOME BOUNDARIES MAY OVERLAP, BUT SCANNING IS IN ORDER OF -C DECREASING PRIORITY SO BASINS SHOULD BE CAPTURED PROPERLY - - DATA BSLTMN/3*-20.,2*0.0,20.,3*-50.,2*0.0/, - 1 BSLTMX/4*60.,25.,40.,3*0.0,2*30./, - 2 BSLNMN/260.,220.,180.,2*100.,110.,90.,160.,40.,75.,40./, - 3 BSLNMX/350.,260.,220.,180.,125.,140.,160.,290.,90.,100.,75./ - - - IER=0 - -C RECOVER BASIN NUMBER FROM STORM ID -C WE ASSUME ALL BASIN IDS ARE VALID HERE - - DO NB=1,NBASIN - IF(STMIDX(3:3) .EQ. IDBASN(NB)) THEN - NBA=NB - GO TO 11 - ENDIF - ENDDO - 11 CONTINUE - - IF(RLTSTM .LT. BSLTMN(NBA) .OR. RLTSTM .GT. BSLTMX(NBA) .OR. - 1 RLNSTM .LT. BSLNMN(NBA) .OR. RLNSTM .GT. BSLNMX(NBA)) THEN - IF(IPRT .EQ. 1) WRITE(6,21) STMIDX,NBA,RLTSTM,RLNSTM,BSLTMN(NBA), - 1 BSLTMX(NBA),BSLNMN(NBA),BSLNMX(NBA) - 21 FORMAT(/'******BASIN IDENTIFIER AND LAT/LON ARE INCONSISTENT. A ', - 1 'POSSIBLE ERROR EXISTS OR THE STORM ORIGINATED IN A ', - 2 'DIFFERENT BASIN.'/4X,'STMIDX,NBA,RLTSTM,RLNSTM,BSLTMN(', - 3 'NBA),BSLTMX(NBA),BSLNMN(NBA),BSLNMX(NBA)='/4X,A,I3,6F8.1) - IER=11 - -C IN WHICH BASIN IS THE STORM REALLY LOCATED? - - DO NB=1,NBASIN - IF(RLTSTM .GE. BSLTMN(NB) .AND. RLTSTM .LE. BSLTMX(NB) .AND. - 1 RLNSTM .GE. BSLNMN(NB) .AND. RLNSTM .LE. BSLNMX(NB)) THEN - NBA=NB - RETURN - ENDIF - ENDDO - IER=3 - WRITE(6,51) STMIDX,NBA,RLTSTM,RLNSTM,BSLTMN(NBA), - 1 BSLTMX(NBA),BSLNMN(NBA),BSLNMX(NBA) - 51 FORMAT(/'******STORM=',A,' IS NOT IN A DEFINED BASIN. NBA,', - 1 'RLTSTM,RLNSTM,BSLTMN(NBA),BSLTMX(NBA),BSLNMN(NBA),', - 2 'BSLNMX(NBA)='/I3,6F8.1) - ENDIF - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AKASUB HANDLES STORAGE AND WRITING ALIAS RECORDS -C PRGMMR: S. LORD ORG: NP22 DATE: 1992-03-05 -C -C ABSTRACT: STORES ALIAS RECORDS UNTIL THEY ARE READY TO BE DUMPED TO -C DISK. DUMPING TO DISK INVOLVES FINDING THE ONE RECORD FOR -C EACH STORM THAT HAS THE EARLIEST DATE. COPYING FROM ONE -C UNIT TO ANOTHER ALSO INVOLVES FINDING THE EARLIEST DATE. -C FUNCTIONS ARE PERFORMED BY 3 SEPARATE ENTRIES AS SHOWN -C BELOW. AKASUB IS JUST A DUMMY HEADING. -C -C PROGRAM HISTORY LOG: -C 1992-03-05 S. LORD -C -C USAGE: CALL AKASUB(IUNITI,IUNITO,NAKREC,NAKA,DAYZ,AKANAM,AKRSMC, -C AKSTID) -C CALL AKASAV(NAKREC,NAKA,DAYZ,AKANAM,AKRSMC,AKSTID): STORES -C RECORDS -C CALL AKADMP(IUNITO): DUMPS RECORDS TO DISK -C CALL AKACPY(IUNITI,IUNITO): COPIES RECORDS FROM IUNITI TO -C IUNITO -C INPUT ARGUMENT LIST: -C IUNITI - INPUT UNIT NUMBER. FILE POSITIONING MUST BE HANDLED -C - OUTSIDE THIS ROUTINE. -C IUNITO - OUTPUT UNIT NUMBER. FILE POSITIONING MUST BE HANDLED -C - OUTSIDE THIS ROUTINE. -C NAKREC - RECORD NUMBER, FIRST RECORD IS 1 AND SO ON. -C NAKA - NUMBER OF ALIASES IN EACH RECORD. FIRST ALIAS IS -C - USUALLY A COMBINED OR UNIFIED ALIAS BEGINNING WITH A !. -C DAYZ - FRACTIONAL DAY FOR EACH RECORD -C AKANAM - STORM NAME (CHARACTER*9) -C AKRSMC - ARRAY CONTAINING ALL RSMCS (CHARACTER*4) -C AKSTID - ARRAY CONTAINING ALL STORM IDS (CHARACTER*3) -C -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE AKASUB(IUNITI,IUNITO,NAKREC,NAKA,DAYZ,AKANAM,AKRSMC, - 1 AKSTID,ICSTNM,ICRSMC,ICSTID,IFAKA) - - PARAMETER (MAXSTM=70) - PARAMETER (NOVRMX=MAXSTM) - PARAMETER (MAXAKA=10) - - SAVE - - DIMENSION NUMSAV(MAXSTM),SAVNAM(MAXSTM),SAVRSM(MAXSTM,MAXAKA), - 1 SAVID(MAXSTM,MAXAKA),SAVDAY(MAXSTM),INDSAM(MAXSTM) - - DIMENSION AKRSMC(NOVRMX),AKSTID(NOVRMX),RSMCCP(MAXAKA), - 1 STIDCP(MAXAKA) - - CHARACTER SAVNAM*9,SAVRSM*4,SAVID*3,STMNMX*9,RSMCCP*4,STIDCP*3 - CHARACTER*(*) AKANAM,AKRSMC,AKSTID,ICSTNM,ICRSMC,ICSTID - - LOGICAL FOUND - -C----------------------------------------------------------------------- -C THIS ENTRY STORES ALIAS ENTRIES - - ENTRY AKASAV(NAKREC,NAKA,DAYZ,AKANAM,AKRSMC,AKSTID) - - WRITE(6,1) NAKREC - 1 FORMAT(/'...ENTERING AKASAV TO STORE RECORD #',I3,'. RECORD IS:') - - NAKSAV=NAKREC - NUMSAV(NAKSAV)=NAKA - SAVNAM(NAKSAV)=AKANAM - SAVDAY(NAKSAV)=DAYZ - - SAVRSM(NAKSAV,1:NAKA)=AKRSMC(1:NAKA) - SAVID (NAKSAV,1:NAKA)=AKSTID(1:NAKA) - WRITE(6,11) NAKA,AKANAM,(AKRSMC(NAL),AKSTID(NAL),NAL=1,NAKA) - 11 FORMAT('...',I1,1X,A9,10(1X,A4,1X,A3)) - - RETURN - -C----------------------------------------------------------------------- -C THIS ENTRY DUMPS ALIAS ENTRIES. ONLY THE EARLIEST ENTRY FOR -C EACH STORM IS SAVED. - - ENTRY AKADMP(IUNITO) - - WRITE(6,21) IUNITO - 21 FORMAT(/'...ENTERING AKADMP TO WRITE EARLIEST UNIQUE ALIAS ', - 1 'RECORDS TO UNIT',I3,'. STORED RECORDS ARE:'/10X,'NAL', - 2 4X,'NAME',12X,'JDAY',5X,'RSMC',2X,'STMID') - DO NAK=1,NAKSAV - WRITE(6,23) NAK,NUMSAV(NAK),SAVNAM(NAK),SAVDAY(NAK), - 1 (SAVRSM(NAK,NS),SAVID(NAK,NS),NS=1,NUMSAV(NAK)) - 23 FORMAT(3X,I3,2X,I3,4X,A,3X,F12.3,10(3X,A)) - ENDDO - - NREC=0 - DO NAK=1,NAKSAV - IF(NUMSAV(NAK) .GT. 0) THEN - IFND=1 - INDSAM(IFND)=NAK - WRITE(6,27) NAK,IFND,SAVNAM(NAK),SAVDAY(NAK),(SAVRSM(NAK,NSAV), - 1 SAVID(NAK,NSAV),NSAV=1,NUMSAV(NAK)) - 27 FORMAT(/'...LOOKING FOR MATCHING STORM NAMES FOR INDEX=',I3, - 1 ', IFND=',I3,' STORM NAME= ',A,' WITH DAY=',F12.3/4X, - 2 'ALIASES ARE: ',10(A,1X,A,'; ')) - WRITE(6,29) - 29 FORMAT('...IMPORTANT NOTE: ALIAS RECORDS WITH DATE=-999.0 WILL ', - 1 'ALWAYS BE COPIED.') - - DO NSAME=NAK+1,NAKSAV - IF(NUMSAV(NSAME) .GT. 0) THEN - FOUND=.FALSE. - -C SAME STORM NAME IF NOT NAMELESS - - IF(SAVNAM(NAK) .NE. 'NAMELESS' .AND. - 1 SAVNAM(NSAME) .NE. 'NAMELESS' .AND. - 2 SAVNAM(NAK) .EQ. SAVNAM(NSAME)) THEN - FOUND=.TRUE. - -C DIRECT COMPARISON OF STORM IDS FOR THE SAME RSMC - - ELSE - DO NAL2=1,NUMSAV(NAK) - DO NAL1=1,NUMSAV(NSAME) - IF(SAVRSM(NSAME,NAL1) .EQ. SAVRSM(NAK,NAL2) .AND. - 1 SAVID (NSAME,NAL1) .EQ. SAVID (NAK,NAL2)) FOUND=.TRUE. - ENDDO - ENDDO - ENDIF - - IF(FOUND) THEN - NUMSAV(NSAME)=-IABS(NUMSAV(NSAME)) - IFND=IFND+1 - INDSAM(IFND)=NSAME - WRITE(6,59) NSAME,IFND,SAVDAY(NSAME) - 59 FORMAT(/'...STORM NAME FOR INDEX=',I3,' MATCHES. IFND=',I3,' AND', - 1 ' DAY=',F12.3) - ENDIF - ENDIF - ENDDO - -C SINGLE OCCURRENCE - - IF(IFND .EQ. 1) THEN - NW=NAK - DAYMNZ=SAVDAY(NAK) - STMNMX=SAVNAM(NAK) - WRITE(6,61) NW,SAVNAM(NAK),SAVID(NAK,1) - 61 FORMAT('...INDEX',I3,' WITH NAME=',A,' AND ID=',A,' HAS ONLY A ', - 1 'SINGLE OCCURRENCE.') - -C IF THERE ARE MULTIPLE OCCURRENCES, WRITE ONLY THE EARLIEST RECORD, -C BUT SUBSTITUTE IN THE STORM NAME IF IT IS NOT NAMELESS. - - ELSE - WRITE(6,63) SAVNAM(NAK),SAVID(NAK,1) - 63 FORMAT('...STORM NAME=',A,' AND ID=',A,' HAS MULTIPLE ', - 1 'OCCURRENCES. WE LOOK FOR THE FIRST OCCURRENCE.') - DAYMNZ=1.E10 - STMNMX='NAMELESS' - DO IF=1,IFND - IF(STMNMX .EQ. 'NAMELESS' .AND. - 1 SAVNAM(INDSAM(IF)) .NE. 'NAMELESS') - 1 STMNMX=SAVNAM(INDSAM(IF)) - IF(SAVDAY(INDSAM(IF)) .LT. DAYMNZ) THEN - DAYMNZ=SAVDAY(INDSAM(IF)) - NW=INDSAM(IF) - ENDIF - ENDDO - ENDIF - -C WRITE THE RECORD - - NREC=NREC+1 - WRITE(IUNITO,81) IABS(NUMSAV(NW)),STMNMX,(SAVRSM(NW,NAL), - 1 SAVID(NW,NAL),NAL=1,IABS(NUMSAV(NW))) - 81 FORMAT(I1,1X,A9,10(1X,A4,1X,A3)) - WRITE(6,83) NREC,DAYMNZ,NW,IUNITO,STMNMX, - 1 IABS(NUMSAV(NW))-1,(SAVRSM(NW,NAL),SAVID(NW,NAL), - 2 NAL=1,IABS(NUMSAV(NW))) - 83 FORMAT('...ADDING NEW ALIAS RECORD ',I3,' WITH DATE=',F12.3, - 1 ' AND INDEX',I3,' TO UNIT ',I3,' FOR STORM NAME=',A,'.'/4X, - 2 'NUMBER OF OBSERVERS IS:',I2,' RSMC, STORM IDS ARE:'/10X, - 3 10(1X,A4,1X,A3)) - - ENDIF - ENDDO - WRITE(6,91) NREC,IUNITO - 91 FORMAT(/'...',I3,' RECORDS HAVE BEEN WRITTEN TO UNIT',I3) - - RETURN - -C----------------------------------------------------------------------- - - ENTRY AKACPY(IUNITI,IUNITO) - - NCPYAL=0 - WRITE(6,101) IUNITI,IUNITO - 101 FORMAT(/'...ENTERING AKACPY TO COPY ALIAS RECORDS FROM IUNITI=', - 1 I3,' TO IUNITO=',I3,':') - - 110 READ(IUNITI,81,END=180) NALMX,STMNMX,(RSMCCP(NAL),STIDCP(NAL), - 1 NAL=1,NALMX) - - DO NALZ=1,NAKSAV - FOUND=.FALSE. - -C SAME STORM NAME IF NOT NAMELESS - - IF(STMNMX .NE. 'NAMELESS' .AND. - 1 SAVNAM(NALZ) .NE. 'NAMELESS' .AND. - 2 STMNMX .EQ. SAVNAM(NALZ)) THEN - FOUND=.TRUE. - GO TO 171 - -C DIRECT COMPARISON OF STORM IDS FOR THE SAME RSMC - - ELSE - DO NAL2=1,NALMX - DO NAL1=1,NUMSAV(NALZ) - IF(SAVRSM(NALZ,NAL1) .EQ. RSMCCP(NAL2) .AND. - 1 SAVID (NALZ,NAL1) .EQ. STIDCP(NAL2)) FOUND=.TRUE. - ENDDO - ENDDO - ENDIF - - ENDDO - 171 CONTINUE - - IF(.NOT. FOUND) THEN - NCPYAL=NCPYAL+1 - WRITE(IUNITO,81) NALMX,STMNMX,(RSMCCP(NAL),STIDCP(NAL), - 1 NAL=1,NALMX) - WRITE(6,175) NALMX,STMNMX,(RSMCCP(NAL),STIDCP(NAL), - 1 NAL=1,NALMX) - 175 FORMAT('...',I1,1X,A9,10(1X,A4,1X,A3)) - - ELSE - WRITE(6,177) STMNMX - 177 FORMAT('...STORM ',A,' IS ALREADY IN OUTPUT ALIAS FILE. IT WILL ', - 1 'NOT BE COPIED.') - ENDIF - - GO TO 110 - - 180 CONTINUE - WRITE(6,181) NCPYAL,IUNITI,IUNITO - 181 FORMAT('...',I3,' RECORDS COPIED FROM UNIT',I3,' TO UNIT ',I3,'.') - - RETURN - -C----------------------------------------------------------------------- - - ENTRY AKAFND(IUNITI,ICSTNM,ICRSMC,ICSTID,NAKA,AKANAM,AKRSMC, - 1 AKSTID,IFAKA) - - ifaka=0 - irec=0 - rewind iuniti - 210 read(iuniti,81,end=240) nalmx,stmnmx,(rsmccp(nal),stidcp(nal), - 1 nal=1,min(nalmx,maxaka)) - irec=irec+1 - do nal=1,nalmx - if(icrsmc .eq. rsmccp(nal) .and. - 1 icstid .eq. stidcp(nal)) then - ifaka=irec - go to 240 - endif - enddo - go to 210 - 240 continue - - if(ifaka .gt. 0) then - - if(nalmx .gt. naka) then - write(6,241) nalmx,naka - 241 format('******Insufficient storage to return aliases. nalmx,', - 1 'naka=',2i5,' Abort.') - call abort1(' AKAFND',241) - endif - - naka=nalmx - akanam=stmnmx - akrsmc(1:nalmx)=rsmccp(1:nalmx) - akstid(1:nalmx)=stidcp(1:nalmx) -c write(6,251) naka,ifaka,icstnm,icrsmc,icstid,akanam, -c 1 (akrsmc(nal),akstid(nal),nal=1,naka) -c 251 format('...akafnd results: # of aliases=',i4,' matching alias ', -c 1 'record #=',i4,' input storm name,rsmc,id=',3(a,1x)/4x, -c 2 'matched name,rsmc,id=',a/(4x,10(1x,a4,1x,a3))) - - else -c write(6,271) icstnm,icrsmc,icstid -c 271 format('###Storm not found in akavit file, storm name,rsmc,', -c 1 'id are:',3(a,1x)) - endif - return - -C----------------------------------------------------------------------- - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: TCCLIM TROPICAL CYCLONE CLIMATOLOGICAL VALUES -C PRGMMR: S. LORD ORG: NP22 DATE: 1992-04-07 -C -C ABSTRACT: RETURNS CLIMATOLOGICAL VALUES FOR SOME TROPICAL CYCLONE -C PROPERTIES. PROPERTIES ARE: CENTRAL PRESSURE OF STORM; -C ENVIRONMENTAL PRESSURE ON THAT ISOBAR RADIUS OF THE OUTERMOST -C CLOSED ISOBAR A SECOND ENTRY CONTAINS PRESSURE-WIND TABLES FOR -C THE ATLANTIC, EAST AND CENTRAL PACIFIC AND WEST PACIFIC BASINS. -C -C PROGRAM HISTORY LOG: -C 1992-04-07 S. LORD -C 1992-09-04 S. LORD ADDED PRESSURE WIND RELATIONSHIP -C -C USAGE: VALUE=TCCLIM(IVAR,IBASN) OR VALUE=TCPWTB(PRES,IBASN) -C INPUT ARGUMENT LIST: -C IVAR - VARIABLE NUMBER (7: CENTRAL PRESSURE) -C - (8: ENVIRONMENTAL PRESSURE) -C - (9: RADIUS OF OUTERMOST CLOSED ISOBAR) -C IBASN - BASIN NUMBER -C PRES - PRESSURE IN MB -C -C -C REMARKS: IVAR VALUES OF 7,8,9 ONLY ARE ALLOWED. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - FUNCTION TCCLIM(IVAR,IBASN) - - PARAMETER (NPRMAX=9) - - PARAMETER (NBASIN=11) - PARAMETER (ISECVR= 5,ITERVR=10) - PARAMETER (NSECVR=ITERVR-ISECVR) - - DIMENSION SECVCL(NBASIN,NSECVR-2),PRTABL(NBASIN,0:NPRMAX+1), - 1 VMTABL(NBASIN,0:NPRMAX+1) - - DATA SECVCL/3*940.0,3*930.0,2*970.0,3*960.0, - 1 3*1010.0,5*1008.0,3*1010.0, - 2 6*400.0,5*300.0/ - - DATA PRTABL/2*1020.,9*1020., 2*987.,9*976., - 2 2*979.,9*966., 2*970.,9*954., - 2 2*960.,9*941., 2*948.,9*927., - 3 2*935.,9*914., 2*921.,9*898., - 4 2*906.,9*879., 2*890.,9*858., - 5 2*850.,9*850./ - - DATA VMTABL/11*12.5,11*33.5,11*39.7,11*46.4,11*52.6,11*59.3, - 1 11*65.5,11*72.2,11*80.0,11*87.6,11*110./ - - ITABL=IVAR-(ISECVR+2)+1 - TCCLIM=SECVCL(IBASN,ITABL) - - RETURN - -C----------------------------------------------------------------------- - - ENTRY TCPWTB(PRESR,IBASN) - - DO IPR=1,NPRMAX - IF(PRESR .LE. PRTABL(IBASN,IPR-1) .AND. - 1 PRESR .GT. PRTABL(IBASN,IPR)) THEN - IPRZ=IPR - GO TO 11 - ENDIF - ENDDO - IPRZ=NPRMAX+1 - 11 CONTINUE - TCPWTB=VMTABL(IBASN,IPRZ-1)+ - 1 (VMTABL(IBASN,IPRZ)-VMTABL(IBASN,IPRZ-1))* - 2 (PRESR-PRTABL(IBASN,IPRZ-1))/ - 3 (PRTABL(IBASN,IPRZ)-PRTABL(IBASN,IPRZ-1)) - - RETURN - -C----------------------------------------------------------------------- - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: RCNCIL MANAGES STORM CATALOG -C PRGMMR: S. LORD ORG: NP22 DATE: 1993-03-05 -C -C ABSTRACT: STORM RECORDS ARE CHECKED FOR PRESENCE IN THE STORM -C CATALOG UPDATED AND ADDED IF NECESSARY. -C -C PROGRAM HISTORY LOG: -C 1992-03-25 S. LORD -C 1992-08-25 S. LORD ADDED IER RETURN CODE -C -C USAGE: CALL RCNCIL(IUNTCA,IUNTCN,IUNTAL,NTEST,NOKAY,NBAD,MAXREC, -C MAXCKS,IEFAIL,IER,IECAT,NUMTST,NUMOKA,NUMBAD, -C TSTREC,BADREC,OKAREC) -C INPUT ARGUMENT LIST: -C IUNTCA - UNIT NUMBER FOR THE STORM CATALOG. -C -C IUNTCN - UNIT NUMBER FOR THE TEMPORARY CATALOG -C -C IUNTAL - UNIT NUMBER FOR ALIAS FILE. -C NTEST - NUMBER OF CURRENT RECORDS TO BE TESTED. -C MAXREC - MAXIMUM NUMBER OF RECORDS (STORAGE FOR ARRAYS) -C MAXCKS - MAXIMUM NUMBER OF ERROR CHECKS (STORAGE FOR ARRAYS) -C IEFAIL - ARRAY CONTAINING ERROR CODES FOR ERROR CHECKS -C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD -C - TO BE TESTED. -C IOVRLP - SCRATCH ARRAY. -C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED. -C -C OUTPUT ARGUMENT LIST: -C NOKAY - NUMBER OF RECORDS THAT PASSED THE RSMC CHECK. -C NBAD - NUMBER OF RECORDS THAT FAILED THE RSMC CHECK. -C IER - ERROR RETURN CODE. 0 EXCEPT IF LOGICAL INCONSISTENCY -C FOUND. -C IECAT - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT -C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES. -C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD -C - RECORD. -C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD -C - RECORD. -C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED -C - THE RSMC CHECK. -C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED -C - THE RSMC CHECK. -C -C INPUT FILES: -C UNIT 25 - ALIAS FILE CONTAINING EQUIVALENT STORM IDS -C - FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S -C - DCB: LRECL=255, BLKSIZE=23400, RECFM=VB -C UNIT 26 - NEW ALIAS FILE CONTAINING EQUIVALENT STORM IDS -C - FOR STORMS THAT HAVE BEEN REPORTED BY MULTIPLE RSMC'S -C UNIT 27 - STORM CATALOG FILE -C - DCB: LRECL=255, BLKSIZE=23400, RECFM=VB -C UNIT 28 - SCRATCH STORM CATALOG FILE -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C UNIT 27 - SAME AS ABOVE -C UNIT 28 - SAME AS ABOVE -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE RCNCIL(IUNTCA,IUNTCN,IUNTAL,NTEST,NOKAY,NBAD,MAXREC, - 1 MAXCKS,IEFAIL,IER,IECAT,NUMTST,NUMOKA,NUMBAD, - 2 TSTREC,BADREC,OKAREC) - - PARAMETER (NERCRC=3) - PARAMETER (MAXSTM=70) - PARAMETER (NOVRMX=MAXSTM) - PARAMETER (NADDMX=10) - - CHARACTER*(*) TSTREC(0:NTEST),BADREC(MAXREC),OKAREC(NOKAY), - 1 ERCRCN(NERCRC)*60 - character stnmal*9,stidal*3,rsmcal*4,stnmca*9,stidca*3,rsmcca*4, - 1 stidad*3,rsmcad*4 - - PARAMETER (MAXCHR=95) - PARAMETER (MAXVIT=15) - PARAMETER (NBASIN=11) - PARAMETER (NRSMCX=4) - - CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1, - 1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1,IDBASN*1, - 2 RSMCID*4,RSMCAP*1 - - DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT) - - DIMENSION BUFIN(MAXCHR),IDBASN(NBASIN), - 1 FMTVIT(MAXVIT),RSMCID(NRSMCX),RSMCAP(NRSMCX) - - EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ), - 1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ), - 2 (BUFIN(37),LATNS),(BUFIN(43),LONEW), - 3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ) - - EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ) - - DIMENSION IVTVRX(MAXVIT) - - DIMENSION RINC(5) - - CHARACTER BUFCK(MAXCHR)*1,RSMCX*4,RELOCX*1,STMIDX*3,BUFINX*100, - 1 STMNMX*9,LATNSX*1,LONEWX*1 - - DIMENSION IEFAIL(MAXREC,0:MAXCKS),IECAT(MAXREC),NUMOKA(NOKAY), - 1 NUMBAD(MAXREC),NUMTST(NTEST),MAXNO(NBASIN) - - dimension rsmcal(novrmx),stidal(novrmx), - 1 rsmcca(novrmx),stidca(novrmx), - 2 rsmcad(naddmx),stidad(naddmx) - - EQUIVALENCE (BUFCK(1),RSMCX),(BUFCK(5),RELOCX),(BUFCK(6),STMIDX), - 1 (BUFCK(1),BUFINX),(BUFCK(10),STMNMX), - 2 (BUFCK(35),LATNSX),(BUFCK(41),LONEWX) - - EQUIVALENCE (IVTVRX(1),IDATEX),(IVTVRX(2),IUTCX) - - DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)', - 1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/, - 2 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/, - 3 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/ - - DATA IDBASN/'L','E','C','W','O','T','U','P','S','B','A'/ - - DATA RSMCID/'NHC ','JTWC','ADRM','JMA '/, - 1 RSMCAP/'N','W','A','J'/ - - data maxno/nbasin*0/,minday/-1/,maxday/1/ - - DATA ERCRCN - 1 /'10: NEW STORM, ADD TO CATALOG ', - 2 '20: DUP. STORM ID IN CATALOG. CREATE NEW ID, APPEND CATALOG ', - 3 '30: STORM FOUND IN CATALOG, UPDATE CATALOG ENTRY '/ - - write(6,1) nokay - 1 format(//'...Entering rcncil to reconcile catalog, alias file ', - 1 'and new records. Number of okay records=',i4/4x,'Codes', - 2 ' are:'/10x,'1: No catalog entry'/13x,'Action: Append ', - 3 'catalog (first time appearance), record unchanged'/10x, - 4 '2: Duplicate storm id to primary catalog id'/13x, - 5 'Action: Find new, unique id which is one more than the', - 6 'largest id for that basin, modify record, append to ', - 7 'catalog'/10x,'3: Storm found in catalog,'/13x,'Action:', - 8 'update catalog entry') - rewind iuntca - rewind iuntcn - ncat=0 - ipack=10*maxrec - nadd=0 - ier=0 - - write(6,3) - 3 format(/'...Input records are:') - - do iec=1,ntest - iecat(iec)=ipack - write(6,5) iec,numtst(iec),tstrec(iec) - 5 format('...',i4,'...',i5,'...',a) - - enddo - - call sclist(iuntca) - call aklist(iuntal) - -c First pass through catalog to determine what should be done - - 20 continue - READ(IUNTCA,21,END=90) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX, - 1 (RSMCCA(NAL),STIDCA(NAL), - 2 NAL=1,MIN(NALCA,NOVRMX)) - 21 FORMAT(I1,1X,A9,2(1X,I8,1X,I4.4),10(1X,A4,1X,A3)) - ncat=ncat+1 - -c Determine maximum storm id in each basin from the catalog - - read(stidca(1)(1:2),23) idno - 23 format(i2) - do nb=1,nbasin - if(stidca(1)(3:3) .eq. idbasn(nb)) then - maxno(nb)=max0(maxno(nb),idno) - go to 31 - endif - enddo - 31 continue - -c Determine the catalog code for each record -c Codes and actions are: - -c Code 1: No catalog entry -c Action: Append catalog (first time appearance), record unchanged - -c Code 2: Duplicate storm id to primary catalog id, storm not -c found in catalog -c Action: Find new, unique id which is one more than the largest -c id for that basin, modify record, append to catalog - -c Code 3: Storm found in catalog -c Action: Update catalog date and other entries if necessary - -c Notes: codes from 1-3 are in order of increasing priority so that -c a code of 2 can be overridden by a code of 3 -c A final check on the consistency between the catalog and the alias -c (akavit) file is made. Any inconsistency is resolved in favor of t -c catalog but is flagged by a positive error code even though the -c record is retained. - -c Codes are packed so that the appropriate record number in the -c catalog is recoverable. Packing depends on maxrec, which -c should be a 4 digit number (1000 should work fine). - - do 80 nrec=1,ntest - -c Look at okay records and bad records with overland error codes. -c An error code for the rsmcck of 22 forces a look at the -c alias file since an entry has been made already. - - if(nrec .le. nokay .or. - 1 (nrec .gt. nokay .and. (iefail(numtst(nrec),4) .eq. 5 .or. - 2 iefail(numtst(nrec),4) .eq. 6 .or. - 3 iefail(numtst(nrec),6) .eq. 22))) then - - bufinz=tstrec(nrec) - - if(rsmcz(1:1) .ne. '!' .and. iefail(numtst(nrec),6) .ne. 22) - 1 then - nalsav=1 - stnmal=stmnmz - rsmcal(1)=rsmcz - stidal(1)=stmidz - - else -c write(6,35) nrec,stmnmz,rsmcz,stmidz -c 35 format('...Calling akafnd for record',i4,' with storm name,', -c 1 'rsmc,id=',3(a,1x),' to find all aliases.') - nalsav=novrmx - call akafnd(iuntal,stmnmz,rsmcz,stmidz,nalsav,stnmal,rsmcal, - 1 stidal,ifnd) - - if(ifnd .eq. 0) then - write(6,37) stmnmz,stmidz,rsmcz - 37 format('******Bang or overlapped storm not found in akavit file ', - 1 'when finding aliases. stmnmz,stmidz,rsmcz=',3(1x,a), - 2 ' abort') -c call abort1(' RCNCIL',37) - endif - - endif - - do nal=1,nalsav - -c Code 3: - -c if the record is nameless the entire storm id and rsmc -c must match - - IF(STMNMZ .NE. 'NAMELESS') THEN - - if(stnmca .eq. stnmal .and. - 1 stidca(1)(3:3) .eq. stidal(nal)(3:3)) then - iecat(nrec)=3*ipack+ncat - write(6,43) nrec,stnmal,stidal(nal),rsmcal(nal),iecat(nrec) - 43 format('...For nrec=',i5,' storm named=',a,' with id,rsmc=', - 1 2(a,1x),' is in catalog, iecat=',i6) - go to 80 - endif - ENDIF - - do nca=1,nalca - if(rsmcal(nal) .eq. rsmcca(nca) .and. - 1 stidal(nal) .eq. stidca(nca)) then - iecat(nrec)=3*ipack+ncat - write(6,47) nrec,nca,stnmal,stidal(nal),rsmcal(nal),iecat(nrec) - 47 format('...For nrec,nca=',2i5,' storm named=',a,' with id,rsmc=', - 1 2(a,1x),' is in catalog, iecat=',i6) - go to 80 - endif - enddo - enddo - - -c Code 2: now there is no exact match to the catalog - make sure the -c won't be a duplicate storm id - -c Possibilities are: -c 1) If both record and catalog are bang, RSMCCK may have changed th -c rsmc (e.g. added a new observing rsmc). We assume the storm is -c in the catalog (code 3). -c 2) If the catalog is a bang, and the record is not, the record is -c new storm (code 2) or the records has been processed by rsmcc -c but not yet by rcncil. Check the AKAVIT file and adjust the -c code accordingly. -c 3) Neither record or catalog entry is a bang (code 2). - - if(stmidz .eq. stidca(1)) then - - if(rsmcz(1:1) .eq. '!' .and. - 1 rsmcca(1)(1:1) .eq. '!') then - iecatz=3 - write(6,71) nrec,stmidz,ncat,rsmcz,rsmcca(1) - 71 format(/'...For nrec=',i5,' only storm id=',a,' matches catalog ', - 1 'entry',i5,'. Record and catalog rsmcs are both bang:', - 2 2(1x,a)/4x,'###This case should never happen!') - - else if(rsmcz(1:1) .ne. '!' .and. - 1 rsmcca(1)(1:1) .eq. '!') then - - write(6,73) nrec,stmidz,rsmcz,rsmcca(1),stmnmz,rsmcz,stmidz - - 73 format('...For nrec=',i5,' only storm id=',a,' matches catalog ', - 1 'entry.'/4x,'...Record rsmc (',a,') is not bang but ', - 2 'catalog rsmc is (',a,').'/4x,'...Calling akafnd with ', - 3 'storm name, rsmc, id=',3(a,1x),' to find all aliases.') - - nalsav=novrmx - call akafnd(iuntal,stmnmz,rsmcz,stmidz,nalsav,stnmal,rsmcal, - 1 stidal,ifnd) - if(ifnd .eq. 1) then - write(6,75) - 75 format(3x,'...Record found in alias file. Code 3 assigned.') - iecatz=3 - - else - write(6,77) - 77 format(3x,'...Record not found in alias file. Code 2 retained.') - iecatz=2 - endif - - else - iecatz=2 - write(6,79) nrec,stmidz,ncat,rsmcz,rsmcca(1) - 79 format(/'...For nrec=',i5,' only storm id=',a,' matches catalog ', - 1 'entry',i5,'. Rsmcs are:',2(1x,a)/4x,' ###Probable new ', - 2 'storm with a duplicate storm id') - endif - - iecat(nrec)=max0(iecat(nrec)/ipack,iecatz)*ipack+ncat - endif - - endif - 80 continue - -c Write to the scratch catalog - - WRITE(IUNTCN,21) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX, - 1 (RSMCCA(NAL),STIDCA(NAL), - 2 NAL=1,MIN(NALCA,NOVRMX)) - go to 20 - 90 continue - - if(ncat .eq. 0) then - write(6,91) - 91 format(/'...There are no catalog entries. All input records will', - 1 ' be assigned code 1.') - iecat(1:ntest)=ipack - - endif - - write(6,131) - 131 format('...Summary of catalog codes for first scan:') - do nrec=1,ntest - if(nrec .le. nokay .or. - 1 (nrec .gt. nokay .and. (iefail(numtst(nrec),4) .eq. 5 .or. - 2 iefail(numtst(nrec),4) .eq. 6 .or. - 3 iefail(numtst(nrec),6) .eq. 22))) then - write(6,133) nrec,iecat(nrec),tstrec(nrec) - 133 format(4x,2i6,1x,'...',a,'...') - if(iabs(iefail(numtst(nrec),5)) .le. 9) then - iefail(numtst(nrec),5)=-(iabs(iefail(numtst(nrec),5))+ - 1 iabs(iecat(nrec))/ipack*10) - endif - endif - enddo - write(6,143) (nb,idbasn(nb),maxno(nb),nb=1,nbasin) - 143 format('...Summary of maximum storm ids for each basin:'/(4x,i3, - 1 1x,a,i4)) - -c Second pass: copy back from the scratch catalog and update -c each entry as needed - - rewind iuntca - rewind iuntcn - ncat=0 - - 201 continue - READ(IUNTCN,21,END=300) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX, - 1 (RSMCCA(NAL),STIDCA(NAL), - 2 NAL=1,MIN(NALCA,NOVRMX)) - ncat=ncat+1 - -c *********************** -c **** Code 3 errors **** -c *********************** - - do nrec=1,ntest - - if(nrec .le. nokay .or. - 1 (nrec .gt. nokay .and. (iefail(numtst(nrec),4) .eq. 5 .or. - 2 iefail(numtst(nrec),4) .eq. 6 .or. - 3 iefail(numtst(nrec),6) .eq. 22))) then - - bufinz=tstrec(nrec) - ietyp=iecat(nrec)/ipack - ircat=iecat(nrec)-ietyp*ipack - - if(ircat .eq. ncat .and. ietyp .eq. 3) then - - write(6,213) nrec,bufinz,NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX, - 1 (RSMCCA(NAL),STIDCA(NAL), - 2 NAL=1,MIN(NALCA,NOVRMX)) - 213 format(/'...Preparing to reconcile code 3 errors for nrec=',i3, - 1 ' record, catalog entry are:'/4x,a,'...'/4x,i1,1x,a9,2(1x, - 2 i8,1x,i4.4),10(1x,a4,1x,a3)) - - IF(STMNMZ .NE. 'NAMELESS' .AND. STNMCA .EQ. 'NAMELESS') THEN - write(6,217) stnmca,ncat,stmnmz,nrec - 217 format('...',a,' storm with catalog entry=',i4,' will have name=', - 1 a,' assigned, nrec=',i4) - STNMCA=STMNMZ - ENDIF - - do iv=1,2 - call decvar(istvar(iv),ienvar(iv),ivtvar(iv),ierdec,fmtvit(iv), - 1 bufinz) - enddo - - call mnmxda(iymdmn,iutcmn,idatez,iutcz,dayz,minday) - call mnmxda(iymdmx,iutcmx,idatez,iutcz,dayz,maxday) - daysav=dayz - ilate=nrec - -c Do all records identified as the same storm - - do nchk=nrec+1,ntest - - if(nchk .le. nokay .or. - 1 (nchk .gt. nokay .and. (iefail(numtst(nchk),4) .eq. 5 .or. - 2 iefail(numtst(nchk),4) .eq. 6 .or. - 3 iefail(numtst(nchk),6) .eq. 22))) then - - bufinx=tstrec(nchk) - ietypx=iecat(nchk)/ipack - ircatx=iecat(nchk)-ietyp*ipack - - if(ircatx .eq. ncat .and. ietypx .eq. 3) then - - IF(STMNMX .NE. 'NAMELESS' .AND. STNMCA .EQ. 'NAMELESS') THEN - write(6,227) stnmca,ncat,stmnmx,nchk - 227 format('...',a,' storm with catalog entry=',i4,' will have name=', - 1 a,' assigned, nchk=',i4) - STNMCA=STMNMX - ENDIF - - do iv=1,2 - call decvar(istvar(iv),ienvar(iv),ivtvrx(iv),ierdec,fmtvit(iv), - 1 bufinx) - enddo - -c write(6,231) nchk,iymdmn,iutcmn,idatex,iutcx,bufinx -c 231 format('...calling mnmxda with nchk,iymdmn,iutcmn,idatex,iutcx,' -c 1 'bufinx=',i4,i9,i6,i7,i6/4x,a) - call mnmxda(iymdmn,iutcmn,idatex,iutcx,dayz,minday) - call mnmxda(iymdmx,iutcmx,idatex,iutcx,dayz,maxday) - if(dayz .gt. daysav) then - daysav=dayz - ilate=nchk - endif - - iecat(nchk)=-iabs(iecat(nchk)) - endif - endif - enddo - -c Look in akavit for the storm. If it is there, extract -c latest pertinent information that will be transferred to the -c storm catalog - - write(6,243) ilate,stmnmz,rsmcz,stmidz - 243 format('...Look in akavit for appropriate information. Latest ', - 1 'record has index=',i5,' storm name,rsmc,id=',3(a,1x)) - - nalsav=novrmx - call akafnd(iuntal,stmnmz,rsmcz,stmidz,nalsav,stnmca,rsmcal, - 1 stidal,ifnd) - - if(ifnd .eq. 0) then - if(rsmcz(1:1) .eq. '!') then - write(6,271) stmnmz,stmidz,rsmcz - 271 format('******Storm not found in akavit file. stmnmz,stmidz,', - 1 'rsmcz=',3(1x,a),' abort') - call abort1(' RCNCIL',271) - - else - write(6,273) ilate - 273 format('...Storm is not multiply observed. We copy the latest ', - 1 'record (#',i5,') to get the latest information.') - bufinx=tstrec(ilate) - nalca=1 - rsmcca(1)=rsmcx - stidca(1)=stmidx - if(stmnmx .ne. 'NAMELESS') stnmca=stmnmx - endif - - else - write(6,277) - 277 format('...Storm is multiply observed. We copy the alias record ', - 1 'to get the latest information.') - -c Do not copy the storm id if there is already a catalog entry - - nalca=nalsav - rsmcca(1)=rsmcal(1) - rsmcca(2:nalca)=rsmcal(2:nalca) - stidca(2:nalca)=stidal(2:nalca) - endif - - iecat(nrec)=-iabs(iecat(nrec)) - - endif - endif - enddo - -c write to the updated catalog - - WRITE(IUNTCA,21) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX, - 1 (RSMCCA(NAL),STIDCA(NAL), - 2 NAL=1,MIN(NALCA,NOVRMX)) - WRITE(6,293) NCAT,NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX, - 1 (RSMCCA(NAL),STIDCA(NAL), - 2 NAL=1,MIN(NALCA,NOVRMX)) - 293 format(/'...CATALOG RECORD ',I3,' WRITTEN. RECORD IS:',I1,1X,A9, - 1 2(1X,I8,1X,I4.4),10(1X,A4,1X,A3)) - go to 201 - - 300 continue - -c **************************** -c **** Code 1 or 2 errors **** -c **************************** - -c Add new storms to the catalog or storms that have duplicate -c ids - - nadcat=0 -c** naladd=0 - do nrec=1,ntest - - if(nrec .le. nokay .or. - 1 (nrec .gt. nokay .and. (iefail(numtst(nrec),4) .eq. 5 .or. - 2 iefail(numtst(nrec),4) .eq. 6 .or. - 3 iefail(numtst(nrec),6) .eq. 22))) then - - bufinz=tstrec(nrec) - ietyp=iecat(nrec)/ipack - - if(ietyp .eq. 1 .or. ietyp .eq. 2) then - write(6,303) nrec,ietyp,bufinz - 303 format(//'...Ready to add new storm to catalog. nrec,ietyp,', - 1 'record are:',2i4/4x,a) - -c Default entry for catalog is a copy of the candidate record or the -c entry from the alias (akavit) file. These entries may be -c updated by records with a later date, entries from the -c alias file, and the need to create a new, unique storm id. - - if(rsmcz(1:1) .ne. '!') then - nalca=1 - stnmca=stmnmz - rsmcca(1)=rsmcz - stidca(1)=stmidz - - else - write(6,305) nrec,stmnmz,rsmcz,stmidz - 305 format('...Calling akafnd for record',i4,' with storm name,', - 1 'rsmc,id=',3(a,1x),' to produce default catalog entries.') - nalsav=novrmx - call akafnd(iuntal,stmnmz,rsmcz,stmidz,nalsav,stnmca,rsmcca, - 1 stidca,ifnd) - nalca=nalsav - - if(ifnd .eq. 0) then - write(6,307) stmnmz,stmidz,rsmcz - 307 format('******Storm not found in akavit file. stmnmz,stmidz,', - 1 'rsmcz=',3(1x,a),' abort') - call abort1(' RCNCIL',307) - endif - endif - - read(stmidz(1:2),23) idno - do nb=1,nbasin - if(stmidz(3:3) .eq. idbasn(nb)) then - nbasav=nb - go to 311 - endif - enddo - 311 continue - - istidn=0 - if(idno .le. maxno(nbasav)) then - istidn=1 - write(6,313) idno,maxno(nbasav) - 313 format('###Storm id number=',i3,' is not larger than catalog ', - 1 'maximum. A new number and storm id must be created=',i4) - endif - - do naddc=1,nadcat - if(stmidz .eq. stidad(naddc)) then - istidn=1 - write(6,315) stmidz - 315 format('...Current storm id has already been added to catalog. A', - 1 ' unique one must be created.') - endif - enddo - -c Create added storm id and rsmc in advance to guarantee uniqueness -c or transfer new storm id to the catalog record. -c istidn=0 : no uniqueness problem has been detected -c istidn=1 : uniqueness problem detected and new id will -c be created -c The new id will be transferred to all records. It must be a bang -c record with only one observing rsmc. It must also be entered int -c the alias file. - - istidn=0 ! Qingfu added to skip the changes of storm ID number - - if(istidn .eq. 1) then - - if(rsmcz(1:1) .eq. '!') then - write(6,331) stmidz,rsmcz,bufinz - 331 format('###Storm with id, rsmc=',2(a,1x),'is a duplicate to a ', - 1 'catalog entry as well as being a bang storm. Record is:'/ - 2 4x,a) - write(6,333) - 333 format('******This problem is not yet coded. Abort') - call abort1(' rcncil',333) - - else - idnomx=-1 - do naddc=1,nadcat - read(stidad(naddc)(1:2),23) idno - if(stidad(naddc)(3:3) .eq. idbasn(nbasav)) - 1 idnomx=max0(idnomx,idno) - enddo - stidad(nadcat+1)(3:3)=idbasn(nbasav) - - if(idnomx .ge. 0) then - write(stidad(nadcat+1)(1:2),3401) idnomx+1 - 3401 format(i2.2) - write(6,341) idbasn(nbasav),stidad(nadcat+1) - 341 format('...Previous storms have been added for basin ',a,' storm', - 1 ' id set to one more than the maximum already added to ', - 2 'the catalog=',a) - else - write(stidad(nadcat+1)(1:2),3401) maxno(nbasav)+1 - write(6,343) idbasn(nbasav),stidad(nadcat+1) - 343 format('...No previous storms added for basin ',a,'. Storm id ', - 1 'set to one more than the maximum already in the catalog=', - 2 a) - endif - -c Create a bang record with one observing rsmc - -c** naladd=naladd+1 - do nrsz=1,nrsmcx - if(rsmcid(nrsz) .eq. rsmcz) then - nrsmc=nrsz - go to 351 - endif - enddo - 351 continue - nalca=2 - rsmcad(nadcat+1)='!'//rsmcap(nrsmc) - stidca(1)=stidad(nadcat+1) - rsmcca(1)=rsmcad(nadcat+1) - stidca(2)=stmidz - rsmcca(2)=rsmcz -c** write(6,355) naladd,(stidca(nca),rsmcca(nca),nca=1,nalca) - write(6,355) nadcat+1,(stidca(nca),rsmcca(nca),nca=1,nalca) - 355 format('...New bang storm (#',i2,') created with unique id. Id, ', - 1 'rsmc are:'/(4x,2(a,3x))) -c** call akasav(naladd,nalca,dayz,stmnmz,rsmcca,stidca) - - endif - - endif - - do iv=1,2 - call decvar(istvar(iv),ienvar(iv),ivtvar(iv),ierdec,fmtvit(iv), - 1 bufinz) - enddo - idatmn=idatez - iutcmn=iutcz - idatmx=idatez - iutcmx=iutcz - call ztime(idatez,iutcz,iyr,imo,ida,ihr,imin) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - call flday(jdy,ihr,imin,daysav) - ilate=nrec - -C####################################################################### - -c Do all records identified as the same storm - - do nchk=nrec+1,ntest - -C----------------------------------------------------------------------- - if(nchk .le. nokay .or. - 1 (nchk .gt. nokay .and. (iefail(numtst(nchk),4) .eq. 5 .or. - 2 iefail(numtst(nchk),4) .eq. 6 .or. - 3 iefail(numtst(nchk),6) .eq. 22))) then - - imatch=0 - - bufinx=tstrec(nchk) - ietypx=iecat(nchk)/ipack - -C....................................................................... - if(ietypx .eq. 1 .or. ietypx .eq. 2) then - - ifnd=0 - -c Storms are obviously the same - - if(stmidz .eq. stmidx .and. rsmcz .eq. rsmcx) then - write(6,371) nchk,nrec,nrec,bufinz,nchk,bufinx - 371 format('...Record',i5,' has the same storm id and rsmc as the ', - 1 'candidate record (#',i5,'). Records are:'/4x,i4,1x,a/4x, - 2 i4,1x,a) - ifnd=-1 - -c Last resort: look in akavit for the storm - - else - write(6,373) nchk,stmnmx,rsmcx,stmidx - 373 format('...calling akafnd for record',i4,' with storm name,rsmc,', - 1 'id=',3(a,1x)) - nalsav=novrmx - call akafnd(iuntal,stmnmx,rsmcx,stmidx,nalsav,stnmal, - 1 rsmcal,stidal,ifnd) - - if(ifnd .eq. 0) then - - if(rsmcx(1:1) .eq. '!') then - write(6,381) stmnmx,stmidx,rsmcx - 381 format('******Storm not found in akavit file. stmnmx,stmidx,', - 1 'rsmcx=',3(1x,a),' abort') - call abort1(' RCNCIL',381) - else -c write(6,383) -c 383 format('...Storm does not have a bang rsmc. It is therefore not ', -c 1 'required to find a match.') - endif - - else - write(6,405) ifnd - 405 format('...Storm found in akavit file at record #',i3) - do nal=1,nalsav - if(rsmcz .eq. rsmcal(nal) .and. - 1 stmidz .eq. stidal(nal)) then - imatch=1 - go to 411 - endif - enddo - 411 continue - endif - - endif - - if(imatch .eq. 1 .or. ifnd .eq. -1) then - write(6,413) ifnd,imatch - 413 format('...Storm matches exactly or by catalog association, ', - 1 'ifnd,imatch=',2i3) - do iv=1,2 - call decvar(istvar(iv),ienvar(iv),ivtvrx(iv),ierdec, - 1 fmtvit(iv),bufinx) - enddo - -c write(6,231) nchk,idatmn,iutcmn,idatex,iutcx,bufinx - call mnmxda(idatmn,iutcmn,idatex,iutcx,dayz,minday) - call mnmxda(idatmx,iutcmx,idatex,iutcx,dayz,maxday) - if(dayz .gt. daysav) then - daysav=dayz - ilate=nchk - endif - - if(istidn .eq. 1) then - tstrec(nchk)=bufinx - nadd=nadd+1 - badrec(nbad+nadd)=bufinx - numbad(nbad+nadd)=numtst(nchk) - iefail(numbad(nbad+nadd),5)= - 1 -iabs(iefail(numtst(nchk),5)) - stmidx=stidad(nadcat+1) - rsmcx =rsmcad(nadcat+1) - write(6,473) stmidx,bufinx,nadd,badrec(nbad+nadd) - 473 format('...Record same as candidate record to be added to ', - 1 'catalog. New storm id=',a,' is assigned. Modified ', - 2 'record is:'/4x,a/4x,'Bad record #',i3,' added is:'/4x,a) - endif - - iecat(nchk)=-iabs(iecat(nchk)) - if(nchk .le. nokay) then - okarec(nchk)=bufinx - else - badrec(nchk-nokay)=bufinx - endif - - endif -C....................................................................... - -c Exact match: substitute storm name if it is not nameless - - if(ifnd .eq. -1) then - - if(stmnmx.ne.'NAMELESS' .and. stmnmz.eq.'NAMELESS') then - stnmca=stmnmx - write(6,475) stnmca - 475 format('...NAMELESS candidate record is renamed to ',a,'from a ', - 1 'matching record.') - endif - -c Match through the alias file: copy alias information for the -c catalog entry - - else if(imatch .eq. 1) then - if(stmnmz.eq.'NAMELESS' .and. stnmal.ne.'NAMELESS') then - stnmca=stnmal - write(6,477) stnmca - 477 format('...NAMELESS candidate record is renamed to ',a,'from a ', - 1 'matching alias record.') - endif - - nalca=nalsav - rsmcca(1:nalca)=rsmcal(1:nalca) - stidca(1:nalca)=stidal(1:nalca) - - else - write(6,491) ifnd,imatch - 491 format('...Storm does not match exactly or by catalog ', - 1 'association, ifnd,imatch=',2i3) - endif - - endif - endif -C----------------------------------------------------------------------- - enddo -C####################################################################### - - if(iecat(nrec) .gt. 0) then - nadcat=nadcat+1 - - if(nadcat .gt. naddmx) then - write(6,505) nadcat,naddmx - 505 format('******Trying to add too many storms to the catalog,', - 1 ' nadcat,naddmx=',2i3) - call abort1(' RCNCIL',505) - endif - - if(istidn .eq. 1) then - nadd=nadd+1 - badrec(nbad+nadd)=bufinz - numbad(nbad+nadd)=numtst(nrec) - iefail(numbad(nbad+nadd),5)=-iabs(iefail(numtst(nrec),5)) - write(6,511) nadd,nrec,nbad+nadd,numtst(nrec) - 511 format(/'...Adding a new bad record due to duplicate storm id, ', - 1 'nadd,nrec,nbad+nadd,numtst=',4i4) - - stmidz=stidad(nadcat) - rsmcz =rsmcad(nadcat) - write(6,513) stidca(1),nalca,bufinz - 513 format('...Id for storm added to catalog =',a,' is new and ', - 1 'unique. nalca=',i3,' Record is:'/4x,a) - - else - stidad(nadcat)=stidca(1) - write(6,515) stidad(nadcat) - 515 format('...Id for storm added to catalog =',a,' has been ', - 1 'recorded to prevent duplication.') - endif - - WRITE(IUNTCA,21) NALCA,STNMCA,IDATMN,IUTCMN,IDATMX,IUTCMX, - 1 (RSMCCA(NAL),STIDCA(NAL), - 2 NAL=1,MIN(NALCA,NOVRMX)) - WRITE(6,293) NCAT+NADCAT,NALCA,STNMCA,IDATMN,IUTCMN,IDATMX, - 1 IUTCMX,(RSMCCA(NAL),STIDCA(NAL), - 2 NAL=1,MIN(NALCA,NOVRMX)) - endif - - if(nrec .le. nokay) then - okarec(nrec)=bufinz - else - badrec(nrec-nokay)=bufinz - endif - - iecat(nrec)=-iabs(iecat(nrec)) - endif - endif - - enddo -c** write(6,601) nadcat,naladd -c 601 format('...',i3,' new storms added to catalog. ',i3,' bang ', -c 1 'storms added to temporary alias file.'/4x,'Dump alias ' -c 2 'records to temporary alias file if necessary (naladd>0).' - write(6,601) nadcat - 601 format('...',i3,' new storms added to catalog.') - -c Finally, storm catalog and alias file (akavit) reconciliation. -c We force the alias file to be a direct subset of the storm -c catalog. - -c write(6,703) -c 703 format(/'...Storm catalog and alias file reconciliation. '/4x, -c 1 'Copy temporary alias file records to the new alias file', -c 2 ' if necessary.') - - iuntaw=iuntal - rewind iuntca - rewind iuntaw - - 720 read(iuntca,21,end=830) nalca,stmnmz,iymdmn,iutcmn,iymdca,iutcca, - 1 (rsmcca(nca),stidca(nca), - 2 nca=1,min(nalca,novrmx)) - if(rsmcca(1)(1:1) .eq. '!') write(iuntaw,711) nalca,stmnmz, - 1 (rsmcca(nca),stidca(nca), - 2 nca=1,min(nalca,novrmx)) - 711 format(i1,1x,a9,10(1x,a4,1x,a3)) - -c** ifndca=0 - -c if(stmnmz .eq. stnmal .and. -c 1 stidca(1) .eq. stidal(1)) then -c ifndz=0 -c write(6,801) stmnmz,stidca(1) -c 801 format('...Alias file and catalog have the same storm and basin ', -c 1 'id=',a,1x,a) - -c do nc=1,nalca -c if(rsmcal(nc) .eq. rsmcca(nc) .and. -c 1 stidal(nc) .eq. stidca(nc)) then -c ifndz=ifndz+1 -c endif -c enddo - -c if(ifndz .eq. nalca) then -c ifndca=1 -c go to 831 -c endif -c** endif - - go to 720 - 830 continue -cc831 continue - -c** if(ifndca .eq. 0) then -c write(6,833) nalca,stmnmz,(rsmcca(nca),stidca(nca), -c 1 nca=1,min(nalca,novrmx)) -c write(6,835) nalmx,stnmal,(rsmcal(nal),stidal(nal), -c 3 nal=1,min(nalmx,novrmx)) -c 833 format('******Storm in alias file but different or not in ', -c 1 'catalog. Catalog entry is:'/4x,i1,1x,a9,10(1x,a4,1x,a3) -c 835 format('Alias entry is:'/4x,i1,1x,a9,10(1x,a4,1x,a3)) -c call abort1(' RCNCIL',835) - -c else -c write(6,841) nalmx,stnmal,(rsmcal(nal),stidal(nal), -c 1 nal=1,min(nalmx,novrmx)) -c 841 format('...Alias file entry is identical to catalog. Entry is:'/ -c 1 4x,i1,1x,a9,10(1x,a4,1x,a3)) -c endif -c** go to 710 - -c Error summary - - write(6,901) nokay,ntest,nadd,(ercrcn(ner),ner=1,nercrc) - 901 format(//'...Results of the catalog reconciliation check are: ', - 1 'nokay=',i4,', ntest=',i4,', nadd=',i3//4x,'Error codes ', - 2 'are:'/(6x,a)) - write(6,903) - 903 format(/'...Okay records are:',100x,'erc'/) - do nok=1,nokay - write(6,909) nok,numoka(nok),okarec(nok),iefail(numoka(nok),5) - 909 format(3x,i4,'...',i4,'...',a,'...',i3) - enddo - - write(6,913) - 913 format(/'...Updated overland or overlapped (bad) records are:', - 1 68x,'erc') - do nba=1,nbad - if(iefail(numbad(nba),4) .eq. 5 .or. - 1 iefail(numbad(nba),4) .eq. 6 .or. - 2 iefail(numbad(nba),6) .eq. 22) then - write(6,919) nba,numbad(nba),badrec(nba),iefail(numbad(nba),5) - 919 format(3x,i4,'...',i4,'...',a,'...',i3) - endif - enddo - - write(6,923) - 923 format(/'...Added records due to duplicate storm id are:',73x, - 1 'erc'/) - do nad=1,nadd - write(6,929) nad,numbad(nbad+nad),badrec(nbad+nad), - 1 iabs(iefail(numbad(nbad+nad),5)) - 929 format(3x,i4,'...',i4,'...',a,'...',i3) - enddo - nbad=nbad+nadd - - return - end - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: MNMXDA SUBSTITUTES MIN OR MAX DATE -C PRGMMR: S. LORD ORG: NP22 DATE: 1993-06-01 -C -C ABSTRACT: SUBSTITUTES MIN OR MAX DATE -C -C PROGRAM HISTORY LOG: -C 1993-06-01 S. LORD -C -C USAGE: CALL MNMXDA(IYMDNX,IUTCNX,IYMDZ,IUTCZ,DAYZ,MINMAX) -C INPUT ARGUMENT LIST: -C IYMDNX - MINIMUM YEAR,MONTH,DAY. -C -C IUTCNX - MINIMUM HOUR (UTC). -C IYMDZ - INPUT YEAR,MONTH,DAY. -C -C IUTCZ - INPUT HOUR (UTC). -C -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - subroutine mnmxda(iymdnx,iutcnx,iymdz,iutcz,dayz,minmax) - - DIMENSION RINC(5) - -c in minmax<0, minimum is returned -c in minmax>0, minimum is returned - - call ztime(iymdnx,iutcnx,iyr,imo,ida,ihr,imin) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - call flday(jdy,ihr,imin,daynx) - - call ztime(iymdz,iutcz,iyr,imo,ida,ihr,imin) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - call flday(jdy,ihr,imin,dayz) - - if(minmax .gt. 0) then - if(dayz .gt. daynx) then - write(6,11) iymdnx,iutcnx,iymdz,iutcz - 11 format('...Substituting maximum date. iymdnx,iutcnx,iymdz,iutcz=', - 1 2(i9,i6.4)) - iymdnx=iymdz - iutcnx=iutcz - else -c write(6,13) iymdnx,iutcnx,iymdz,iutcz -c 13 format('...No substitution of maximum date. iymdnx,iutcnx,iymdz,', -c 1 'iutcz=',2(i9,i6.4)) - endif - - else if(minmax .lt. 0) then - if(dayz .lt. daynx) then - write(6,21) iymdnx,iutcnx,iymdz,iutcz - 21 format('...Substituting minimum date. iymdnx,iutcnx,iymdz,iutcz=', - 1 2(i9,i6.4)) - iymdnx=iymdz - iutcnx=iutcz - else -c write(6,23) iymdnx,iutcnx,iymdz,iutcz -c 23 format('...No substitution of minimum date. iymdnx,iutcnx,iymdz,', -c 1 'iutcz=',2(i9,i6.4)) - endif - - else - write(6,31) minmax - 31 format('******minmax value=',i5,' is improper. abort.') - CALL ABORT1(' MNMXDA',31) - endif - - return - end - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: SCLIST LISTS STORM CATALOG -C PRGMMR: S. LORD ORG: NP22 DATE: 1993-06-01 -C -C ABSTRACT: LISTS STORM CATALOG -C -C PROGRAM HISTORY LOG: -C 1993-06-01 S. LORD -C -C USAGE: CALL SCLIST(IUNTCA) -C INPUT ARGUMENT LIST: -C IUNTCA - UNIT NUMBER FOR CATALOG. -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - subroutine sclist(iuntca) - parameter (novrmx=70) - - character stnmca*9,stidca*3,rsmcca*4 - dimension stidca(novrmx),rsmcca(novrmx) - - rewind iuntca - nrec=0 - - write(6,1) iuntca - 1 format(/'...Storm catalog list for unit ',i3) - 10 continue - READ(IUNTCA,21,END=90) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX, - 1 (RSMCCA(NAL),STIDCA(NAL), - 2 NAL=1,MIN(NALCA,NOVRMX)) - nrec=nrec+1 - 21 FORMAT(I1,1X,A9,2(1X,I8,1X,I4.4),10(1X,A4,1X,A3)) - write(6,23) nrec,NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX, - 1 (RSMCCA(NAL),STIDCA(NAL), - 2 NAL=1,MIN(NALCA,NOVRMX)) - 23 FORMAT(3x,i4,2x,I1,1X,A9,2(1X,I8,1X,I4.4),10(1X,A4,1X,A3)) - go to 10 - - 90 continue - write(6,91) - 91 format('...End of storm catalog list.'/) - rewind iuntca - return - end - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AKLIST LISTS ALIAS FILE -C PRGMMR: S. LORD ORG: NP22 DATE: 1993-06-01 -C -C ABSTRACT: LISTS ALIAS FILE -C -C PROGRAM HISTORY LOG: -C 1993-06-01 S. LORD -C -C USAGE: CALL AKLIST(IUNTAL) -C INPUT ARGUMENT LIST: -C IUNTAL - UNIT NUMBER FOR ALIAS FILE. -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - subroutine aklist(iuntal) - parameter (novrmx=70) - - character stnmal*9,stidal*3,rsmcal*4 - dimension stidal(novrmx),rsmcal(novrmx) - - rewind iuntal - nrec=0 - - write(6,1) iuntal - 1 format(/'...Storm alias list for unit ',i3) - 10 continue - READ(IUNTAL,21,END=90) NALAL,STNMAL,(RSMCAL(NAL),STIDAL(NAL), - - 1 NAL=1,MIN(NALAL,NOVRMX)) - nrec=nrec+1 - 21 FORMAT(I1,1X,A9,10(1X,A4,1X,A3)) - write(6,23) nrec,NALAL,STNMAL,(RSMCAL(NAL),STIDAL(NAL), - 1 NAL=1,MIN(NALAL,NOVRMX)) - 23 FORMAT(3x,i4,2x,I1,1X,A9,10(1X,A4,1X,A3)) - go to 10 - - 90 continue - write(6,91) - 91 format('...End of storm alias list.'/) - rewind iuntal - return - end - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: STCATI GETS STORM ID FROM CATALOG -C PRGMMR: S. LORD ORG: NP22 DATE: 1993-06-01 -C -C ABSTRACT: LOOKS FOR GIVEN STORM ID AND RSMC IN CATALOG -C -C PROGRAM HISTORY LOG: -C 1993-06-01 S. LORD -C -C USAGE: CALL STCATI(IUNTCA,STMIDZ,RSMCZ,STMIDX,IFND) -C INPUT ARGUMENT LIST: -C IUNTCA - UNIT NUMBER FOR STORM CATALOG. -C -C STMIDZ - REQUESTED STORM ID. -C RSMCZ - REQUESTED RSMC. -C -C OUTPUT ARGUMENT LIST: -C STMIDX - CATALOGED STORM ID. -C IFND - 1 IF FOUND. -C - THE RSMC CHECK. -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - subroutine stcati(iuntca,stmidz,rsmcz,stmidx,ifnd) - - parameter (novrmx=70) - - dimension rsmcca(novrmx),stidca(novrmx) - - character stmidz*(*),stmidx*(*),rsmcz*(*) - character stnmca*9,stidca*3,rsmcca*4 - - ifnd=0 - rewind iuntca - write(6,1) stmidz,rsmcz - 1 format('...Entering stcati looking for storm id,rsmc=',2(a,2x)) - 10 continue - READ(IUNTCA,21,END=90) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX, - 1 (RSMCCA(NCA),STIDCA(NCA), - 2 NCA=1,MIN(NALCA,NOVRMX)) - 21 FORMAT(I1,1X,A9,2(1X,I8,1X,I4.4),10(1X,A4,1X,A3)) - do nca=1,min(nalca,novrmx) - if(stmidz .eq. stidca(nca) .and. rsmcz .eq. rsmcca(nca)) then - ifnd=1 - stmidx=stidca(1) - rewind iuntca - return - endif - enddo - go to 10 - - 90 continue - - rewind iuntca - return - end - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: STCATN GETS STORM NAME AND LAST DATE FROM CATLG -C PRGMMR: S. LORD ORG: NP22 DATE: 1993-08-25 -C -C ABSTRACT: LOOKS FOR GIVEN STORM ID AND RSMC IN CATALOG -C -C PROGRAM HISTORY LOG: -C 1993-08-25 S. LORD -C -C USAGE: CALL STCATN(IUNTCA,STMNMZ,IDATEZ,IUTCZ,IFND) -C INPUT ARGUMENT LIST: -C IUNTCA - UNIT NUMBER FOR STORM CATALOG. -C STMNMZ - REQUESTED STORM NAME. -C -C OUTPUT ARGUMENT LIST: -C IDATEZ - LATEST DATE FOUND FOR NAMED STORM. -C IUTCZ - LATEST HHMM FOUND FOR NAMED STORM. -C IFND - 1 IF FOUND. -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE STCATN(IUNTCA,STMNMZ,IDATEZ,IUTCZ,IFND) - - character STMNMZ*(*) - character stnmca*9 - - ifnd=0 - IDATEZ=-999999 - IUTCZ=-999 - rewind iuntca - write(6,1) STMNMZ - 1 format('...Entering stcatn looking for storm name=',a) - 10 continue - READ(IUNTCA,21,END=90) NALCA,STNMCA,IYMDMN,IUTCMN,IYMDMX,IUTCMX - 21 FORMAT(I1,1X,A9,2(1X,I8,1X,I4.4)) - if(STNMCA .eq. STMNMZ) then - ifnd=1 - IDATEZ=IYMDMX - IUTCZ=IUTCMX - endif - go to 10 - - 90 continue - - rewind iuntca - return - end - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: ADFSTF ADDS FIRST OCCURRENCE FLAGS TO RECORDS -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-07 -C -C ABSTRACT: ADDS FIRST OCCURRENCE FLAGS TO RECORDS AS APPROPRIATE, -C EVEN IF A FLAG HAS BEEN CLASSIFIED AS A BAD RECORD. -C -C PROGRAM HISTORY LOG: -C 1991-06-07 S. J. LORD -C 1991-06-07 S. J. LORD DISABLED FIRST FLAGS FOR RELOCATED STORMS -C -C USAGE: CALL ADFSTF(IUNTHA,NOKAY,NBAD,MAXREC,MAXCKS,IECOST,NUMBAD, -c IEFAIL,DUMREC,OKAREC,BADREC) -C INPUT ARGUMENT LIST: -C IUNTHA - UNIT NUMBER FOR THE ALIAS SHORT-TERM HISTORY FILE -C NOKAY - LENGTH OF ARRAY OKAREC -C NBAD - LENGTH OF ARRAY BADREC AND NUMBAD -C MAXREC - LENGTH OF FIRST DIMENSION OF ARRAY IEFAIL -C MAXCKS - LENGTH OF SECOND DIMENSION OF ARRAY IEFAIL -C IECOST - ERROR CODE FOR OVERLAND (COASTAL) TROPICAL CYCLONE -C - POSITIONS -C NUMBAD - ARRAY CONTAINING INDEX NUMBER OF EACH BAD RECORD -C IEFAIL - 2-D ARRAY OF ERROR CODES FOR ALL RECORDS -C DUMREC - DUMMY CHARACTER VARIABLE FOR READING SHORT-TERM -C - HISTORY RECORDS -C OKAREC - CHARACTER ARRAY OF OK RECORDS, RECORDS THAT HAVE -C - PASSES ALL Q/C CHECKS SO FAR -C BADREC - CHARACTER ARRAY OF BAD RECORDS, RECORDS THAT HAVE -C - FAILED AT LEAST ONE Q/C CHECK SO FAR -C -C OUTPUT ARGUMENT LIST: -C DUMREC - DESCRIPTION AS ABOVE -C OKAREC - SAME AS INPUT, EXCEPT FIRST OCCURENCE FLAG MAY HAVE -C - BEEN ADDED -C BADREC - SAME AS INPUT, EXCEPT FIRST OCCURENCE FLAG MAY HAVE -C - BEEN ADDED IN THE CASE OF OVER-LAND (COASTAL) STORMS -C -C INPUT FILES: -C UNIT "IUNTHA" - SHORT-TERM HISTORY FILE -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE ADFSTF(IUNTHA,NOKAY,NBAD,MAXREC,MAXCKS,IECOST,NUMBAD, - 1 IEFAIL,DUMREC,OKAREC,BADREC) - - SAVE - - LOGICAL FOUNDO,FOUNDB - - CHARACTER*(*) DUMREC,OKAREC(NOKAY),BADREC(NBAD) - CHARACTER*100 DUMY2K - - PARAMETER (MAXCHR=95) - PARAMETER (MAXVIT=15) - - CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1, - 1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1 - - DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT) - - DIMENSION BUFIN(MAXCHR),FMTVIT(MAXVIT) - - EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ), - 1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ), - 2 (BUFIN(37),LATNS),(BUFIN(43),LONEW), - 3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ) - - EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ) - - DIMENSION IEFAIL(MAXREC,0:MAXCKS),NUMBAD(NBAD) - - DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)', - 1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/, - 2 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/, - 3 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/, - 4 IFSTFL/19/,ISTID/6/,IENID/8/ - - DATA NUM/1/ - - WRITE(6,1) NOKAY,NBAD,IECOST - 1 FORMAT(/'...ENTERING ADFSTF WITH NOKAY,NBAD,IECOST=',3I4/4X, - 1 'WARNING: FIRST OCCURRENCE FLAGS (FOF) MAY OR MAY NOT BE', - 2 ' PRESENT IN THE ORIGINAL SHORT-TERM ALIAS FILE DUE TO ', - 3 'THIS ROUTINE.'/4X,'RELIABLE FOFS ARE PRESENT ONLY IN ', - 4 'THE ALIAS SHORT-TERM HISTORY FILE.') - -C CHECK EACH ALIAS SHORT-TERM HISTORY RECORD FIRST VERSUS THE -C "OKAY" RECORDS AND SECOND VERSUS THE "BAD" RECORDS THAT -C HAVE ONLY AN OVER COAST ERROR - - DO NOK=1,NOKAY - BUFINZ=OKAREC(NOK) - FOUNDO=.FALSE. - REWIND IUNTHA - NREC=0 - - 10 CONTINUE - - READ(IUNTHA,11,END=90) DUMREC - 11 FORMAT(A) - -C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20 -C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR -C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF -C LATITUDE N/S INDICATOR TO FIND OUT ... - - IF(DUMREC(35:35).EQ.'N' .OR. DUMREC(35:35).EQ.'S') THEN - -C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR - -C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE -C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 2-digit year "',DUMREC(20:21),'"' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntha,'; DUMREC-4: ',dumrec - PRINT *, ' ' - DUMY2K(1:19) = DUMREC(1:19) - IF(DUMREC(20:21).GT.'20') THEN - DUMY2K(20:21) = '19' - ELSE - DUMY2K(20:21) = '20' - ENDIF - DUMY2K(22:100) = DUMREC(20:100) - DUMREC = DUMY2K - PRINT *, ' ' - PRINT *, '==> 2-digit year converted to 4-digit year "', - $ DUMREC(20:23),'" via windowing technique' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntha,'; DUMREC-4: ',dumrec - PRINT *, ' ' - - ELSE IF(DUMREC(37:37).EQ.'N' .OR. DUMREC(37:37).EQ.'S') THEN - -C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR -C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 4-digit year "',DUMREC(20:23),'"' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntha,'; DUMREC-4: ',dumrec - PRINT *, ' ' - PRINT *, '==> No conversion necessary' - PRINT *, ' ' - - ELSE - - PRINT *, ' ' - PRINT *, '***** Cannot determine if this record contains ', - $ 'a 2-digit year or a 4-digit year - skip it and try reading ', - $ 'the next record' - PRINT *, ' ' - GO TO 10 - - END IF - - NREC=NREC+1 - IF(STMIDZ .EQ. DUMREC(ISTID:IENID) .AND. - 1 DUMREC(IFSTFL:IFSTFL) .NE. '*') THEN - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 DUMREC) - ENDDO - IDTDUM=IDATEZ - IUTDUM=IUTCZ - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 OKAREC(NOK)) - ENDDO - -C IF THERE ARE DUPLICATE DATES, THEN WE ASSUME THE OKAY RECORD -C IS AN UPDATED RECORD AND WE TRANSFER THE FIRST OCCURRENCE -C FLAG TO THE UPDATED RECORD. THIS CREATES A PARTIAL -C DUPLICATE RECORD THAT WILL BE DEALT WITH IN RITSTH. - - IF(IDATEZ .EQ. IDTDUM .AND. IUTCZ .EQ. IUTDUM) THEN - OKAREC(NOK)(IFSTFL:IFSTFL)=DUMREC(IFSTFL:IFSTFL) - ELSE - FOUNDO=.TRUE. - ENDIF - ENDIF - -C WRITE(6,87) NOK,FOUNDO,DUMREC,OKAREC(NOK) -C 87 FORMAT('...CHECKING FOR FIRST OCCURRENCE, NOK,FOUNDO,DUMREC,', -C 1 'OKAREC=',I3,1X,L1/4X,A/4X,A) - GO TO 10 - - 90 CONTINUE - -C IF THERE ARE NO MATCHING STORMS IN THE SHORT-TERM HISTORY FILE, -C FIND THE EARLIEST STORM IN THE OKAY RECORDS - - IF(.NOT. FOUNDO) THEN - CALL FSTSTM(NOKAY,NOK,NFIRST,OKAREC) - OKAREC(NFIRST)(IFSTFL:IFSTFL)=':' - ENDIF - - ENDDO - - DO NBA=1,NBAD - - IF(IEFAIL(NUMBAD(NBA),4) .EQ. IECOST) THEN - - DO NCK=1,MAXCKS - IF(NCK .NE. 4 .AND. IEFAIL(NUMBAD(NBA),NCK) .GT. 0) GO TO 200 - ENDDO - - BUFINZ=BADREC(NBA) - REWIND IUNTHA - FOUNDB=.FALSE. - NREC=0 - - 160 CONTINUE - - READ(IUNTHA,11,END=190) DUMREC - NREC=NREC+1 - -C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20 -C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR -C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF -C LATITUDE N/S INDICATOR TO FIND OUT ... - - IF(DUMREC(35:35).EQ.'N' .OR. DUMREC(35:35).EQ.'S') THEN - -C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR - -C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE -C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 2-digit year "',DUMREC(20:21),'"' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntha,'; DUMREC-5: ',dumrec - PRINT *, ' ' - DUMY2K(1:19) = DUMREC(1:19) - IF(DUMREC(20:21).GT.'20') THEN - DUMY2K(20:21) = '19' - ELSE - DUMY2K(20:21) = '20' - ENDIF - DUMY2K(22:100) = DUMREC(20:100) - DUMREC = DUMY2K - PRINT *, ' ' - PRINT *, '==> 2-digit year converted to 4-digit year "', - $ DUMREC(20:23),'" via windowing technique' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntha,'; DUMREC-5: ',dumrec - PRINT *, ' ' - - ELSE IF(DUMREC(37:37).EQ.'N' .OR. DUMREC(37:37).EQ.'S') THEN - -C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR -C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 4-digit year "',DUMREC(20:23),'"' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntha,'; DUMREC-5: ',dumrec - PRINT *, ' ' - PRINT *, '==> No conversion necessary' - PRINT *, ' ' - - ELSE - - PRINT *, ' ' - PRINT *, '***** Cannot determine if this record contains ', - $ 'a 2-digit year or a 4-digit year - skip it and try reading ', - $ 'the next record' - PRINT *, ' ' - GO TO 160 - - END IF - - IF(STMIDZ .EQ. DUMREC(ISTID:IENID) .AND. - 1 DUMREC(IFSTFL:IFSTFL) .NE. '*') THEN - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 DUMREC) - ENDDO - IDTDUM=IDATEZ - IUTDUM=IUTCZ - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 BADREC(NBA)) - ENDDO - -C IF THERE ARE DUPLICATE DATES, THEN WE ASSUME THE BAD RECORD -C IS AN UPDATED RECORD AND WE TRANSFER THE FIRST OCCURRENCE -C FLAG TO THE UPDATED RECORD. THIS CREATES A PARTIAL -C DUPLICATE RECORD THAT WILL BE DEALT WITH IN RITSTH. - - IF(IDATEZ .EQ. IDTDUM .AND. IUTCZ .EQ. IUTDUM) THEN - BADREC(NBA)(IFSTFL:IFSTFL)=DUMREC(IFSTFL:IFSTFL) - ELSE - FOUNDB=.TRUE. - ENDIF - ENDIF - -C WRITE(6,187) NBA,DUMREC,BADREC(NBA) -C 187 FORMAT('...CHECKING FOR FIRST OCCURRENCE, NBA,DUMREC,BADREC=',I3/ -C 1 4X,A/4X,A) - GO TO 160 - - 190 CONTINUE - -C IF THERE ARE NO MATCHING STORMS IN THE SHORT-TERM HISTORY FILE, -C FIND THE EARLIEST STORM IN THE BAD RECORDS - - IF(.NOT. FOUNDB) THEN - CALL FSTSTM(NBAD,NBA,NFIRST,BADREC) - BADREC(NFIRST)(IFSTFL:IFSTFL)='*' - ENDIF - - ENDIF - 200 CONTINUE - ENDDO - -C IF THERE ARE NO RECORDS IN THE SHORT-TERM HISTORY FILE, -C WE MUST ASSIGN A FIRST OCCURRENCE FLAG TO EACH STORM - - IF(NREC .EQ. 0) THEN - DO NOK=1,NOKAY - CALL FSTSTM(NOKAY,NOK,NFIRST,OKAREC) - OKAREC(NFIRST)(IFSTFL:IFSTFL)=':' - ENDDO - ENDIF - -C ADD FIRST OCCURRENCE FLAGS FOR RELOCATED STORMS -C DISABLED 4-9-93 - -C DO NOK=1,NOKAY -C BUFINZ=OKAREC(NOK) -C IF(RELOCZ .EQ. 'R') OKAREC(NOK)(IFSTFL:IFSTFL)=':' -C ENDDO - -C VERY SPECIAL CASE: NO RECORDS IN THE SHORT-TERM HISTORY FILE -C AND A RECORD HAS AN OVER LAND ERROR - - IF(NREC .EQ. 0) THEN - DO NBA=1,NBAD - - IF(IEFAIL(NUMBAD(NBA),4) .EQ. IECOST) THEN - - DO NCK=1,MAXCKS - IF(NCK .NE. 4 .AND. IEFAIL(NUMBAD(NBA),NCK) .GT. 0) GO TO 400 - ENDDO - - BADREC(NBA)(IFSTFL:IFSTFL)='*' - - ENDIF - 400 CONTINUE - ENDDO - ENDIF - - WRITE(6,401) NOKAY,NBAD,NREC - 401 FORMAT(/'...LEAVING ADFSTF, NOKAY, NBAD=',2I4/4X,I3,' RECORDS ', - 1 'READ FROM ALIAS SHORT-TERM HISTORY FILE.') - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FSTSTM FINDS FIRST OCCURRENCE FOR A STORM -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-07-18 -C -C ABSTRACT: FINDS FIRST OCCURRENCE OF A PARTICULAR STORM BY PICKING -C OUT THE MINIMUM TIME. -C -C PROGRAM HISTORY LOG: -C 1991-07-18 S. J. LORD -C -C USAGE: CALL FSTSTM(NRCMX,NRCSTM,NFIRST,DUMREC) -C INPUT ARGUMENT LIST: -C NRCMX - LENGTH OF ARRAY DUMREC -C NRCSTM - INDEX OF THE RECORD CONTAINING THE DESIRED STORM -C DUMREC - ARRAY OF INPUT RECORDS -C -C OUTPUT ARGUMENT LIST: -C NFIRST - INDEX OF THE FIRST RECORD FOR THE DESIRED STORM -C DUMREC - DESCRIPTION AS ABOVE -C -C REMARKS: NONE -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE FSTSTM(NRCMX,NRCSTM,NFIRST,DUMREC) - - CHARACTER*(*) DUMREC(NRCMX) - - DIMENSION RINC(5) - - SAVE - - PARAMETER (MAXCHR=95) - PARAMETER (MAXVIT=15) - - CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1, - 1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1 - - DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT) - - DIMENSION BUFIN(MAXCHR),FMTVIT(MAXVIT) - - EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ), - 1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ), - 2 (BUFIN(37),LATNS),(BUFIN(43),LONEW), - 3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ) - - EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ) - - DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)', - 1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/, - 2 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/, - 3 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/, - 4 ISTID/6/,IENID/8/ - - DATA NUM/1/ - -C WRITE(6,1) NRCMX,NRCSTM -C 1 FORMAT(/'...ENTERING FSTSTM WITH NRCMX,NRCSTM=',2I4) - - DAYFST=1.0E10 - -C PICK OUT THE RECORD WITH THE MINIMUM DATE FOR THE CHOSEN STORM - - DO NCOM=1,NRCMX - BUFINZ=DUMREC(NCOM) - IF(STMIDZ .EQ. DUMREC(NRCSTM)(ISTID:IENID)) THEN - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 BUFINZ) - ENDDO - CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYZ) - IF(DAYZ .LE. DAYFST) THEN - NFIRST=NCOM - DAYFST=DAYZ - ENDIF - ENDIF - ENDDO - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: RITCUR WRITES Q/C RECORDS TO CURRENT DATA FILE -C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01 -C -C ABSTRACT: WRITES CURRENT QUALITY CONTROLLED RECORDS TO THE CURRENT -C FILE (UNIT 60). -C -C PROGRAM HISTORY LOG: -C 1990-11-01 S. LORD -C 1991-07-22 S. LORD ADDED IDATEZ,IUTCZ TO ARGUMENT LIST -C 1992-07-01 S. LORD REVISION FOR TIME WINDOW -C -C USAGE: CALL RITCUR(IUNTRD,IUNTCU,NTEST,NOKAY,NBAD,IDATCU,JUTCCU,DAY0, -C MAXREC,IFLLCK,NUMTST,NUMOKA,NUMBAD,FILES,LNDFIL, -C ZZZREC,NNNREC,DUMREC,SCRREC,TSTREC,OKAREC,BADREC) -C INPUT ARGUMENT LIST: -C IUNTRD - UNIT NUMBER FOR READING RECORDS -C IUNTCU - UNIT NUMBER FOR CURRENT DATA FILE -C NTEST - NUMBER OF INPUT RECORDS (>0 FOR FILES=FALSE OPTION, -C - =0 FOR FILES=TRUE OPTION) -C IDATCU - DATE (YYYYMMDD) FOR ACCEPTANCE WINDOW -C JUTCCU - UTC (HHMMSS) FOR ACCEPTANCE WINDOW -C DAY0 - DATE OF ACCEPTANCE WINDOW -C MAXREC - DIMENSION OF INPUT ARRAYS -C FILES - LOGICAL VARIABLE, TRUE IF UPDATED SHORT-TERM HISTORY -C FILE HAS BEEN CREATED -C LNDFIL - LOGICAL VARIABLE, TRUE IF OVER-LAND FILTER SHOULD BE -C APPLIED TO CURRENT RECORDS. -C RECORDS TO THE CURRENT FILE -C DUMREC - CHARACTER VARIABLE -C TSTREC - CHARACTER ARRAY (LENGTH MAXREC) OF INPUT RECORDS. ONLY -C - THE FIRST NTEST ARE VALID IN THE CASE OF FILES=.FALSE. -C NUMTST - INDEX FOR ARRAY TSTREC -C ZZZREC - CHARACTER VARIABLE CONTAINING HEADER INFO -C NNNREC - CHARACTER VARIABLE CONTAINING COLUMN INFO -C -C OUTPUT ARGUMENT LIST: -C OKAREC - CONTAINS CANDIDATE QUALITY CONTROLLED RECORDS COPIED -C - TO THE CURRENT FILE -C NOKAY - NUMBER OF OKAY RECORDS -C NBAD - NUMBER OF RECORDS THAT FAILED THE OVERLAND CHECK -C IFLLCK - CONTAINS FAILURE CODE OF BAD RECORDS -C BADREC - ARRAY CONTAINING BAD RECORDS -C SCRREC - SCRATCH ARRAY CONTAINING STORM IDS AND NAMES -C NUMOKA - ARRAY CONTAINING INDICES OF OKAY RECORDS -C NUMBAD - ARRAY CONTAINING INDICES OF BAD RECORDS -C -C INPUT FILES: -C UNIT 20 - SCRATCH FILE CONTAINING QUALITY CONTROLLED RECORDS -C - IUNTRD POINTS TO THIS FILE WHEN FILES=.TRUE. -C UNIT 22 - ALIAS SHORT-TERM HISTORY FILE CONTAINING RECORDS -C - PROCESSED BY THIS PROGRAM FOR THE LAST SEVERAL DAYS. -C - IUNTRD POINTS TO THIS FILE WHEN FILES=.FALSE. -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C UNIT 60 - QUALITY CONTROLLED RECORDS (IUNTCU) -C -C REMARKS: IF LENGTH OF OUTPUT RECORDS (MAXCHR) EXCEEDS THE DESIGNATED -C RECORD LENGTH FOR THE FILE (MAXSPC), THIS SUBROUTINE WILL -C PRINT A NASTY MESSAGE AND CALL AN ABORT1 PROGRAM THAT GIVES -C A RETURN CODE OF 20 FOR THIS PROGRAM EXECUTION. UNDER -C THE FILES=TRUE OPTION, RECORDS ARE READ FROM THE SCRATCH -C FILE, DATE CHECKED, CHECKED FOR OVERLAND POSITIONS IF NEED -C BE, AND THEN WRITTEN TO THE CURRENT FILE. UNDER THE FILES= -C FALSE OPTION, ALL RECORDS PROCESSED BY THE PRESENT RUN OF -C THIS PROGRAM MAY BE WRITTEN IN ADDITION TO SOME RECORDS FROM -C THE ALIAS SHORT-TERM HISTORY FILE. IN BOTH OPTIONS, ONLY THE -C LATEST STORM RECORD IS WRITTEN. ALL RECORDS LIE IN A TIME -C WINDOW GIVEN BY DAY0. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE RITCUR(IUNTRD,IUNTCU,NTEST,NOKAY,NBAD,IDATCU,JUTCCU, - 1 DAY0,MAXREC,IFLLCK,NUMTST,NUMOKA,NUMBAD,FILES, - 2 LNDFIL,ZZZREC,NNNREC,DUMREC,SCRREC,TSTREC, - 3 OKAREC,BADREC) - - PARAMETER (MAXSPC=100) - - SAVE - - LOGICAL FIRST,FILES,LNDFIL,FOUND - - CHARACTER*(*) TSTREC(0:MAXREC),OKAREC(MAXREC),BADREC(MAXREC), - 1 ZZZREC,NNNREC,DUMREC,SCRREC(0:MAXREC) - CHARACTER*100 DUMY2K - - PARAMETER (MAXCHR=95) - PARAMETER (MAXVIT=15) - - CHARACTER FMTVIT*6 - - DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT) - - DIMENSION FMTVIT(MAXVIT) - - EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ) - - DIMENSION IFLLCK(MAXREC),NUMTST(MAXREC),NUMOKA(MAXREC), - 1 NUMBAD(MAXREC) - - DIMENSION RINC(5) - - DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)', - 2 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/, - 3 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/, - 4 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/, - 5 ISTID/6/,IENID/8/ - - DATA FIRST/.TRUE./,NUM/1/,FIVMIN/3.4722E-3/ - - WRITE(6,1) IUNTRD,IUNTCU,FILES,LNDFIL,IDATCU,JUTCCU,DAY0 - 1 FORMAT(/'...ENTERING RITCUR WITH IUNTRD,IUNTCU,FILES,LNDFIL,', - 1 'IDATCU,JUTCCU,DAY0',2I3,2L2,I9,I7,F10.3) - - IF(FIRST) THEN - FIRST=.FALSE. - IF(MAXCHR .GT. MAXSPC) THEN - WRITE(6,5) MAXCHR,MAXSPC - 5 FORMAT(/'******INSUFFICIENT SPACE ALLOCATED FOR CURRENT HISTORY ', - 1 'FILE.'/7X,'MAXCHR, AVAILABLE SPACE ARE:',2I4) - CALL ABORT1(' RITCUR',1) - ENDIF - - ENDIF - -C RITCUR USES EITHER OF TWO POSSIBLE SOURCES FOR CURRENT RECORDS: -C 1) IF FILES=.TRUE., THE SCRATCH FILE (IUNTOK) CONTAINS -C ALL THE CURRENT RECORDS, INCLUDING THOSE PROCESSED BY A -C PREVIOUS RUN OF THIS PROGRAM. HOWEVER, A POSSIBILITY -C EXISTS THAT A CURRENT COASTAL RECORD MAY BE IN THE -C SCRATCH FILE. THEREFORE, THERE IS AN OPTIONAL FILTER -C (LNDFIL) BY USING A CALL TO SELACK TO WEED OUT THESE -C RECORDS. - -C 2) IF FILES=.FALSE., THE CURRENT RECORDS ARE THOSE -C PROCESSED BY THE PRESENT RUN OF THIS PROGRAM (OKAREC) -C AND CANDIDATES FROM THE ALIAS SHORT-TERM HISTORY FILE. - -C IN EITHER CASE, ONLY THE LATEST RECORD FOR EACH STORM IS -C WRITTEN. - - REWIND IUNTCU - REWIND IUNTRD - NUNIQ=0 - SCRREC(NUNIQ)='ZZZ' - print *, ' ' - print *, ' ' - - 10 CONTINUE - - READ(IUNTRD,11,END=100) DUMREC - 11 FORMAT(A) - -C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20 -C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR -C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF -C LATITUDE N/S INDICATOR TO FIND OUT ... - - IF(DUMREC(35:35).EQ.'N' .OR. DUMREC(35:35).EQ.'S') THEN - -C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR - -C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE -C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 2-digit year "',DUMREC(20:21),'"' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntrd,'; DUMREC-6: ',dumrec - PRINT *, ' ' - DUMY2K(1:19) = DUMREC(1:19) - IF(DUMREC(20:21).GT.'20') THEN - DUMY2K(20:21) = '19' - ELSE - DUMY2K(20:21) = '20' - ENDIF - DUMY2K(22:100) = DUMREC(20:100) - DUMREC = DUMY2K - PRINT *, ' ' - PRINT *, '==> 2-digit year converted to 4-digit year "', - $ DUMREC(20:23),'" via windowing technique' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntrd,'; DUMREC-6: ',dumrec - PRINT *, ' ' - - ELSE IF(DUMREC(37:37).EQ.'N' .OR. DUMREC(37:37).EQ.'S') THEN - -C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR -C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 4-digit year "',DUMREC(20:23),'"' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntrd,'; DUMREC-6: ',dumrec - PRINT *, ' ' - PRINT *, '==> No conversion necessary' - PRINT *, ' ' - - ELSE - - PRINT *, ' ' - PRINT *, '***** Cannot determine if this record contains ', - $ 'a 2-digit year or a 4-digit year - skip it and try reading ', - $ 'the next record' - PRINT *, ' ' - GO TO 10 - - END IF - - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 DUMREC) - ENDDO - CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYZ) - - IF(DAYZ .GE. DAY0-FIVMIN) THEN - NTEST=NTEST+1 - TSTREC(NTEST)=DUMREC - NUMTST(NTEST)=NTEST -C WRITE(6,33) NTEST,DUMREC -C 33 FORMAT('...READING FROM SCRATCH FILE'/4X,I4,'...',A,'...') - ENDIF - GO TO 10 - - 100 CONTINUE - - IF(NTEST .GT. 0) THEN - IF(LNDFIL .AND. FILES) THEN - WRITE(6,103) NTEST,NOKAY,NBAD - 103 FORMAT(/'...IN RITCUR, CALLING SELACK IN RITCUR TO CHECK FOR ', - 1 'OVERLAND POSITIONS.'/4X,'NTEST,NOKAY,NBAD=',3I4) - - CALL SELACK(NTEST,NOKAY,NBAD,IECOST,IFLLCK,NUMTST,NUMOKA,NUMBAD, - 1 LNDFIL,ZZZREC,NNNREC,TSTREC,BADREC,OKAREC) - - ELSE - DO NOK=1,NTEST - OKAREC(NOK)=TSTREC(NOK) - NUMOKA(NOK)=NOK - ENDDO - NOKAY=NTEST - ENDIF - -C PICK OUT THE UNIQUE STORMS - - DO NOK=1,NOKAY - FOUND=.FALSE. - DO NUNI=1,NUNIQ - IF(OKAREC(NOK)(ISTID:IENID) .EQ. SCRREC(NUNI)(1:IENID-ISTID+1)) - 1 FOUND=.TRUE. - ENDDO - IF(.NOT. FOUND) THEN - NUNIQ=NUNIQ+1 - SCRREC(NUNIQ)(1:IENID-ISTID+1)=OKAREC(NOK)(ISTID:IENID) - ENDIF - ENDDO - WRITE(6,151) NUNIQ - 151 FORMAT(/'...THE NUMBER OF UNIQUE STORMS IS',I4) - -C SCAN THROUGH RECORDS AND PICK OUT THE LATEST STORM RECORD FOR -C EACH UNIQUE STORM. - - WRITE(6,157) - 157 FORMAT(/'...THE FOLLOWING LATEST RECORDS FOR EACH STORM ARE ', - 1 'BEING WRITTEN TO THE CURRENT FILE:') - - DO NUNI=1,NUNIQ - DAYCHK=-1.E10 - INDXZ=-99 - DO NOK=1,NOKAY - IF(OKAREC(NOK)(ISTID:IENID) .EQ. SCRREC(NUNI)(1:IENID-ISTID+1)) - 1 THEN - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 OKAREC(NOK)) - ENDDO - CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYZ) - IF(DAYZ .GT. DAYCHK) THEN - INDXZ=NOK - DAYCHK=DAYZ - ENDIF - ENDIF - ENDDO - IF(INDXZ .GT. 0) THEN - WRITE(6,173) INDXZ,OKAREC(INDXZ)(1:MAXCHR) - WRITE(IUNTCU,177) OKAREC(INDXZ)(1:MAXCHR) - 173 FORMAT('...',I3,'...',A,'...') - 177 FORMAT(A) - - ELSE - WRITE(6,181) SCRREC(NUNI)(1:IENID-ISTID+1) - 181 FORMAT(/'###STORM ID=',A,' CANNOT BE FOUND. ABORT1') - CALL ABORT1(' RITCUR',181) - ENDIF - ENDDO - WRITE(6,221) NUNIQ,IUNTCU - 221 FORMAT(/'...',I4,' RECORDS HAVE BEEN COPIED TO THE CURRENT FILE ', - 1 '(UNIT',I3,').') - - ELSE - WRITE(6,231) - 231 FORMAT(/'...NO CURRENT RECORDS WILL BE WRITTEN.') - END FILE IUNTCU - ENDIF - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: RITSTH WRITES SHORT-TERM HISTORY FILE -C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01 -C -C ABSTRACT: WRITES ALL INPUT RECORDS AND QUALITY CONTROL MARKS -C ASSIGNED BY THIS PROGRAM TO A SCRATCH FILE THAT -C CONTAINS ALL RECENT HISTORICAL RECORDS FOR EACH STORM. -C -C PROGRAM HISTORY LOG: -C 1990-11-01 S. LORD -C -C USAGE: CALL RITSTH(IUNTHA,IUNTHO,IUNTOK,NOKAY,NBAD,DAYMIN,IECOST, -C MAXCKS,MAXREC,NUMBAD,IEFAIL,DUMREC,OKAREC,BADREC) -C INPUT ARGUMENT LIST: -C IUNTHA - UNIT NUMBER FOR THE ALIAS SHORT-TERM HISTORY FILE. -C IUNTHO - UNIT NUMBER FOR THE ORIGINAL SHORT-TERM HISTORY FILE. -C IUNTOK - UNIT NUMBER FOR THE SCRATCH FILE CONTAINING RECORDS -C - WRITTEN TO THE SHORT-TERM HISTORY FILE. -C NOKAY - NUMBER OF RECORDS THAT PASSED ALL Q/C CHECKS. -C NBAD - NUMBER OF RECORDS THAT HAVE AT LEAST ONE ERROR. -C DAYMIN - EARLIEST (MINIMUM) DATE FOR RECORDS THAT WILL BE -C - COPIED TO THE SHORT-TERM HISTORICAL FILE. -C - UNITS ARE DDD.FFF, WHERE DDD=JULIAN DAY, FFF=FRAC- -C - TIONAL DAY (E.G. .5=1200 UTC). -C IECOST - ERROR CODE FOR AN OVERLAND (COASTAL) RECORD. -C MAXCKS - NUMBER OF QUALITY CONTROL CHECKS. SECOND DIMENSION OF -C - ARRAY IEFAIL IS (0:MAXCKS). -C MAXREC - FIRST DIMENSION OF ARRAY IEFAIL. -C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD -C - RECORD. -C IEFAIL - INTEGER ARRAY CONTAINING QUALITY MARKS. INDEXING -C - IS ACCORDING TO ARRAY NUMBAD. -C DUMREC - CHARACTER VARIABLE LONG ENOUGH TO HOLD VITAL -C - STATISTICS RECORD. -C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT HAVE -C - PASSED ALL Q/C CHECKS -C BADREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT HAVE -C - FAILED AT LEAST ONE Q/C CHECK -C -C INPUT FILES: -C UNIT 22 - ALIAS SHORT=TERM HISTORY FILE -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C UNIT 20 - SCRATCH FILE -C UNIT 21 - ORIGINAL SHORT-TERM HISTORY FILE -C -C REMARKS: RECORDS ARE COPIED FROM THE CURRENT ALIAS SHORT-TERM HISTORY -C FILE TO THE SCRATCH FILE IUNTOK. THE CONTENTS OF IUNTOK -C WILL BE FINALLY BE COPIED TO THE SHORT-TERM HISTORY FILE -C BY ROUTINE FNLCPY. ORIGINAL RECORDS THAT CONTRIBUTED TO -C MAKING ALIAS RECORDS ARE COPIED TO THE ORIGINAL SHORT-TERM -C SHORT-TERM HISTORY FILE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE RITSTH(IUNTHA,IUNTHO,IUNTOK,NOKAY,NBAD,DAYMIN,IECOST, - 1 MAXCKS,MAXREC,NUMBAD,IEFAIL,DUMREC,OKAREC,BADREC) - - SAVE - - CHARACTER*(*) DUMREC,OKAREC(NOKAY),BADREC(NBAD) - - DIMENSION IEFAIL(MAXREC,0:MAXCKS),NUMBAD(NBAD) - - ICALL=2 - - REWIND IUNTOK - -C COPY ALL RECORDS FROM THE CURRENT ORIGINAL SHORT-TERM HISTORY -C FILE TO A SCRATCH FILE (IUNTOK) FOR TEMPORARY STORAGE. - - WRITE(6,1) DAYMIN,ICALL - 1 FORMAT(/'...THE FOLLOWING RECORDS, HAVING DATES GREATER THAN OR ', - 1 'EQUAL TO DAY',F10.3,', WILL BE CHECKED FOR EXACT AND ', - 2 'PARTIAL DUPLICATES '/4X,'(ICALL=',I2,') AND WILL BE ', - 3 'COPIED FROM THE ORIGINAL SHORT-TERM HISTORICAL FILE TO ', - 4 'THE PRELIMINARY QUALITY CONTROLLED FILE'/4X,'(SCRATCH ', - 5 'FILE) FOR TEMPORARY STORAGE:') - - CALL CPYREC(ICALL,IUNTHO,IUNTOK,NOKAY,DAYMIN,DUMREC,OKAREC) - -C NOW ADD THE CURRENT RECORDS. - - WRITE(6,21) - 21 FORMAT(//'...THE FOLLOWING ACCEPTABLE ORIGINAL RECORDS WILL BE ', - 1 'ADDED TO THE NEW ORIGINAL SHORT-TERM HISTORY FILE:'/) - DO NOK=1,NOKAY - IF(OKAREC(NOK)(1:1) .NE. '!') THEN - WRITE(6,23) NOK,OKAREC(NOK) - 23 FORMAT('...',I4,'...',A) - WRITE(IUNTOK,27) OKAREC(NOK) - 27 FORMAT(A) - ENDIF - ENDDO - -C NOW WE APPEND THE SCRATCH FILE WITH RECORDS THAT CONTRIBUTED -C TO ALIAS RECORDS. - - WRITE(6,101) - 101 FORMAT(/'...THE FOLLOWING (BAD) RECORDS WITH RSMCCK OR RCNCIL ', - 1 'ERRORS WILL BE ADDED TO THE SHORT-TERM ORIGINAL'/4X, - 2 'HISTORY FILE:'/) - - DO NBA=1,NBAD - - IF(IEFAIL(NUMBAD(NBA),6) .EQ. 10 .OR. - 1 IEFAIL(NUMBAD(NBA),6) .GE. 21 .OR. - 1 IABS(IEFAIL(NUMBAD(NBA),5)) .EQ. 20) THEN - - DO NCK=1,MAXCKS - IF(NCK .NE. 6 .AND. NCK .NE. 5 .AND. - 1 IEFAIL(NUMBAD(NBA),NCK) .GT. 0) GO TO 150 - ENDDO - - WRITE(6,131) NBA,BADREC(NBA) - 131 FORMAT('...',I4,'...',A) - WRITE(IUNTOK,133) BADREC(NBA) - 133 FORMAT(A) - - ENDIF - 150 CONTINUE - ENDDO - -C COPY RECORDS THAT ARE MORE RECENT THAN DAYMIN FROM THE -C SCRATCH FILE (IUNTOK) TO THE ORIGINAL SHORT-TERM -C HISTORY FILE - - ICALL=1 - REWIND IUNTOK - REWIND IUNTHO - WRITE(6,151) - 151 FORMAT(/'...THE FOLLOWING RECORDS WILL BE COPIED FROM THE ', - 1 'SCRATCH FILE TO THE NEW ORIGINAL SHORT-TERM HISTORICAL ', - 2 'FILE:') - - CALL CPYREC(ICALL,IUNTOK,IUNTHO,NOKAY,DAYMIN,DUMREC,OKAREC) - - ICALL=3 - - REWIND IUNTOK - -C COPY RECORDS THAT ARE MORE RECENT THAN DAYMIN FROM THE -C CURRENT ALIAS SHORT-TERM HISTORY FILE TO A SCRATCH FILE -C (IUNTOK). THEN ADD THE CURRENT RECORDS. - - CALL CPYREC(ICALL,IUNTHA,IUNTOK,NOKAY,DAYMIN,DUMREC,OKAREC) - - WRITE(6,211) - 211 FORMAT(//'...THE FOLLOWING ACCEPTABLE RECORDS WILL BE ADDED TO ', - 1 'THE NEW ALIAS SHORT-TERM HISTORY FILE:'/) - DO NOK=1,NOKAY - WRITE(6,213) NOK,OKAREC(NOK) - 213 FORMAT('...',I4,'...',A) - WRITE(IUNTOK,217) OKAREC(NOK) - 217 FORMAT(A) - ENDDO - -C ADD RECORDS THAT HAVE OVERLAND POSITIONS TO THE SHORT-TERM -C HISTORY FILE, PROVIDED THEY HAVE NO OTHER ERRORS - - WRITE(6,41) - 41 FORMAT(/'...THE FOLLOWING (BAD) RECORDS WITH COASTAL OVERLAND ', - 1 'POSITIONS WILL BE ADDED TO THE NEW ALIAS SHORT-TERM '/4X, - 2 'HISTORY FILE FOR FUTURE TRACK CHECKS:'/) - - DO NBA=1,NBAD - - IF(IEFAIL(NUMBAD(NBA),4) .EQ. IECOST) THEN - - DO NCK=1,MAXCKS - IF(NCK .NE. 4 .AND. IEFAIL(NUMBAD(NBA),NCK) .GT. 0) GO TO 300 - ENDDO - - WRITE(6,261) NBA,BADREC(NBA) - 261 FORMAT('...',I4,'...',A) - WRITE(IUNTOK,263) BADREC(NBA) - 263 FORMAT(A) - - ENDIF - 300 CONTINUE - ENDDO - -C THE SCRATCH FILE (IUNTOK) NOW CONTAINS ALL RECORDS THAT WILL -C BE IN THE NEW ALIAS SHORT-TERM HISTORY FILE. SUBROUTINE FNLCPY -C WILL COPY THIS SCRATCH FILE TO THE NEW ALIAS SHORT-TERM HISTORY -C FILE. - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: RITHIS WRITES RECORDS AND Q/C MARKS TO FILE -C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01 -C -C ABSTRACT: WRITES ALL INPUT RECORDS AND QUALITY CONTROL MARKS -C ASSIGNED BY THIS PROGRAM TO A LONG-TERM HISTORY FILE. -C -C PROGRAM HISTORY LOG: -C 1990-11-01 S. LORD -C -C USAGE: CALL RITHIS(IUNTHI,IEFAIL,NRTOT,IDATE,IUTC,NUMREC,NREC, -C MAXREC,MAXCKS,HROFF,WINCUR,RUNID,LNDFIL,FILES, -C RECORD,ZZZREC,XXXREC) -C INPUT ARGUMENT LIST: -C IUNTHI - UNIT NUMBER FOR THE OUTPUT FILE. NOTE: SIGN OF THE -C - QUALITY MARKS IS ATTACHED TO THIS NUMBER! -C IEFAIL - INTEGER ARRAY CONTAINING QUALITY MARKS. INDEXING -C - IS ACCORDING TO ARRAY NUMREC. SIGN OF THIS NUMBER IS -C - ATTACHED TO IUNTHI! -C NRTOT - TOTAL NUMBER OF RECORDS WRITTEN INTO THE FILE. NREC -C - IS THE NUMBER WRITTEN FOR EACH CALL OF THE ROUTINE. -C IDATE - YYYYMMDD FOR WHICH THE PROGRAM IS BEING RUN. -C IUTC - HHMM FOR WHICH THE PROGRAM IS BEING RUN. -C NUMREC - ARRAY OF RECORD NUMBERS CORRESPONDING TO THE QUALITY -C - MARKS STORED IN ARRAY IEFAIL. -C NREC - NUMBER OF RECORDS TO BE WRITTEN TO THE OUTPUT FILE. -C MAXREC - FIRST DIMENSION OF ARRAY IEFAIL. -C MAXCKS - NUMBER OF QUALITY CONTROL CHECKS. SECOND DIMENSION OF -C - ARRAY IEFAIL IS (0:MAXCKS). -C HROFF - OFFSET (FRACTIONAL HOURS) BETWEEN TIME PROGRAM IS -C - RUN AND THE VALID CYCLE TIME -C WINCUR - TIME WINDOW FOR ADDING RECORDS TO CURRENT FILE -C RUNID - CHARACTER VARIABLE IDENTIFYING RUN -C LNDFIL - LOGICAL VARIABLE, TRUE IF OVER LAND POSITIONS ARE -C - NOT WRITTEN TO CURRENT FILE -C FILES - LOGICAL VARIABLE: TRUE IF SHORT-TERM HISTORY FILES ARE -C - UPDATED. -C RECORD - CHARACTER ARRAY CONTAINING OUTPUT RECORDS. -C ZZZREC - COLUMN HEADER RECORD. -C XXXREC - COLUMN HEADER RECORD. -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C UNIT 61 - CONTAINS HISTORY OF ALL RECORDS THAT ARE OPERATED ON -C - BY THIS PROGRAM -C -C REMARKS: THE HEADER RECORD IS WRITTEN ON THE FIRST CALL OF THIS -C ROUTINE. IT CONSISTS OF IDATE,IUTC,NRTOT,NREC,ZZZREC -C AND XXXREC. FOR THE FIRST CALL, NREC CORRESPONDS TO THE -C NUMBER OF RECORDS THAT PASSED THE Q/C CHECKS. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE RITHIS(IUNTHI,IEFAIL,NRTOT,IDATE,IUTC,NUMREC,NREC, - 1 MAXREC,MAXCKS,HROFF,WINCUR,RUNID,LNDFIL,FILES, - 2 RECORD,ZZZREC,XXXREC) - - PARAMETER (MAXSPH=131) - - SAVE - - LOGICAL FIRST,LNDFIL,FILES - - CHARACTER*(*) RUNID,RECORD(NREC),ZZZREC,XXXREC - - PARAMETER (MAXCHR=95) - - DIMENSION IEFAIL(MAXREC,0:MAXCKS),NUMREC(NREC) - - DATA FIRST/.TRUE./ - - IF(FIRST) THEN - FIRST=.FALSE. - IF(MAXCHR+1+3*(MAXCKS+1) .GT. MAXSPH) THEN - WRITE(6,1) MAXCHR,MAXCKS,MAXCHR+1+3*(MAXCKS+1),MAXSPH - 1 FORMAT(/'******INSUFFICIENT SPACE ALLOCATED FOR LONG-TERM ', - 1 'HISTORY FILE.'/7X,'MAXCHR,MAXCK,(REQUIRED,AVAILABLE) ', - 2 ' SPACE ARE:',4I4) - CALL ABORT1(' RITHIS',1) - ENDIF - - NROKAY=NREC - WRITE(IABS(IUNTHI),3) IDATE,IUTC,NRTOT,NROKAY,HROFF,RUNID,LNDFIL, - 1 FILES,WINCUR,ZZZREC(1:MAXCHR),XXXREC - 3 FORMAT('IDATE=',I8,' IUTC=',I4,' NRTOT=',I4,' NROKAY=',I4, - 1 ' HROFF=',F6.2,' RUNID=',A12,' LNDFIL=',L1,' FILES=',L1, - 2 ' WINCUR=',F6.3/A,1X,A) - ENDIF - -C OUTPUT UNIT NUMBER IS NEGATIVE FOR OKAY RECORDS (ERROR CODES ARE -C ALWAYS NEGATIVE). OUTPUT UNIT NUMBER IS POSITIVE FOR BAD -C RECORDS, WHICH MAY HAVE A MIXTURE OF POSITIVE AND NEGATIVE -C ERROR CODES. - - IF(IUNTHI .LT. 0) THEN - DO NR=1,NREC - WRITE(IABS(IUNTHI),5) RECORD(NR)(1:MAXCHR),IEFAIL(NUMREC(NR),0), - 1 (-IABS(IEFAIL(NUMREC(NR),ICK)),ICK=1,MAXCKS) - 5 FORMAT(A,1X,I3,8I3) - ENDDO - - ELSE - DO NR=1,NREC - WRITE(IABS(IUNTHI),5) RECORD(NR)(1:MAXCHR),IEFAIL(NUMREC(NR),0), - 1 (IEFAIL(NUMREC(NR),ICK),ICK=1,MAXCKS) - ENDDO - ENDIF - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FNLCPY RESETS FILES FOR THE NEXT INPUT CYCLE -C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01 -C -C ABSTRACT: RESETS THE FILES CONTAINING THE INPUT RECORDS FOR THE -C NEXT RUN OF THE PROGRAM. THE SHORT-TERM HISTORY FILE IS UPDATED -C AND ALL INPUT FILES ARE FLUSHED, RECORDS THAT BELONG TO A FUTURE -C CYCLE ARE REINSERTED INTO THE INPUT FILES. -C -C PROGRAM HISTORY LOG: -C 1990-11-01 S. LORD -C -C USAGE: CALL FNLCPY(IUNTVZ,MAXUNT,IUNTOK,IUNTHA,MAXREC,NTBP,NUMTBP, -C IUNTIN,TBPREC,DUMREC) -C INPUT ARGUMENT LIST: -C IUNTVZ - UNIT NUMBER FOR FIRST INPUT FILE -C MAXUNT - NUMBER OF INPUT FILES TO BE RESET -C IUNTOK - UNIT NUMBER FOR TEMPORARY HISTORY FILE, WHICH CONTAINS -C - QUALITY CONTROLLED RECORDS, INCLUDING THOSE JUST -C - PROCESSED. -C IUNTHA - UNIT NUMBER FOR THE ALIAS SHORT TERM HISTORY FILE. -C RECORDS ARE COPIED FROM IUNTOK TO IUNTHA. -C MAXREC - MAXIMUM NUMBER OF RECORDS, DIMENSION OF IUNTIN. -C NTBP - NUMBER OF RECORDS FOR THE NEXT CYCLE THAT WILL BE -C - PUT BACK INTO THE INPUT FILES (THROWN BACK INTO THE -C - POND). -C NUMTBP - INTEGER ARRAY CONTAINING INDICES OF RECORDS THAT WILL -C - THROWN BACK INTO THE POND. INDICES REFER TO POSITION -C - IN ARRAY IUNTIN. -C IUNTIN - INTEGER ARRAY CONTAINING UNIT NUMBERS FOR RECORDS -C - THAT WILL BE THROWN BACK INTO THE POND. -C TBPREC - CHARACTER ARRAY CONTAINING RECORDS THAT WILL BE -C - THROWN BACK INTO THE POND. -C DUMREC - CHARACTER VARIABLE FOR COPYING RECORDS TO THE -C - SHORT-TERM HISTORY FILE. -C -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C UNIT 10 - SCRATCH FILE -C UNIT 22 - SHORT-TERM HISTORY, RECORDS BACK 4 DAYS FROM PRESENT -C UNIT 30 - FILE(S) CONTAINING NEW RECORDS TO BE QUALITY -C - CONTROLLED. RECORDS APPROPRIATE TO A FUTURE CYCLE ARE -C - WRITTEN BACK TO THIS FILE -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE FNLCPY(IUNTVZ,MAXUNT,IUNTOK,IUNTHA,MAXREC,NTBP,NUMTBP, - 1 IUNTIN,TBPREC,DUMREC) - - SAVE - - CHARACTER DUMREC*(*),TBPREC(NTBP)*(*) - CHARACTER*100 DUMY2K - - DIMENSION NUMTBP(NTBP),IUNTIN(MAXREC) - -C FINAL COPYING BACK TO SHORT TERM HISTORY FILE AND ZEROING ALL -C FILES THAT WILL CONTAIN NEW RECORDS FOR THE NEXT CYCLE - - NREC=0 - REWIND IUNTOK - REWIND IUNTHA - - 10 CONTINUE - - READ(IUNTOK,11,END=20) DUMREC - 11 FORMAT(A) - -C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20 -C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR -C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF -C LATITUDE N/S INDICATOR TO FIND OUT ... - - IF(DUMREC(35:35).EQ.'N' .OR. DUMREC(35:35).EQ.'S') THEN - -C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR - -C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE -C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 2-digit year "',DUMREC(20:21),'"' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntok,'; DUMREC-7: ',dumrec - PRINT *, ' ' - DUMY2K(1:19) = DUMREC(1:19) - IF(DUMREC(20:21).GT.'20') THEN - DUMY2K(20:21) = '19' - ELSE - DUMY2K(20:21) = '20' - ENDIF - DUMY2K(22:100) = DUMREC(20:100) - DUMREC = DUMY2K - PRINT *, ' ' - PRINT *, '==> 2-digit year converted to 4-digit year "', - $ DUMREC(20:23),'" via windowing technique' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntok,'; DUMREC-7: ',dumrec - PRINT *, ' ' - - ELSE IF(DUMREC(37:37).EQ.'N' .OR. DUMREC(37:37).EQ.'S') THEN - -C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR -C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 4-digit year "',DUMREC(20:23),'"' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntok,'; DUMREC-7: ',dumrec - PRINT *, ' ' - PRINT *, '==> No conversion necessary' - PRINT *, ' ' - - ELSE - - PRINT *, ' ' - PRINT *, '***** Cannot determine if this record contains ', - $ 'a 2-digit year or a 4-digit year - skip it and try reading ', - $ 'the next record' - PRINT *, ' ' - GO TO 10 - - END IF - - NREC=NREC+1 - WRITE(IUNTHA,11) DUMREC - GO TO 10 - - 20 CONTINUE - WRITE(6,21) NREC,IUNTHA - 21 FORMAT(/'...',I3,' RECORDS HAVE BEEN COPIED TO THE FUTURE ALIAS ', - 1 'SHORT-TERM HISTORY FILE, UNIT=',I3) - - IUNTVI=IUNTVZ - DO NFILE=1,MAXUNT - REWIND IUNTVI - - IF(NTBP .EQ. 0) THEN - - END FILE IUNTVI - WRITE(6,23) IUNTVI - 23 FORMAT(/'...UNIT',I3,' HAS BEEN ZEROED FOR THE NEXT CYCLE.') - -C THROW RECORDS FOR THE NEXT CYCLE BACK INTO THE POND - - ELSE - - WRITE(6,27) IUNTVI - 27 FORMAT(/'...THE FOLLOWING RECORDS WILL BE THROWN BACK INTO THE ', - 1 'POND = UNIT',I3,':') - - DO NTB=1,NTBP - IF(IUNTIN(NUMTBP(NTB)) .EQ. IUNTVI) THEN - WRITE(IUNTVI,11) TBPREC(NTB) - WRITE(6,29) NTB,NUMTBP(NTB),TBPREC(NTB) - 29 FORMAT(3X,I4,'...',I4,'...',A,'...') - ENDIF - ENDDO - - ENDIF - - IUNTVI=IUNTVI+1 - - ENDDO - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: CPYREC COPIES RECORDS CHECKS DATES & DUPLICATES -C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01 -C -C ABSTRACT: RECORDS ARE CHECKED FOR DATE AND EXACT AND PARTIAL -C DUPLICATES AND COPIED FROM ONE FILE TO A SECOND FILE. -C -C PROGRAM HISTORY LOG: -C 1990-11-01 S. LORD -C 1992-03-10 S. LORD - ADDED FILTERS. -C -C USAGE: CALL CPYREC(ICALL,IUNTRD,IUNTWT,NOKAY,DAYMN,DUMREC,OKAREC) -C INPUT ARGUMENT LIST: -C ICALL - TOGGLE FOR FILTER. 1: NO FILTER (STRAIGHT COPY) -C 2: DATE/TIME, STORM ID & NAME -C 3: #2 ABOVE PLUS RSMC (PARTIAL -C DUPLICATE) -C IUNTRD - UNIT NUMBER FOR RECORDS TO BE COPIED -C IUNTWT - RECORDS COPIED TO THIS UNIT NUMBER -C NOKAY - LENGTH OF ARRAY OKAREC -C DAYMN - RECORDS WITH DATES PRIOR TO THIS DAY WILL NOT BE -C - COPIED. DAYMN HAS UNITS OF DDD.FFF, WHERE DDD= -C - JULIAN DAY, FFF=FRACTIONAL DAY (E.G. .5 IS 1200 UTC.) -C DUMREC - CHARACTER VARIABLE LONG ENOUGH TO HOLD COPIED RECORD. -C OKAREC - CHARACTER ARRAY CONTAINING RECORDS AGAINST WHICH -C - EACH COPIED RECORD WILL BE CHECKED FOR EXACT OR -C - PARTIAL DUPLICATES. A PARTIAL DUPLICATE IS ONE WITH -C - THE SAME RSMC, DATE/TIME AND STORM NAME/ID. -C -C INPUT FILES: -C UNIT 20 - SHORT TERM HISTORY -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C UNIT 22 - PRELIMINARY QUALITY CONTROLLED FILE -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE CPYREC(ICALL,IUNTRD,IUNTWT,NOKAY,DAYMN,DUMREC,OKAREC) - - SAVE - - CHARACTER*(*) DUMREC,OKAREC(NOKAY) - CHARACTER*100 DUMY2K - - DIMENSION RINC(5) - - PARAMETER (MAXVIT=15) - - CHARACTER FMTVIT*6 - - DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT) - - DIMENSION FMTVIT(MAXVIT) - - EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ) - - DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)', - 1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/, - 2 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/, - 3 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/ - - DATA NUM/1/,FIVMIN/3.4722E-3/ - - NREC=0 - REWIND IUNTRD - - 10 CONTINUE - - READ(IUNTRD,11,END=100) DUMREC - 11 FORMAT(A) - -C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20 -C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR -C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF -C LATITUDE N/S INDICATOR TO FIND OUT ... - - IF(DUMREC(35:35).EQ.'N' .OR. DUMREC(35:35).EQ.'S') THEN - -C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR - -C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE -C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 2-digit year "',DUMREC(20:21),'"' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntrd,'; DUMREC-8: ',dumrec - PRINT *, ' ' - DUMY2K(1:19) = DUMREC(1:19) - IF(DUMREC(20:21).GT.'20') THEN - DUMY2K(20:21) = '19' - ELSE - DUMY2K(20:21) = '20' - ENDIF - DUMY2K(22:100) = DUMREC(20:100) - DUMREC = DUMY2K - PRINT *, ' ' - PRINT *, '==> 2-digit year converted to 4-digit year "', - $ DUMREC(20:23),'" via windowing technique' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntrd,'; DUMREC-8: ',dumrec - PRINT *, ' ' - - ELSE IF(DUMREC(37:37).EQ.'N' .OR. DUMREC(37:37).EQ.'S') THEN - -C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR -C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 4-digit year "',DUMREC(20:23),'"' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntrd,'; DUMREC-8: ',dumrec - PRINT *, ' ' - PRINT *, '==> No conversion necessary' - PRINT *, ' ' - - ELSE - - PRINT *, ' ' - PRINT *, '***** Cannot determine if this record contains ', - $ 'a 2-digit year or a 4-digit year - skip it and try reading ', - $ 'the next record' - PRINT *, ' ' - GO TO 10 - - END IF - - IF(ICALL .GT. 1) THEN - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 DUMREC) - ENDDO - CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYZ) -C WRITE(6,21) IDATEZ,IUTCZ,DAYZ,DAYMN -C 21 FORMAT(/'...CHECKING DATE,TIME FOR COPYING HISTORICAL RECORDS',I9, -C I5,2F10.2) - - IF(DAYZ .GE. DAYMN-FIVMIN) THEN - - DO NOK=1,NOKAY - IF(DUMREC .EQ. OKAREC(NOK)) THEN - WRITE(6,27) DUMREC - 27 FORMAT(/'...EXACT DUPLICATE FOUND IN THE NEW AND HISTORICAL ', - 1 'FILES. THE HISTORICAL RECORD WILL NOT BE COPIED.'/8X, - 2 '...',A/) - GO TO 10 - ENDIF - -C CHECK FOR VARIOUS PARTIAL DUPLICATES: -C ICALL = 2: DATE/TIME, STORM ID, STORM NAME FILTER -C ICALL = 3: #2 ABOVE PLUS RSMC, I.E. A PARTIAL DUPLICATE - - IF(ICALL .EQ. 2 .AND. DUMREC(6:ISTVAR(3)-1) .EQ. - 1 OKAREC(NOK)(6:ISTVAR(3)-1)) THEN - WRITE(6,59) DUMREC,OKAREC(NOK) - 59 FORMAT(/'...PARTIAL DUPLICATE IN STORM ID & NAME, DATE AND TIME ', - 1 'FOUND IN THE NEW AND HISTORICAL FILES.'/4X,'THE ', - 2 'HISTORICAL RECORD WILL NOT BE COPIED.'/5X,'HIS...',A/5X, - 3 'NEW...',A/) - GO TO 10 - ENDIF - - IF(ICALL .GE. 3 .AND. DUMREC(1:ISTVAR(3)-1) .EQ. - 1 OKAREC(NOK)(1:ISTVAR(3)-1)) THEN - WRITE(6,69) DUMREC,OKAREC(NOK) - 69 FORMAT(/'...PARTIAL DUPLICATE IN RSMC, STORM ID & NAME, DATE AND', - 1 ' TIME FOUND IN THE NEW AND HISTORICAL FILES.'/4X,'THE ', - 2 'HISTORICAL RECORD WILL NOT BE COPIED.'/5X,'HIS...',A/5X, - 3 'NEW...',A/) - GO TO 10 - ENDIF - - ENDDO - - NREC=NREC+1 - WRITE(6,83) NREC,DUMREC - 83 FORMAT(3X,I4,'...',A,'...') - - WRITE(IUNTWT,11) DUMREC - ENDIF - - ELSE - NREC=NREC+1 - WRITE(6,83) NREC,DUMREC - WRITE(IUNTWT,11) DUMREC - ENDIF - - GO TO 10 - - 100 WRITE(6,101) NREC,IUNTRD,IUNTWT - 101 FORMAT(/'...',I4,' RECORDS HAVE BEEN COPIED FROM UNIT',I3,' TO ', - 1 'UNIT',I3,'.') - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: DUPCHK READS INPUT RECORDS, DUPLICATE CHECKS -C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01 -C -C ABSTRACT: READS INPUT RECORDS FROM ALL SPECIFIED FILES. CHECKS FOR -C EXACT DUPLICATES. RETURNS ALL RECORDS TO BE QUALITY CONTROLLED. -C -C PROGRAM HISTORY LOG: -C 1990-11-01 S. LORD -C 1992-08-20 S. LORD ADDED NEW UNIT FOR GTS BUFR MESSAGES -C 1997-06-24 S. LORD ADDED NEW UNIT FOR MANUALLY ENTERED MESSAGES -C -C USAGE: CALL DUPCHK(IUNTIN,MAXUNT,MAXREC,IERCHK,NUNI,IFILE, -C NUMOKA,DUMREC,UNIREC,DUPREC,*) -C INPUT ARGUMENT LIST: -C IUNTIN - THE INPUT UNIT NUMBER FOR THE FIRST FILE TO BE READ. -C MAXUNT - NUMBER OF INPUT FILES. -C MAXREC - MAXIMUM NUMBER OF INPUT RECORDS. SUBROUTINE -C - RETURNS WITH CONDITION CODE=51 OR 53 WHEN NUMBER OF -C - UNIQUE OR DUPLICATE RECORDS EXCEEDS MAXREC. -C -C OUTPUT ARGUMENT LIST: -C IERCHK - ERROR INDICATOR. -C NUNI - NUMBER OF UNIQUE RECORDS TO BE QUALITY CONTROLLED -C IFILE - INTEGER ARRAY CONTAINING THE UNIT NUMBER FROM WHICH -C - EACH INPUT RECORD WAS READ. -C NUMOKA - INDEX NUMBER FOR EACH UNIQUE RECORD. INDEX NUMBER -C - IS SIMPLY THE ORDINAL NUMBER OF EACH RECORD READ -C - THAT IS UNIQUE, I.E. NOT A DUPLICATE. -C DUMREC - DUMMY CHARACTER VARIABLE LARGE ENOUGH TO READ A RECORD. -C UNIREC - CHARACTER ARRAY HOLDING ALL INPUT RECORDS. -C DUPREC - CHARACTER ARRAY HOLDING ALL DUPLICATE RECORDS. -C * - ALTERNATE RETURN IF NO INPUT RECORDS ARE FOUND. -C - SUBROUTINE RETURNS WITH IERCHK=161. -C -C INPUT FILES: -C UNIT 30 - FILES CONTAINING NEW RECORDS TO BE QUALITY CONTROLLED. -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE DUPCHK(IUNTIN,MAXUNT,MAXREC,IERCHK,NUNI,IFILE,NUMOKA, - 1 DUMREC,UNIREC,DUPREC,*) - - PARAMETER (MAXFIL=5) - - SAVE - - LOGICAL UNIQUE - CHARACTER*(*) DUMREC,UNIREC(0:MAXREC),DUPREC(MAXREC) - CHARACTER INPFIL(MAXFIL)*4 - CHARACTER*100 DUMY2K - - DIMENSION NUMOKA(MAXREC),IFILE(MAXREC) - - DATA INPFIL/'NHC ','FNOC','GBTB','GBFR','HBTB'/ - - IF(MAXUNT .GT. MAXFIL) THEN - WRITE(6,1) MAXUNT,MAXFIL - 1 FORMAT(/'******MAXIMUM NUMBER OF UNITS TO BE READ=',I3,' EXCEEDS', - 1 ' EXPECTATIONS. NUMBER WILL BE REDUCED TO',I3) - MAXUNT=MAXFIL - ENDIF - - IUNTVI=IUNTIN - IERCHK=0 - NUNI=0 - NDUP=0 - NSTART=0 - NALREC=0 - NRFILE=0 - UNIREC(0)='ZZZZZZZ' - - WRITE(6,3) MAXREC,IUNTVI,MAXUNT,(INPFIL(IFFF), - 1 IUNTIN+IFFF-1,IFFF=1,MAXUNT) - 3 FORMAT(//'...ENTERING DUPCHK: READING FILE AND LOOKING FOR EXACT', - 1 ' DUPLICATES. MAXREC=',I4,'.'/4X,'INITIAL UNIT NUMBER=', - 2 I4,' AND',I3,' UNITS WILL BE READ'/4X,'FILES AND UNIT ', - 3 'NUMBERS ARE:'/(6X,A,':',I3)) - - 10 CONTINUE - - DO NREC=1,MAXREC - READ(IUNTVI,11,END=130) DUMREC - 11 FORMAT(A) - -C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20 -C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR -C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF -C LATITUDE N/S INDICATOR TO FIND OUT ... - - IF(DUMREC(35:35).EQ.'N' .OR. DUMREC(35:35).EQ.'S') THEN - -C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR - -C FOR EXAMPLE: - -C NHC 13L MITCH 981028 1800 164N 0858W 270 010 0957 1008 0371 51 019 0278 0278 0185 0185 D -C 123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123 -C 1 2 3 4 5 6 7 8 9 - -C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE -C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS - FOR -C EXAMPLE, THE ABOVE RECORD IS CONVERTED TO: - -C NHC 13L MITCH 19981028 1800 164N 0858W 270 010 0957 1008 0371 51 019 0278 0278 0185 0185 D -C 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345 -C 1 2 3 4 5 6 7 8 9 - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 2-digit year "',DUMREC(20:21),'"' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntvi,'; DUMREC-1: ',dumrec - PRINT *, ' ' - DUMY2K(1:19) = DUMREC(1:19) - IF(DUMREC(20:21).GT.'20') THEN - DUMY2K(20:21) = '19' - ELSE - DUMY2K(20:21) = '20' - ENDIF - DUMY2K(22:100) = DUMREC(20:100) - DUMREC = DUMY2K - PRINT *, ' ' - PRINT *, '==> 2-digit year converted to 4-digit year "', - $ DUMREC(20:23),'" via windowing technique' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntvi,'; DUMREC-1: ',dumrec - PRINT *, ' ' - - ELSE IF(DUMREC(37:37).EQ.'N' .OR. DUMREC(37:37).EQ.'S') THEN - -C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR - -C FOR EXAMPLE: - -C NHC 13L MITCH 19981028 1800 164N 0858W 270 010 0957 1008 0371 51 019 0278 0278 0185 0185 D -C 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345 -C 1 2 3 4 5 6 7 8 9 - -C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 4-digit year "',DUMREC(20:23),'"' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iuntvi,'; DUMREC-1: ',dumrec - PRINT *, ' ' - PRINT *, '==> No conversion necessary' - PRINT *, ' ' - - ELSE - - PRINT *, ' ' - PRINT '(a,a,a)', '***** Cannot determine if this record ', - $ 'contains a 2-digit year or a 4-digit year - skip it and ', - $ 'try reading the next record' - PRINT *, ' ' - GO TO 100 - - END IF - - NALREC=NALREC+1 - NRFILE=NRFILE+1 - - UNIQUE=.TRUE. - DO NR=NSTART,NUNI - IF(DUMREC .EQ. UNIREC(NR)) UNIQUE=.FALSE. - ENDDO - - IF(UNIQUE) THEN - - IF(NUNI .EQ. MAXREC) THEN - WRITE(6,51) MAXREC - 51 FORMAT('******INSUFFICIENT STORAGE FOR ALL VITAL ', - 1 'STATISTICS RECORDS, MAXREC=',I5) - IERCHK=51 - RETURN - ELSE - NUNI=NUNI+1 - NUMOKA(NUNI)=NUNI - UNIREC(NUNI)=DUMREC - IFILE(NUNI)=IUNTVI - ENDIF - - ELSE - - IF(NDUP .EQ. MAXREC) THEN - WRITE(6,51) MAXREC - IERCHK=53 - RETURN - ELSE - NDUP=NDUP+1 - DUPREC(NDUP)=DUMREC - ENDIF - ENDIF - NSTART=1 - - 100 continue - - ENDDO - - 130 CONTINUE - -C LOOP FOR MORE FILES IF REQUESTED - - IF(NRFILE .EQ. 0) WRITE(6,133) INPFIL(IUNTVI-29) - 133 FORMAT(/'###',A,' FILE IS EMPTY.') - - IUNTVI=IUNTVI+1 - IF(IUNTVI-IUNTIN .LT. MAXUNT) THEN - NRFILE=0 - WRITE(6,141) IUNTVI,MAXUNT - 141 FORMAT(/'...LOOPING TO READ UNIT NUMBER',I3,'. MAXUNT=',I3) - GO TO 10 - ENDIF - - WRITE(6,151) NALREC - 151 FORMAT(//'...TOTAL NUMBER OF RECORDS=',I4) - WRITE(6,153) NUNI,(NUMOKA(NR),UNIREC(NR),NR=1,NUNI) - 153 FORMAT(/'...',I4,' RECORDS ARE UNIQUE, BUT NOT ERROR CHECKED.'// - 1 (' ...',I4,'...',A)) - WRITE(6,157) NDUP,(NR,DUPREC(NR),NR=1,NDUP) - 157 FORMAT(/'...',I4,' RECORDS ARE EXACT DUPLICATES:'//(' ...',I4, - 1 '...',A)) - - IF(NUNI .EQ. 0) THEN - WRITE(6,161) - 161 FORMAT(/'###THERE ARE NO RECORDS TO BE READ. THIS PROGRAM ', - 1 'WILL COMPLETE FILE PROCESSING AND LEAVE AN EMPTY ', - 2 ' "CURRENT" FILE!!') - IERCHK=161 - RETURN 1 - ENDIF - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: BLNKCK CHECKS FOR PROPER COLUMNAR FORMAT -C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01 -C -C ABSTRACT: CHECKS ALL INPUT RECORDS FOR PROPER COLUMNAR FORMAT. -C THE TABULAR INPUT RECORD HAS SPECIFIED BLANK COLUMNS. IF -C NONBLANK CHARACTERS ARE FOUND IN SPECIFIED BLANK COLUMNS, -C AN OBVIOUS ERROR HAS OCCURRED. THE RECORD IS REJECTED IN THIS -C CASE. -C -C PROGRAM HISTORY LOG: -C 1990-11-01 S. LORD -C 1994-06-20 S. LORD MODIFIED MAXCHK FOR THE GFDL FORMAT -C -C USAGE: CALL BLNKCK(NTEST,NOKAY,NBAD,IFBLNK,NUMTST,NUMOKA,NUMBAD, -C ZZZREC,NNNREC,TSTREC,BADREC,OKAREC) -C INPUT ARGUMENT LIST: -C NTEST - NUMBER OF RECORDS TO BE TESTED. -C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD -C - TO BE TESTED. -C ZZZREC - CHARACTER VARIABLE CONTAINING VARIABLE NAMES. -C NNNREC - CHARACTER VARIABLE CONTAINING COLUMN NUMBERS. -C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED. -C -C OUTPUT ARGUMENT LIST: -C NOKAY - NUMBER OF RECORDS THAT PASSED THE BLANK CHECK. -C NBAD - NUMBER OF RECORDS THAT FAILED THE BLANK CHECK. -C IFBLNK - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT -C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES. -C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD -C - RECORD. -C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD -C - RECORD. -C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED -C - THE BLANK CHECK. -C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED -C - THE BLANK CHECK. -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE BLNKCK(NTEST,NOKAY,NBAD,IFBLNK,NUMTST,NUMOKA,NUMBAD, - 1 ZZZREC,NNNREC,TSTREC,BADREC,OKAREC) - - PARAMETER (MAXCHK=95) - PARAMETER (NERCBL=3) - PARAMETER (MAXREC=1000) - - SAVE - - CHARACTER*(*) ZZZREC,NNNREC,TSTREC(0:NTEST),BADREC(MAXREC), - 1 OKAREC(NTEST) - CHARACTER ERCBL(NERCBL)*60 - - PARAMETER (MAXCHR=95) - PARAMETER (MAXVIT=15) - - CHARACTER NAMVAR*5 - - DIMENSION ISTVAR(MAXVIT) - - DIMENSION NAMVAR(MAXVIT+1) - - DIMENSION IFBLNK(MAXREC),NUMOKA(NTEST),NUMBAD(MAXREC), - 1 NUMTST(NTEST) - - DATA ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/, - 1 LENHED/18/ - - DATA NAMVAR/'DATE ','TIME ','LAT. ','LONG.','DIR ','SPEED', - 1 'PCEN ','PENV ','RMAX ','VMAX ','RMW ','R15NE', - 2 'R15SE','R15SW','R15NW','DEPTH'/ - - DATA ERCBL - 1 /'1 : LAST NON-BLANK CHARACTER IS IN THE WRONG COLUMN ', - 2 '18 : FIRST 18 COLUMNS ARE BLANK ', - 3 '19-87: FIRST NON-BLANK CHARACTER FOUND IN THIS COLUMN '/ - -C ERROR CODES FOR BAD RECORDS RETURNED IN IFBLNK ARE AS FOLLOWS: -C 1: LAST NON-BLANK CHARACTER IS IN THE WRONG COLUMN -C 18 : FIRST 18 COLUMNS ARE BLANK -C 19-87: NON-BLANK CHARACTER FOUND IN A BLANK COLUMN. ERROR -C CODE GIVES COLUMN OF LEFT-MOST OCCURRENCE - -C SET COUNTERS FOR INITIAL SORTING OF ALL RECORDS. ALL SUBSEQUENT -C CALLS TO THIS ROUTINE SHOULD BE FOR SINGLE RECORDS - - WRITE(6,1) NTEST - 1 FORMAT(//'...ENTERING BLNKCK, LOOKING FOR WRONGLY POSITIONED ', - 1 ' BLANKS. NTEST=',I4//) - - NADD=0 - IF(NREC .GT. 0) THEN - NOKAY=0 - NBAD =0 - ENDIF - -C DO ALL RECORDS - - DO NREC=1,NTEST - IETYP=0 - -C FIND THE RIGHT-MOST NON-BLANK CHARACTER: IT SHOULD CORRESPOND -C TO THE MAXIMUM NUMBER OF CHARACTERS IN THE MESSAGE (MAXCHR) - - DO ICH=MAXCHK,1,-1 - IF(TSTREC(NREC)(ICH:ICH) .NE. ' ') THEN - IBLANK=ICH - GO TO 31 - ENDIF - ENDDO - 31 CONTINUE -C WRITE(6,3311) IBLANK,TSTREC(NREC)(1:IBLANK) -C3311 FORMAT(/'...TESTING LENGTH OF RECORD, IBLANK,TSTREC=',I4/4X,'...', -C 1 A,'...') -C - IF(IBLANK .NE. MAXCHR) THEN - IETYP=1 - WRITE(6,33) NREC,IBLANK,NNNREC,ZZZREC,TSTREC(NREC) - 33 FORMAT(/'...RECORD #',I3,' HAS RIGHT-MOST NON-BLANK CHARACTER ', - 1 'AT POSITION',I4/2(1X,'@@@',A,'@@@'/),4X,A) - GO TO 41 - ENDIF - -C CHECK FOR BLANKS IN THE HEADER SECTION (THE FIRST 18 COLUMNS) - - IF(TSTREC(NREC)(1:LENHED) .EQ. ' ') THEN - IETYP=LENHED - WRITE(6,35) NREC,NNNREC,ZZZREC,TSTREC(NREC) - 35 FORMAT(/'...RECORD #',I3,' HAS BLANK HEADER SECTION.'/2(1X,'@@@', - 1 A,'@@@'/),4X,A) - ENDIF - -C CHECK COLUMN BLANKS STARTING TO THE LEFT OF THE YYMMDD GROUP - - DO IBL=1,MAXVIT - IF(TSTREC(NREC)(ISTVAR(IBL)-1:ISTVAR(IBL)-1) .NE. ' ') THEN - IETYP=ISTVAR(IBL)-1 - WRITE(6,39) TSTREC(NREC)(ISTVAR(IBL)-1:ISTVAR(IBL)-1), - 1 ISTVAR(IBL)-1,NAMVAR(IBL),NNNREC,ZZZREC,TSTREC(NREC) - 39 FORMAT(/'...NONBLANK CHARACTER ',A1,' AT POSITION ',I3, - 1 ' PRECEEDING VARIABLE',1X,A/2(1X,'@@@',A,'@@@'/),4X,A) - GO TO 41 - ENDIF - ENDDO - - 41 IFBLNK(NUMTST(NREC))=IETYP - IF(IETYP .GT. 0) THEN - NADD=NADD+1 - NUMBAD(NADD+NBAD)=NUMTST(NREC) - BADREC(NADD+NBAD)=TSTREC(NREC) - ELSE - NOKAY=NOKAY+1 - NUMOKA(NOKAY)=NUMTST(NREC) - OKAREC(NOKAY)=TSTREC(NREC) - ENDIF - - ENDDO - - print *, ' ' - IF(NTEST .GT. 1) THEN - WRITE(6,101) NOKAY,NADD,NTEST,(ERCBL(NER),NER=1,NERCBL) - 101 FORMAT(/'...RESULTS OF THE GLOBAL BLANK CHECK ARE: NOKAY=',I4, - 1 ' AND NADD=',I4,' FOR A TOTAL OF ',I4,' RECORDS.'//4X, - 2 'ERROR CODES ARE:'/(6X,A)) - WRITE(6,103) - 103 FORMAT(/'...OKAY RECORDS ARE:',100X,'ERC'/) - DO NOK=1,NOKAY - WRITE(6,109) NOK,NUMOKA(NOK),OKAREC(NOK),IFBLNK(NUMOKA(NOK)) - 109 FORMAT(3X,I4,'...',I4,'...',A,'...',I3) - ENDDO - IF(NADD .GT. 0) WRITE(6,111) (NBAD+NBA,NUMBAD(NBAD+NBA), - 1 BADREC(NBAD+NBA), - 2 IFBLNK(NUMBAD(NBAD+NBA)), - 3 NBA=1,NADD) - 111 FORMAT(/' ADDED BAD RECORDS ARE:',95X,'ERC'/(3X,I4,'...',I4, - 1 '...',A,'...',I3)) - NBAD=NBAD+NADD - ELSE - WRITE(6,113) IETYP,TSTREC(NTEST),NOKAY - 113 FORMAT(/'...BLANK TEST FOR SINGLE RECORD, BLANK ERROR CODE=',I2, - 1 ' RECORD IS:'/4X,'...',A/4X,'NOKAY=',I2) - ENDIF - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: READCK CHECKS READABILITY OF EACH RECORD -C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01 -C -C ABSTRACT: CHECKS READABILITY OF EACH RECORD. SINCE THE INPUT -C RECORD FORMAT CONTAINS ONLY NUMBERS AND LETTERS, -C -C PROGRAM HISTORY LOG: -C 1990-11-01 S. LORD -C 1992-09-18 S. J. LORD ADDED CHECK FOR CORRECT MISSING DATA IN READCK -C -C USAGE: CALL READCK(NTEST,NOKAY,NBAD,IFREAD,NUMTST,NUMOKA,NUMBAD, -C ZZZREC,NNNREC,TSTREC,BADREC,OKAREC) -C INPUT ARGUMENT LIST: -C NTEST - NUMBER OF RECORDS TO BE TESTED. -C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD -C - TO BE TESTED. -C ZZZREC - CHARACTER VARIABLE CONTAINING VARIABLE NAMES. -C NNNREC - CHARACTER VARIABLE CONTAINING COLUMN NUMBERS. -C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED. -C -C OUTPUT ARGUMENT LIST: -C NOKAY - NUMBER OF RECORDS THAT PASSED THE BLANK CHECK. -C NBAD - NUMBER OF RECORDS THAT FAILED THE BLANK CHECK. -C IFREAD - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT -C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES. -C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD -C - RECORD. -C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD -C - RECORD. -C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED -C - THE BLANK CHECK. -C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED -C - THE BLANK CHECK. -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE READCK(NTEST,NOKAY,NBAD,IFREAD,NUMTST,NUMOKA,NUMBAD, - 1 ZZZREC,NNNREC,TSTREC,BADREC,OKAREC) - - PARAMETER (NERCRD=2) - PARAMETER (MAXREC=1000) - - SAVE - - CHARACTER*(*) ZZZREC,NNNREC,TSTREC(0:NTEST),BADREC(MAXREC), - 1 OKAREC(NTEST),ERCRD(NERCRD)*60 - - PARAMETER (MAXVIT=15) - PARAMETER (ITERVR=10) - - CHARACTER FMTVIT*6,NAMVAR*5 - - DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT) - - DIMENSION NAMVAR(MAXVIT+1),FMTVIT(MAXVIT),MISSNG(MAXVIT) - - DIMENSION IFREAD(MAXREC),NUMOKA(NTEST),NUMBAD(MAXREC), - 1 NUMTST(NTEST) - - DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)', - 1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/, - 2 MISSNG/-9999999,-999,-99,-999,2*-99,3*-999,-9,-99,4*-999/, - 3 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/, - 4 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/ - - DATA NAMVAR/'DATE ','TIME ','LAT. ','LONG.','DIR ','SPEED', - 1 'PCEN ','PENV ','RMAX ','VMAX ','RMW ','R15NE', - 2 'R15SE','R15SW','R15NW','DEPTH'/ - - DATA NUM/1/ - - DATA ERCRD - 1 /'N: INDEX OF THE FIRST UNREADABLE RECORD ', - 2 '20-N: WRONG MISSING CODE '/ - -C ERROR CODE FOR UNREADABLE RECORD IS THE INDEX OF THE FIRST -C UNREADABLE RECORD. -C ***NOTE: THERE MAY BE ADDITIONAL UNREADABLE RECORDS TO THE -C RIGHT. - - WRITE(6,1) NTEST - 1 FORMAT(//'...ENTERING READCK, LOOKING FOR UNREADABLE (NOT ', - 1 ' CONTAINING INTEGERS) PRIMARY AND SECONDARY VARIABLES,', - 2 ' NTEST=',I4//) - - NADD=0 - -C DO ALL RECORDS - - DO NREC=1,NTEST - IETYP=0 - - DO IV=1,ITERVR - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 TSTREC(NREC)) - IF(IERDEC .NE. 0) THEN - IETYP=IV - WRITE(6,7) NREC,ISTVAR(IV),NAMVAR(IV),NNNREC,ZZZREC,TSTREC(NREC) - 7 FORMAT(/'...RECORD #',I3,' IS UNREADABLE AT POSITION',I3, - 1 ' FOR VARIABLE ',A,'.'/2(1X,'@@@',A,'@@@'/),4X,A) - GO TO 11 - ENDIF - ENDDO - 11 CONTINUE - - DO IV=1,ITERVR - IF(IVTVAR(IV) .LT. 0 .AND. IVTVAR(IV) .NE. MISSNG(IV)) THEN - IETYP=20-IV - WRITE(TSTREC(NREC) (ISTVAR(IV):IENVAR(IV)),FMTVIT(IV))MISSNG(IV) - ENDIF - ENDDO - - IFREAD(NUMTST(NREC))=IETYP - IF(IETYP .GT. 0) THEN - NADD=NADD+1 - NUMBAD(NADD+NBAD)=NUMTST(NREC) - BADREC(NADD+NBAD)=TSTREC(NREC) - ELSE - NOKAY=NOKAY+1 - NUMOKA(NOKAY)=NUMTST(NREC) - OKAREC(NOKAY)=TSTREC(NREC) - ENDIF - - ENDDO - - WRITE(6,101) NOKAY,NADD,NTEST,(ERCRD(NER),NER=1,NERCRD) - 101 FORMAT(//'...RESULTS OF THE READABILITY CHECK ARE: NOKAY=',I4, - 1 ' AND NADD=',I4,' FOR A TOTAL OF ',I4,' RECORDS.'//4X, - 2 'ERROR CODES ARE:'/(6X,A)) - WRITE(6,103) - 103 FORMAT(/'...OKAY RECORDS ARE:',100X,'ERC'/) - DO NOK=1,NOKAY - WRITE(6,109) NOK,NUMOKA(NOK),OKAREC(NOK),IFREAD(NUMOKA(NOK)) - 109 FORMAT(3X,I4,'...',I4,'...',A,'...',I3) - ENDDO - IF(NADD .GT. 0) WRITE(6,111) (NBAD+NBA,NUMBAD(NBAD+NBA), - 1 BADREC(NBAD+NBA), - 2 IFREAD(NUMBAD(NBAD+NBA)), - 3 NBA=1,NADD) - 111 FORMAT(/' ADDED BAD RECORDS ARE:',95X,'ERC'/(3X,I4,'...',I4, - 1 '...',A,'...',I3)) - NBAD=NBAD+NADD - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: DTCHK CHECK FOR VALID DATE FOR ALL RECORDS -C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01 -C -C ABSTRACT: CHECKS FOR VALID DATE IN ALL RECORDS. -C -C PROGRAM HISTORY LOG: -C 1990-11-01 S. LORD -C -C USAGE: CALL DTCHK(NTEST,NOKAY,NBAD,NTBP,IFDTCK,NUMTST,NUMOKA, -C NUMBAD,NUMTBP,DAYMN,DAYMX1,DAYMX2,DAYOFF,TSTREC, -C BADREC,OKAREC,TBPREC) -C INPUT ARGUMENT LIST: -C NTEST - NUMBER OF RECORDS TO BE TESTED. -C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD -C - TO BE TESTED. -C DAYMN - EARLIEST (MINIMUM) DATE FOR ACCEPTANCE OF A RECORD. -C - UNITS ARE DDD.FFF, WHERE DDD=JULIAN DAY, FFF=FRAC- -C - TIONAL DAY (E.G. .5=1200 UTC). -C DAYMX1 - LATEST (MAXIMUM) DATE FOR ACCEPTANCE OF A RECORD. -C - UNITS ARE FRACTIONAL JULIAN DAYS AS IN DAYMN ABOVE. -C DAYMX2 - EARLIEST (MINIMUM) DATE FOR REJECTION OF A RECORD. -C - RECORDS WITH DATES BETWEEN DAYMX1 AND DAYMX2 ARE -C - ASSUMED TO BELONG TO A FUTURE CYCLE AND ARE THROWN -C - BACK INTO THE POND, I.E. NEITHER REJECTED OR ACCEPTED. -C - UNITS ARE FRACTIONAL JULIAN DAYS AS IN DAYMN ABOVE. -C DAYOFF - OFFSET DAYS WHEN ACCEPTANCE WINDOW CROSSES YEAR -C BOUNDARY -C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED. -C -C OUTPUT ARGUMENT LIST: -C NOKAY - NUMBER OF RECORDS THAT PASSED THE BLANK CHECK. -C NBAD - NUMBER OF RECORDS THAT FAILED THE BLANK CHECK. -C NTBP - NUMBER OF RECORDS THAT ARE TO BE RESTORED TO THE -C - INPUT FILES (THROWN BACK INTO THE POND). -C IFDTCK - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT -C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES. -C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD -C - RECORD. -C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD -C - RECORD. -C NUMTBP - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD -C - TO BE THROWN BACK INTO THE POND. -C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED -C - THE BLANK CHECK. -C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED -C - THE BLANK CHECK. -C TBPREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT ARE TO -C - BE THROWN BACK INTO THE POND. -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE DTCHK(NTEST,NOKAY,NBAD,NTBP,IFDTCK,NUMTST,NUMOKA, - 1 NUMBAD,NUMTBP,DAYMN,DAYMX1,DAYMX2,DAYOFF,TSTREC, - 2 BADREC,OKAREC,TBPREC) - - PARAMETER (NERCDT=8) - PARAMETER (MAXREC=1000) - PARAMETER (MAXTBP=20) - - SAVE - - CHARACTER*(*) TSTREC(0:NTEST),BADREC(MAXREC),OKAREC(NTEST), - 1 TBPREC(MAXTBP),ERCDT(NERCDT)*60 - - PARAMETER (MAXVIT=15) - - CHARACTER FMTVIT*6 - - DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT) - - DIMENSION FMTVIT(MAXVIT) - - EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ) - - DIMENSION RINC(5) - - DIMENSION IFDTCK(MAXREC),NUMOKA(NTEST),NUMBAD(MAXREC), - 1 NUMTST(NTEST),NUMTBP(MAXTBP),IDAMX(12) - - DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)', - 1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/, - 2 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/, - 3 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/ - - DATA NUM/1/,IYRMN/0/,IYRMX/9999/,IMOMN/1/,IMOMX/12/,IDAMN/1/, - 1 IDAMX/31,29,31,30,31,30,31,31,30,31,30,31/,IHRMN/0/, - 2 IHRMX/23/,IMINMN/0/,IMINMX/59/ - - DATA ERCDT - 1 /' 1: YEAR OUT OF RANGE ', - 2 ' 2: MONTH OUT OF RANGE ', - 3 ' 3: DAY OUT OF RANGE ', - 4 ' 4: HOUR OUT OF RANGE ', - 5 ' 5: MINUTE OUT OF RANGE ', - 6 ' 6: DATE/TIME LESS THAN ALLOWED WINDOW ', - 7 ' 7: DATE/TIME GREATER THAN ALLOWED MAXIMUM WINDOW ', - 8 '-8: DATE/TIME PROBABLY VALID AT LATER CYCLE TIME (TBIP) '/ - -C ERROR CODES FOR BAD RECORDS RETURNED IN IFDTCK ARE AS FOLLOWS: -C 1: YEAR OUT OF RANGE -C 2: MONTH OUT OF RANGE -C 3: DAY OUT OF RANGE -C 4: HOUR OUT OF RANGE -C 5: MINUTE OUT OF RANGE -C 6: DATE/TIME LESS THAN ALLOWED WINDOW -C 7: DATE/TIME GREATER THAN ALLOWED WINDOW -C -8: DATE/TIME PROBABLY VALID AT LATER CYCLE TIME (THROWN BACK -C INTO THE POND) - - WRITE(6,1) NTEST,NOKAY,NBAD,DAYMN,DAYMX1,DAYMX2 - 1 FORMAT(//'...ENTERING DTCHK, LOOKING FOR BAD DATE/TIME GROUPS. ', - 1 'NTEST,NOKAY,NBAD=',3I4,'.'/4X,'DAYMN,DAYMX1,DAYMX2=', - 2 3F12.4//) - - NADD=0 - NTBPZ=0 - DO NREC=1,NTEST - - IETYP=0 - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 TSTREC(NREC)) - ENDDO - -C CONVERT DATE/TIME TO FLOATING POINT DATE - - CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYZ) - - IF(IYR .LT. IYRMN .OR. IYR .GT. IYRMX) THEN - IETYP=1 - WRITE(6,21) IYR,IYRMN,IYRMX,TSTREC(NREC) - 21 FORMAT(/'******DECODED YEAR OUT OF ALLOWED BOUNDS, IYR,IYRMN,', - 1 'IYRMX,RECORD=',3I9/8X,A) - ENDIF - - IF(IMO .LT. IMOMN .OR. IMO .GT. IMOMX) THEN - IETYP=2 - WRITE(6,31) IMO,IMOMN,IMOMX,TSTREC(NREC) - 31 FORMAT(/'******DECODED MONTH OUT OF ALLOWED BOUNDS, IMO,IMOMN,', - 1 'IMOMX,RECORD=',3I9/8X,A/5X,'...(DAY WILL NOT BE CHECKED)') - - ELSE - IF(IDA .LT. IDAMN .OR. IDA .GT. IDAMX(IMO)) THEN - IETYP=3 - WRITE(6,41) IDA,IDAMN,IDAMX,TSTREC(NREC) - 41 FORMAT(/'******DECODED DAY OUT OF ALLOWED BOUNDS, IDA,IDAMN,', - 1 'IDAMX,RECORD=',3I9/8X,A) - ENDIF - ENDIF - - IF(IHR .LT. IHRMN .OR. IHR .GT. IHRMX) THEN - IETYP=4 - WRITE(6,51) IHR,IHRMN,IHRMX,TSTREC(NREC) - 51 FORMAT(/'******DECODED HOUR OUT OF ALLOWED BOUNDS, IHR,IHRMN,', - 1 'IHRMX,RECORD=',3I9/8X,A) - ENDIF - - IF(IMIN .LT. IMINMN .OR. IMIN .GT. IMINMX) THEN - IETYP=5 - WRITE(6,61) IMIN,IMINMN,IMINMX,TSTREC(NREC) - 61 FORMAT(/'******DECODED MINUTE OUT OF ALLOWED BOUNDS, IMIN,', - 1 'IMINMN,IMINMX,RECORD=',3I9/8X,A) - ENDIF - - IF(IETYP .EQ. 0 .AND. DAYZ+DAYOFF .LT. DAYMN) THEN - IETYP=6 - WRITE(6,71) DAYZ,DAYMN,TSTREC(NREC) - 71 FORMAT(/'******DECODED DAY LESS THAN MINIMUM WINDOW, DAYZ,DAYMN,', - 1 'RECORD=',2F12.4/8X,A) - ENDIF - - IF(IETYP .EQ. 0 .AND. DAYZ+DAYOFF .GT. DAYMX2) THEN - IETYP=7 - WRITE(6,73) DAYZ,DAYMX2,TSTREC(NREC) - 73 FORMAT(/'******DECODED DAY EXCEEDS MAXIMUM WINDOW, DAYZ,DAYMX2,', - 1 'RECORD=',2F12.4/8X,A) - ENDIF - - IF(IETYP .EQ. 0 .AND. DAYZ .GT. DAYMX1) THEN - IETYP=-8 - WRITE(6,77) DAYZ,DAYMX1,TSTREC(NREC) - 77 FORMAT(/'###DECODED DAY PROBABLY VALID AT FUTURE CYCLE TIME. ', - 1 'DAYZ,DAYMX1,RECORD=',2F12.4/8X,A/4X, 'THIS RECORD WILL ', - 2 'BE THROWN BACK IN THE POND.') - ENDIF - - IFDTCK(NUMTST(NREC))=IETYP - IF(IETYP .GT. 0) THEN - NADD=NADD+1 - NUMBAD(NADD+NBAD)=NUMTST(NREC) - BADREC(NADD+NBAD)=TSTREC(NREC) - ELSE IF(IETYP .EQ. 0) THEN - NOKAY=NOKAY+1 - NUMOKA(NOKAY)=NUMTST(NREC) - OKAREC(NOKAY)=TSTREC(NREC) - ELSE - NTBPZ=NTBPZ+1 - NUMTBP(NTBPZ)=NUMTST(NREC) - TBPREC(NTBPZ)=TSTREC(NREC) - ENDIF - - ENDDO - - NTBP=NTBPZ - WRITE(6,101) NOKAY,NADD,NTBP,NTEST,(ERCDT(NER),NER=1,NERCDT) - 101 FORMAT(//'...RESULTS OF THE DATE/TIME CHECK ARE: NOKAY=',I4, - 1 ' ,NADD=',I4,' AND NTBP=',I4,' FOR A TOTAL OF',I4, - 2 ' RECORDS.'//4X,'ERROR CODES ARE:'/(6X,A)) - - WRITE(6,103) - 103 FORMAT(/'...OKAY RECORDS ARE:',100X,'ERC'/) - DO NOK=1,NOKAY - WRITE(6,109) NOK,NUMOKA(NOK),OKAREC(NOK),IFDTCK(NUMOKA(NOK)) - 109 FORMAT(3X,I4,'...',I4,'...',A,'...',I3) - ENDDO - - WRITE(6,113) - 113 FORMAT(/'...RECORDS THAT WILL BE RETURNED TO THE INPUT FILES ', - 1 '(THROWN BACK INTO THE POND) ARE:',36X,'ERC'/) - DO NTB=1,NTBP - WRITE(6,119) NTB,NUMTBP(NTB),TBPREC(NTB), - 1 IFDTCK(NUMTBP(NTB)) - 119 FORMAT(3X,I4,'...',I4,'...',A,'...',I3) - ENDDO - - IF(NADD .GT. 0) WRITE(6,131) (NBAD+NBA,NUMBAD(NBAD+NBA), - 1 BADREC(NBAD+NBA), - 2 IFDTCK(NUMBAD(NBAD+NBA)), - 3 NBA=1,NADD) - 131 FORMAT(/' ADDED BAD RECORDS ARE:',95X,'ERC'/(3X,I4,'...',I4, - 1 '...',A,'...',I3)) - NBAD=NBAD+NADD - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: SETMSK CHECKS ALL RECORDS FOR CORRECT LAT/LON -C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01 -C -C ABSTRACT: INPUT RECORDS ARE CHECKED FOR PHYSICALLY REALISTIC -C LATITUDE AND LONGITUDE (-70 Read in RECORD from tcvitals file -- contains a', - $ ' 2-digit year "',SCRATC(NCHECK)(20:21),'"' - PRINT *, ' ' - PRINT *, 'From unit ',iuntho,'; SCRATC(NCHECK)-9: ', - $ scratc(ncheck) - PRINT *, ' ' - DUMY2K(1:19) = SCRATC(NCHECK)(1:19) - IF(SCRATC(NCHECK)(20:21).GT.'20') THEN - DUMY2K(20:21) = '19' - ELSE - DUMY2K(20:21) = '20' - ENDIF - DUMY2K(22:100) = SCRATC(NCHECK)(20:100) - SCRATC(NCHECK) = DUMY2K - PRINT *, ' ' - PRINT *, '==> 2-digit year converted to 4-digit year "', - $ SCRATC(NCHECK)(20:23),'" via windowing technique' - PRINT *, ' ' - PRINT *, 'From unit ',IUNTHo,'; SCRATC(NCHECK)-9: ', - $ scratc(ncheck) - PRINT *, ' ' - - ELSE IF(SCRATC(NCHECK)(37:37).EQ.'N' .OR. - 1 SCRATC(NCHECK)(37:37).EQ.'S') THEN - -C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR -C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 4-digit year "',SCRATC(NCHECK)(20:23),'"' - PRINT *, ' ' - PRINT *, 'From unit ',iuntho,'; SCRATC(NCHECK)-9: ', - $ SCRATC(NCHECK) - PRINT *, ' ' - PRINT *, '==> No conversion necessary' - PRINT *, ' ' - - ELSE - - PRINT *, ' ' - PRINT *, '***** Cannot determine if this record contains ', - $ 'a 2-digit year or a 4-digit year - skip it and try reading ', - $ 'the next record' - PRINT *, ' ' - GO TO 30 - - END IF - - WRITE(6,19) NCHECK,SCRATC(NCHECK) - NCPY=NCPY+1 - NCHECK=NCHECK+1 - GO TO 30 - - 40 CONTINUE - NCHECK=NCHECK-1 - WRITE(6,41) NCPY,NCHECK - 41 FORMAT('...',I3,' RECORDS COPIED FOR A TOTAL OF ',I4,' TO BE ', - 1 'CHECKED.') - - NADD=0 - DO NREC=1,NTEST - -C INITIALIZE THE CHARACTER STRING AND ERROR CODE - - BUFINZ=TSTREC(NREC) - IETYP=0 - NDUP =0 - -C SET THE FLAG FOR ERROR TYPE=4 (PREVIOUS RECORD WITH DUPLICATE -C RSMC, DATE/TIME AND STORM ID APPEARS TO BE VALID) - -C RECORDS THAT WERE MARKED ERRONEOUS EARLIER DO NOT RECEIVE -C FURTHER PROCESSING WITH THIS VERSION OF THE CODE. - - IF(IDUPID(NREC) .GT. 0) THEN - IETYP=IDUPID(NREC) - GO TO 190 - ENDIF - -C BASIN CHECK - - NIDBSN=999 - DO NBA=1,NBASIN - IF(STMIDZ(3:3) .EQ. IDBASN(NBA)) THEN - NIDBSN=NBA - ENDIF - ENDDO - - IF(NIDBSN .GT. 130) THEN - IETYP=1 - WRITE(6,51) NREC,STMIDZ(3:3),(IDBASN(NBA),NBA=1,NBASIN),NNNREC, - 1 ZZZREC,TSTREC(NREC) - 51 FORMAT(/'******RECORD #',I3,' HAS BAD BASIN CODE=',A1,'. ALLOWED', - 2 ' CODES ARE:',1X,11(A1,1X)/2(1X,'@@@',A,'@@@'/),4X,A) - -C CHECK THAT THE LAT/LON CORRESPONDS TO A VALID BASIN - - ELSE - DO IV=3,4 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 TSTREC(NREC)) - VITVAR(IV)=REAL(IVTVAR(IV))*VITFAC(IV) - ENDDO - IF(LATNS .EQ. 'S') STMLTZ=-STMLTZ - IF(LONEW .EQ. 'W') STMLNZ=360.-STMLNZ - CALL BASNCK(STMIDZ,STMLTZ,STMLNZ,NBAZ,IPRT,IER) - IF(IER .EQ. 3) THEN - IETYP=6 - WRITE(6,61) NREC,STMIDZ,STMLTZ,STMLNZ,IETYP,NNNREC,ZZZREC, - 1 TSTREC(NREC) - 61 FORMAT(/'******RECORD #',I3,' WITH STMID=',A,' HAS LAT/LON ', - 1 'OUTSIDE BASIN LIMITS. LAT/LON=',2F9.1,' IETYP=',I3/ - 2 2(1X,'@@@',A,'@@@'/),4X,A) - ENDIF - ENDIF - - IF(IETYP .EQ. 0) THEN - -C CHECK CODED STORM ID NUMBER: ID NUMBERS GREATER >= 80 ARE -C CONSIDERED ERRONEOUS. ! CHG. TESTID - - CALL DECVAR(ISTIDC,ISTIDC+ITWO-1,KSTORM,IERDEC,'(I2.2)', - 1 STMIDZ) - IF(KSTORM .LT. 1 .OR. KSTORM .GE. ISTMAX .OR. IERDEC .NE. 0) THEN - IETYP=2 - IF(KSTORM .GE. ISTMAX .AND. KSTORM .LT. 100) THEN - WRITE(6,94) NREC,STMIDZ(ISTIDC:ISTIDC+ITWO-1),NNNREC,ZZZREC, - 1 TSTREC(NREC) - 94 FORMAT(/'******RECORD #',I3,' HAS TEST STORM NUMBER=',A2, - 1 ' -- CONSIDER IT BAD'/2(1X,'@@@',A,'@@@'/),4X,A) - ELSE - WRITE(6,63) NREC,STMIDZ(ISTIDC:ISTIDC+ITWO-1),NNNREC,ZZZREC, - 1 TSTREC(NREC) - 63 FORMAT(/'******RECORD #',I3,' HAS BAD STORM NUMBER=',A2/ - 1 2(1X,'@@@',A,'@@@'/),4X,A) - END IF - ENDIF - -C CHECK CONSISTENCY BETWEEN STORM NAME AND STORM ID, PRESENT AND -C PAST. FIRST, CHECK FOR EXACT DUPLICATES IN THE INPUT AND -C SHORT-TERM HISTORY FILES. - - IF(IETYP .EQ. 0) THEN - DO NCK=NCHECK,NREC+1,-1 - BUFINX=SCRATC(NCK) - - IF(NCK .GT. NTEST .AND. BUFINZ(1:IFSTFL-1) .EQ. - 1 BUFINX(1:IFSTFL-1) .AND. - 2 BUFINZ(IFSTFL+1:MAXCHR) .EQ. - 3 BUFINX(IFSTFL+1:MAXCHR)) THEN - IETYP=9 - WRITE(6,64) NREC,NCK,NNNREC,ZZZREC,TSTREC(NREC),SCRATC(NCK) - 64 FORMAT(/'******RECORD #',I3,' IS IDENTICAL TO RECORD #',I3, - 1 ' WHICH IS FROM THE ORIGINAL SHORT-TERM HISTORY FILE.'/4X, - 2 'RECORDS ARE:'/2(1X,'@@@',A,'@@@'/),2(4X,A/)) - GO TO 71 - ENDIF - - IF(RSMCX .EQ. RSMCZ) THEN - -C DISABLE THE FOLLOWING TWO CHECKS IN THE CASE OF A CARDINAL -C TROPICAL STORM IDENTIFIER - - DO NCARD=1,NCRDMX - IF(STMNMZ(1:ICRDCH(NCARD)) .EQ. CARDNM(NCARD)(1:ICRDCH(NCARD)) - 1 .OR. - 2 STMNMX(1:ICRDCH(NCARD)) .EQ. CARDNM(NCARD)(1:ICRDCH(NCARD))) - 3 THEN - WRITE(6,1147) STMNMZ(1:ICRDCH(NCARD)), - 1 STMNMX(1:ICRDCH(NCARD)),NCARD,ICRDCH(NCARD) - 1147 FORMAT(/'...WE HAVE FOUND A MATCHING NAME FOR "',A,'" OR "',A, - 1 '" AT CARDINAL INDEX',I3,', FOR CHARACTERS 1-',I2,'.'/4X, - 2 'NAME CHECKING IS HEREBY DISABLED.') - GO TO 71 - ENDIF - ENDDO - -C SAME NAME BUT DIFFERENT ID - - IF(STMNMZ .NE. 'NAMELESS' .AND. - 1 STMNMZ .EQ. STMNMX .AND. STMIDZ .NE. STMIDX) THEN - IETYP=7 - IF(NCK .GT. NTEST) WRITE(6,65) NREC,STMNMZ,STMIDZ,NCK,STMIDX, - 1 NNNREC,ZZZREC,TSTREC(NREC),SCRATC(NCK) - 65 FORMAT(/'******RECORD #',I3,' HAS NAME=',A,' AND ID=',A,', BUT ', - 1 'ID IS DIFFERENT FROM VALIDATED ORIGINAL SHORT-TERM ', - 2 'HISTORY RECORD',I3/4X,' WHICH IS ',A,'. RECORDS ARE:'/ - 3 2(1X,'@@@',A,'@@@'/),2(4X,A/)) - IF(NCK .LE. NTEST) WRITE(6,66) NREC,STMNMZ,STMIDZ,NCK,STMIDX, - 1 NNNREC,ZZZREC,TSTREC(NREC),SCRATC(NCK) - 66 FORMAT(/'******RECORD #',I3,' HAS NAME=',A,' AND ID=',A,', BUT ', - 1 'ID IS DIFFERENT FROM TEST RECORD WITH LARGER INDEX',I3, - 2 ' WHICH IS ',A,'.'/4X,'RECORDS ARE:'/2(1X,'@@@',A,'@@@'/), - 3 2(4X,A/)) - IF(RSMCZ .EQ. 'JTWC' .AND. STMIDZ(1:2) .EQ. STMIDX(1:2)) THEN - IETYP=-7 - WRITE(6,165) - 165 FORMAT('###OBSERVER IS JTWC. BASIN NOT GUARANTEED TO BE ', - 1 'CONSISTENT. IETYP=-7.') - ENDIF - IF(IETYP .GT. 0) GO TO 71 - ENDIF - -C SAME ID BUT DIFFERENT NAME: NEITHER IS NAMELESS - - IF(STMNMZ .NE. 'NAMELESS' .AND. STMNMX .NE. 'NAMELESS') THEN - IF(STMIDZ .EQ. STMIDX .AND. STMNMZ .NE. STMNMX .AND. - 1 RELOCZ .EQ. ' ' .AND. RELOCX .EQ. ' ') THEN - IETYP=8 - IF(NCK .GT. NTEST) WRITE(6,67) NREC,STMIDZ,STMNMZ,NCK,STMIDX, - 1 NNNREC,ZZZREC,TSTREC(NREC),SCRATC(NCK) - 67 FORMAT(/'******RECORD #',I3,' HAS ID=',A,' AND NAME=',A,', BUT ', - 1 'NAME IS DIFFERENT FROM VALIDATED ORIGINAL'/7X,'SHORT-', - 2 'TERM HISTORY RECORD',I3,' WHICH IS ',A,'.'/7X,'RECORDS ', - 3 'ARE:'/2(1X,'@@@',A,'@@@'/),2(4X,A/)) - IF(NCK .LE. NTEST) WRITE(6,68) NREC,STMIDZ,STMNMZ,NCK,STMIDX, - 1 NNNREC,ZZZREC,TSTREC(NREC),SCRATC(NCK) - 68 FORMAT(/'******RECORD #',I3,' HAS ID=',A,' AND NAME=',A,', BUT ', - 1 'NAME IS DIFFERENT FROM TEST RECORD WITH LARGER INDEX',I3, - 2 ' WHICH IS ',A,'.'/4X,'RECORDS ARE:'/2(1X,'@@@',A,'@@@'/), - 3 2(4X,A/)) - GO TO 71 - ENDIF - ENDIF - - ENDIF - ENDDO - 71 CONTINUE - ENDIF - -C CHECK FOR RECORDS WITH IDENTICAL RSMC, DATE/TIME GROUP AND -C STORM ID. SINCE THE CURRENT RECORD IS FIRST, WE WILL SUPERCEDE -C IT WITH THE LATER RECORD - - IF(IETYP .EQ. 0) THEN - DO NCK=NREC+1,NTEST - BUFINX=TSTREC(NCK) - CALL DECVAR(ISTIDC,ISTIDC+ITWO-1,KSTMX,IERDEC,'(I2.2)', - 1 STMIDX) - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 TSTREC(NREC)) - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV), - 1 TSTREC(NCK )) - ENDDO - - DO NBA=1,NBASIN - IF(STMIDX(3:3) .EQ. IDBASN(NBA)) THEN - NIDBSX=NBA - GO TO 91 - ENDIF - ENDDO - - 91 IF(RSMCX .EQ. RSMCZ .AND. - 1 IDATEX .EQ. IDATEZ .AND. - 2 IUTCX .EQ. IUTCZ .AND. - 3 NIDBSX .EQ. NIDBSN .AND. - 4 KSTMX .EQ. KSTORM) THEN - -C ACCUMULATE ALL RECORDS THAT HAVE THE SAME RSMC, DATE/TIME AND -C STORM ID FOR PROCESSING - - IF(NDUP .LT. NDUPMX) THEN - NDUP=NDUP+1 - INDXDP(NDUP)=NCK - - ELSE - WRITE(6,93) RSMCZ,IDATEZ,IUTCZ,STMIDZ,NDUPMX - 93 FORMAT(/'******NUMBER OF RECORDS WITH SAME RSMC=',A,', DATE=',I9, - 1 ', TIME=',I5,' AND STORM ID=',A/7X,'EXCEEDS THE MAXIMUM=', - 2 I3,'. THE PROGRAM WILL TERMINATE!!') - CALL ABORT1('STIDCK ',53) - ENDIF - - ENDIF - ENDDO - - IF(NDUP .GT. 0) THEN - CALL FIXDUP(IUNTHO,NTEST,NREC,NDUP,INDXDP,TSTREC,ZZZREC,NNNREC, - 1 IETYP) - IF(IETYP .EQ. 4) THEN - DO NDU=1,NDUP - WRITE(6,109) NDU,IABS(INDXDP(NDU)),IETYP - 109 FORMAT(/'...DUPLICATE RECORD',I3,' WITH INDEX=',I3,' HAS ', - 1 'PROBABLE DATE/TIME ERROR=',I3) - IF(INDXDP(NDU) .LT. 0) IDUPID(IABS(INDXDP(NDU)))=IETYP - ENDDO - -C CLEAR THE ERROR FLAG FOR THE CURRENT RECORD!!! - - IETYP=0 - ENDIF - ENDIF - - ENDIF - - IF(IETYP .EQ. 0) THEN - -C SKIP STORM NAME CHECK IF STORM NAME='NAMELESS' OR BASIN IS -C NEITHER ATLANTIC OR EAST PACIFIC - - IF(STMNMZ .EQ. 'NAMELESS') THEN - WRITE(6,113) STMNMZ - 113 FORMAT(/'...STORM NAME IS ',A9,' SO NO NAME CHECKING WILL BE ', - 1 'DONE') - GO TO 190 - ENDIF - - IF(NIDBSN .LE. 4) THEN - IF(NIDBSN .LE. 2) THEN - NSTBSN=-1 - DO NST=1,NSTMAX - IF(STMNMZ .EQ. STBASN(NST,NIDBSN,IYRNAM)) THEN -C WRITE(6,117) STMNMZ,NST,NIDBSN,IYRNAM -C 117 FORMAT(/'...WE HAVE FOUND MATCHING NAME FOR ',A,' AT INDEX=',I4, -C 1 ', FOR NIDBSN,IYRNAM=',2I4) - NSTBSN=NST - GO TO 171 - ENDIF - ENDDO - -C FOR EAST PACIFIC STORM IDS, CHECK THAT THEY MAY HAVE BEEN NAMED -C IN THE CENTRAL PACIFIC - - IF(NIDBSN .EQ. 2) THEN - NSTBSN=-1 - DO NST=1,NSMXCP - IF(STMNMZ .EQ. STBACP(NST)) THEN - NSTBSN=NST - GO TO 171 - ENDIF - ENDDO - ENDIF - - ELSE IF(NIDBSN .EQ. 3) THEN - NSTBSN=-1 - DO NST=1,NSMXCP - IF(STMNMZ .EQ. STBACP(NST)) THEN - NSTBSN=NST - GO TO 171 - ENDIF - ENDDO - - ELSE IF(NIDBSN .EQ. 4) THEN - NSTBSN=-1 - DO NST=1,NSMXWP - IF(STMNMZ .EQ. STBAWP(NST)) THEN - NSTBSN=NST - GO TO 171 - ENDIF - ENDDO - ENDIF - -C CHECK FOR CARDINAL NUMBER IDENTIFIER FOR AS YET UNNAMED STORMS - - DO NCARD=1,NCRDMX - IF(STMNMZ(1:ICRDCH(NCARD)) .EQ. CARDNM(NCARD)(1:ICRDCH(NCARD))) - 1 THEN - WRITE(6,147) STMNMZ(1:ICRDCH(NCARD)),NCARD,ICRDCH(NCARD) - 147 FORMAT(/'...WE HAVE FOUND MATCHING NAME FOR "',A,'" AT CARDINAL ', - 1 'INDEX',I3,', FOR CHARACTERS 1-',I2,'.') - NSTBSN=NCARD - GO TO 171 - ENDIF - ENDDO - -C CHECK FOR GREEK NAMES - - DO NGRK=1,NGRKMX - IF(STMNMZ(1:IGRKCH(NGRK)) .EQ. GREKNM(NGRK)(1:IGRKCH(NGRK))) - 1 THEN - WRITE(6,157) STMNMZ(1:IGRKCH(NGRK)),NGRK,IGRKCH(NGRK) - 157 FORMAT(/'...WE HAVE FOUND MATCHING GREEK NAME FOR "',A,'" AT ', - 1 'GREEK INDEX',I3,', FOR CHARACTERS 1-',I2,'.') - NSTBSN=NGRK - GO TO 171 - ENDIF - ENDDO - - 171 IF(NSTBSN .LT. 0) THEN - IETYP=5 - WRITE(6,173) NREC,STMNMZ,NIDBSN,IYRNAM,NNNREC,ZZZREC,TSTREC(NREC) - 173 FORMAT(/'+++RECORD #',I3,' HAS BAD STORM NAME=',A9,'. NIDBSN,', - 1 'IYRNAM=',2I4/4X,'ERROR RECOVERY WILL BE CALLED FOR THIS', - 2 ' RECORD:'/2(1X,'@@@',A,'@@@'/),4X,A) - - CALL FIXNAM(IUNTCA,NIDBSN,IYR,IETYP,STMNMZ,TSTREC(NREC)) - - ENDIF - - ELSE - WRITE(6,181) IDBASN(NIDBSN),STMNMZ - 181 FORMAT('...VALID BASIN ID=',A1,' DOES NOT ALLOW STORM NAME CHECK', - 1 ' AT THIS TIME. NAME=',A9) - ENDIF - - ENDIF - - ENDIF - - 190 IFSTCK(NUMTST(NREC))=IETYP - IF(IETYP .GT. 0) THEN - NADD=NADD+1 - NUMBAD(NADD+NBAD)=NUMTST(NREC) - BADREC(NADD+NBAD)=TSTREC(NREC) - ELSE - NOKAY=NOKAY+1 - NUMOKA(NOKAY)=NUMTST(NREC) - OKAREC(NOKAY)=TSTREC(NREC) - ENDIF - - ENDDO - - WRITE(6,201) NOKAY,NADD,NTEST,(ERCID(NER),NER=1,NERCID) - 201 FORMAT(//'...RESULTS OF THE STORM ID CHECK ARE: NOKAY=',I4,' AND', - 1 ' NADD=',I4,' FOR A TOTAL OF ',I4,' RECORDS.'//4X, - 2 'ERROR CODES ARE:'/(6X,A)) - WRITE(6,203) - 203 FORMAT(/'...OKAY RECORDS ARE:',100X,'ERC'/) - DO NOK=1,NOKAY - WRITE(6,209) NOK,NUMOKA(NOK),OKAREC(NOK),IFSTCK(NUMOKA(NOK)) - 209 FORMAT(3X,I4,'...',I4,'...',A,'...',I3) - ENDDO - IF(NADD .GT. 0) WRITE(6,211) (NBAD+NBA,NUMBAD(NBAD+NBA), - 1 BADREC(NBAD+NBA), - 2 IFSTCK(NUMBAD(NBAD+NBA)), - 3 NBA=1,NADD) - 211 FORMAT(/' ADDED BAD RECORDS ARE:',95X,'ERC'/(3X,I4,'...',I4, - 1 '...',A,'...',I3)) - NBAD=NBAD+NADD - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FIXDUP ERROR RECOVERY FOR PARTIAL DUPLICATE RECS -C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01 -C -C ABSTRACT: ERROR RECOVERY FOR PARTIAL DUPLICATE RECORDS. PARTIAL -C DUPLICATE RECORDS ARE DEFINED AS THOSE WITH IDENTICAL RSMC, STORM -C ID & NAME, AND DATE/TIME. THE ERROR RECOVERY PROCEDURE BEGINS BY -C TRYING TO FIND A PREVIOUS RECORD FOR THE TARGET RECORD, WHICH IS -C DEFINED AS THE FIRST OF THE DUPLICATE RECORDS (ALL SUBSEQUENT -C RECORDS ARE DEFINED AS "DUPLICATES"). THE CURRENT RECORDS ARE -C SEARCHED FIRST, THEN THE SHORT-TERM HISTORY FILE IS SEARCHED. -C IF NO PREVIOUS RECORDS ARE FOUND ANYWHERE, THE DEFAULT DECISION IS -C TO KEEP THE LAST OF THE DUPLICATES, UNDER THE ASSSUMPTION THAT -C THE DUPLICATE RECORDS ARE UPDATE RECORDS FOR THE SAME STORM. -C IF A PREVIOUS RECORD IS FOUND, ITS EXTRAPOLATED POSITION IS COMPARED -C WITH THE TARGET RECORD AND THE DUPLICATE RECORDS. IF THE TARGET -C POSITION ERROR IS GREATER THAN THE DUPLICATE POSITION, THE -C TARGET RECORD IS CONSIDERED ERROREOUS. IF THE TARGET POSITION ERROR -C IS LESS THAN THE DUPLICATE POSITION ERROR, THE DUPLICATE POSITION -C IS CHECKED AGAINST AN EXTRAPOLATED FUTURE POSITION. IF THAT ERROR -C IS LESS THAN FOR THE CURRENT POSITION, IT IS ASSUMED THAT THE -C DUPLICATE RECORD HAS A DATE/TIME ERROR. IF THE DUPLICATE POSITION -C ERROR IS LARGER FOR THE FUTURE TIME, IT IS ASSUMED THAT THE -C DUPLICATE RECORD IS AN UPDATE RECORD WHICH SUPERCEDES THE TARGET. -C -C PROGRAM HISTORY LOG: -C 1990-11-01 S. LORD -C -C USAGE: CALL FIXDUP(IUNTHO,NTEST,NREC,NDUP,INDXDP,TSTREC,ZZZREC, -C NNNREC,IETYP) -C INPUT ARGUMENT LIST: -C IUNTHO - UNIT NUMBER FOR SHORT-TERM HISTORY FILE. -C NTEST - TOTAL NUMBER OF RECORDS AVAILABLE (DIMENSION OF TSTREC) -C NREC - INDEX NUMBER OF TARGET RECORD -C NDUP - NUMBER OF DUPLICATE RECORDS -C INDXDP - INTEGER ARRAY CONTAINING INDEX NUMBERS OF -C - DUPLICATE RECORDS -C TSTREC - CHARACTER ARRAY OF INPUT RECORDS. -C ZZZREC - CHARACTER VARIABLE CONTAINING VARIABLE NAMES. -C NNNREC - CHARACTER VARIABLE CONTAINING COLUMN NUMBERS. -C -C OUTPUT ARGUMENT LIST: -C IETYP - ERROR CODE -C -C INPUT FILES: -C UNIT 21 - SHORT-TERM HISTORY FILE -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE FIXDUP(IUNTHO,NTEST,NREC,NDUP,INDXDP,TSTREC,ZZZREC, - 1 NNNREC,IETYP) - - PARAMETER (MAXSTM=70) - - SAVE - - CHARACTER*(*) TSTREC(0:NTEST),ZZZREC,NNNREC - - DIMENSION INDXDP(NDUP) - - DIMENSION RINC(5) - - CHARACTER STMNAM*9,STMID*3,RSMC*4 - - LOGICAL FSTFLG - - DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM), - 1 STMDIR(MAXSTM),STMSPD(MAXSTM),IDATE(MAXSTM), - 2 IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM),PCEN(MAXSTM), - 3 PTOP(MAXSTM),RSMC(MAXSTM),RMW(MAXSTM),VMAX(MAXSTM), - 4 R15NW(MAXSTM),R15NE(MAXSTM),R15SE(MAXSTM),R15SW(MAXSTM), - 5 STMID(MAXSTM),FSTFLG(MAXSTM) - - PARAMETER (MAXCHR=95) - PARAMETER (MAXVIT=15) - PARAMETER (NBASIN=11) - - CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1, - 1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1,IDBASN*1 - - DIMENSION IVTVAR(MAXVIT),VITVAR(MAXVIT),VITFAC(MAXVIT), - 1 ISTVAR(MAXVIT),IENVAR(MAXVIT) - - DIMENSION IDBASN(NBASIN),BUFIN(MAXCHR),FMTVIT(MAXVIT) - - EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ), - 1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ), - 2 (BUFIN(37),LATNS),(BUFIN(43),LONEW), - 3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ) - - EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ) - - EQUIVALENCE (VITVAR( 3),STMLTZ),(VITVAR( 4),STMLNZ), - 1 (VITVAR( 5),STMDRZ),(VITVAR( 6),STMSPZ) - - DIMENSION IVTVRX(MAXVIT),VITVRX(MAXVIT) - - CHARACTER BUFCK(MAXCHR)*1,RSMCX*4,RELOCX*1,STMIDX*3,LATNSX*1, - 1 LONEWX*1,BUFINX*100 - - EQUIVALENCE (BUFCK(1),RSMCX),(BUFCK(5),RELOCX),(BUFCK(6),STMIDX), - 1 (BUFCK(35),LATNSX),(BUFCK(41),LONEWX), - 2 (BUFCK(1),BUFINX) - - EQUIVALENCE (IVTVRX(1),IDATEX),(IVTVRX(2),IUTCX), - 1 (VITVRX(3),STMLTX),(VITVRX(4),STMLNX), - 2 (VITVRX(5),STMDRX),(VITVRX(6),STMSPX) - - DATA VITFAC/2*1.0,2*0.1,1.0,0.1,9*1.0/, - 1 FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)', - 2 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/, - 3 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/, - 4 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/ - - DATA IDBASN/'L','E','C','W','O','T','U','P','S','B','A'/ - -C IPRNT : CONTROLS PRINTING IN SUBROUTINE NEWVIT -C FACSPD: CONVERSION FACTOR FOR R(DEG LAT)=V(M/S)*T(FRAC DAY)* -C FACSPD - - DATA NUM/1/,ITWO/2/,ISTIDC/1/,IPRNT/0/,FACSPD/0.77719/, - 1 IHRWIN/0/ - - WRITE(6,1) NDUP,NTEST,NREC - 1 FORMAT(/'...ENTERING FIXDUP WITH ',I3,' DUPLICATE RECORDS AND',I4, - 1 ' TOTAL RECORDS. TARGET RECORD TO BE CHECKED HAS INDEX=', - 2 I3) - -C RECOVER STORM ID, DATE,TIME ETC FROM THE TARGET RECORD - - BUFINZ=TSTREC(NREC) - CALL DECVAR(ISTIDC,ISTIDC+ITWO-1,KSTORM,IERDEC,'(I2.2)', - 1 STMIDZ) - DO IV=1,6 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 BUFINZ) - VITVAR(IV)=IVTVAR(IV)*VITFAC(IV) - ENDDO - IF(LATNS .EQ. 'S') STMLTZ=-STMLTZ - IF(LONEW .EQ. 'W') STMLNZ=360.-STMLNZ - CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYZ) - - WRITE(6,7) BUFINZ,(INDXDP(ND),TSTREC(INDXDP(ND)),ND=1,NDUP) - 7 FORMAT('...TARGET RECORD FOR COMPARISON IS:'/10X,A/4X, - 1 'DUPLICATE RECORDS ARE:'/(4X,I4,2X,A)) -C WRITE(6,9) STMLTZ,STMLNZ,STMDRZ,STMSPZ -C 9 FORMAT('...LAT/LON, DIR/SPD OF TARGET RECORD ARE ',4F10.3) - -C CHECK IF THERE ARE ANY PREVIOUS RECORDS IN TSTREC - - INDCLO=-99 - DTCLO=1.E10 - DO NCK=1,NTEST - BUFINX=TSTREC(NCK) - CALL DECVAR(ISTIDC,ISTIDC+ITWO-1,KSTMX,IERDEC,'(I2.2)', - 1 STMIDX) - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV), - 1 TSTREC(NCK)) - ENDDO - - DO NBA=1,NBASIN - IF(STMIDX(3:3) .EQ. IDBASN(NBA)) NIDBSX=NBA - IF(STMIDZ(3:3) .EQ. IDBASN(NBA)) NIDBSN=NBA - ENDDO - - IF(RSMCX .EQ. RSMCZ .AND. - 1 NIDBSX .EQ. NIDBSN .AND. - 2 KSTMX .EQ. KSTORM .AND. - 3 NCK .NE. NREC ) THEN - CALL ZTIME(IDATEX,IUTCX,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYX) -C WRITE(6,53) NCK,IDATEX,IUTCX,DAYX -C 53 FORMAT('...INDEX,DATE,TIME OF SAME STORM ARE:',I3,I9,I5,F10.3) - - IF(DAYX .LT. DAYZ .AND. DAYZ-DAYX .LT. DTCLO) THEN - INDCLO=NCK - DTCLO=DAYZ-DAYX - ENDIF - - ENDIF - - ENDDO - - IF(INDCLO .GT. 0) THEN - BUFINX=TSTREC(INDCLO) - DO IV=3,6 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV), - 1 BUFINX) - VITVRX(IV)=IVTVRX(IV)*VITFAC(IV) - ENDDO - IF(LATNSX .EQ. 'S') STMLTX=-STMLTX - IF(LONEWX .EQ. 'W') STMLNX=360.-STMLNX - CALL DS2UV(USTM,VSTM,STMDRX,STMSPX) - - ELSE - WRITE(6,77) IUNTHO - 77 FORMAT(/'...PREVIOUS STORM RECORD COULD NOT BE FOUND IN CURRENT ', - 1 'RECORDS. WE WILL LOOK IN THE SHORT-TERM HISTORY FILE, ', - 2 'UNIT=',I3) - -C SCAN HISTORICAL FILE FOR ALL OCCURRENCES OF EACH STORM. -C SAVE THE LATEST TIME FOR USE LATER. - - IOPT=5 - IDTREQ=IDATEZ - STMID(1)=STMIDZ - CALL NEWVIT(IUNTHO,IPRNT,IOPT,IERVIT,MAXSTM,KSTORM,IDTREQ,IHRREQ, - 1 IHRWIN,IDATE,IUTC,STMLAT,STMLON,STMDIR,STMSPD, - 2 PCEN,PENV,RMAX,VMAX,RMW,R15NE,R15SE,R15SW,R15NW, - 3 PTOP,FSTFLG,STMNAM,STMID,RSMC) - - IF(KSTORM .GT. 0) THEN - DO KST=1,KSTORM - CALL ZTIME(IDATE(KST),IUTC(KST),IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYX) -C WRITE(6,79) KST,DAYX,DAYZ -C 79 FORMAT('...INDEX,DAYX, DAYZ FROM ST. TERM HIST. FILE=',I3,2F10.3) - IF(DAYZ-DAYX .LT. DTCLO) THEN - INDCLO=KST - DTCLO=DAYZ-DAYX - ENDIF - ENDDO - - CALL DS2UV(USTM,VSTM,STMDIR(INDCLO),STMSPD(INDCLO)) - STMLTX=STMLAT(INDCLO) - STMLNX=STMLON(INDCLO) - - ELSE - WRITE(6,97) - 97 FORMAT('###PREVIOUS RECORD COULD NOT BE FOUND ANYWHERE. ', - 1 'THEREFORE, WE MAKE THE ARBITRARY, BUT NECESSARY DECISION'/ - 2 4X,'TO RETAIN THE LAST DUPLICATE RECORD.') - - IETYP=3 - WRITE(6,99) NREC,INDXDP(NDUP),NNNREC,ZZZREC,TSTREC(NREC), - 1 TSTREC(INDXDP(NDUP)) - 99 FORMAT(/'******RECORD #',I3,' WILL BE SUPERCEDED BY RECORD #',I3, - 1 ', WHICH ARRIVED LATER AND HAS IDENTICAL RSMC, DATE/TIME', - 2 ' AND STORM ID'/2(1X,'@@@',A,'@@@'/),2(4X,A/)) - RETURN - ENDIF - - ENDIF - -C SAVE THE PREVIOUS FIX POSITION AND EXTRAPOLATE IT -C TO THE CURRENT TIME - - PRVLAT=STMLTX - PRVLON=STMLNX - EXTLAT=PRVLAT+VSTM*DTCLO*FACSPD - EXTLON=PRVLON+USTM*DTCLO*FACSPD - - EXTERZ=DISTSP(STMLTZ,STMLNZ,EXTLAT,EXTLON)*1.E-3 - WRITE(6,95) STMLTZ,STMLNZ,EXTERZ - 95 FORMAT(/'...LAT/LON,EXTRAPOLATION ERROR FOR RECORDS ARE:'/4X, - 1 'TARGET:',9X,3F10.3) - - DO NDU=1,NDUP - BUFINX=TSTREC(INDXDP(NDU)) - DO IV=3,4 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVRX(IV),IERDEC,FMTVIT(IV), - 1 BUFINX) - VITVRX(IV)=IVTVRX(IV)*VITFAC(IV) - ENDDO - IF(LATNSX .EQ. 'S') STMLTX=-STMLTX - IF(LONEWX .EQ. 'W') STMLNX=360.-STMLNX - EXTERD=DISTSP(STMLTX,STMLNX,EXTLAT,EXTLON)*1.E-3 - WRITE(6,111) NDU,STMLTX,STMLNX,EXTERD - 111 FORMAT('...DUP. RECORD:',I4,3F10.3) - - IF(EXTERD .GT. EXTERZ) THEN - EXTLT2=PRVLAT+VSTM*DTCLO*FACSPD*2.0 - EXTLN2=PRVLON+USTM*DTCLO*FACSPD*2.0 - EXTER2=DISTSP(STMLTX,STMLNX,EXTLT2,EXTLN2)*1.E-3 - WRITE(6,113) NDU,EXTLT2,EXTLN2,EXTER2 - 113 FORMAT('...2XDT EXTRAP:',I4,3F10.3) - -C IF THE DIFFERENCE BETWEEN THE DUPLICATE POSITION AND -C AN EXTRAPOLATED POSITION TO A FUTURE CYCLE IS LESS -C THAN THE DIFFERENCE AT THE CURRENT TIME, WE ASSUME -C THAT THE DUPLICATE HAS A BAD DATE/TIME, I.E. THAT IT -C IS VALID A A LATER TIME. CURRENTLY THERE IS NO ERROR -C RETRIEVAL FOR THE DATE/TIME GROUP SO THAT THIS RECORD -C IS MARKED TO BE IN ERROR BY MAKING THE INDEX NEGATIVE. - - IF(EXTER2 .LT. EXTERD) THEN - IETYP=4 - INDXDP(NDU)=-INDXDP(NDU) - WRITE(6,117) IETYP,INDXDP(NDU) - 117 FORMAT(/'...DUPLICATE HAS DIFFERENCE WITH EXTRAPOLATED POSITION ', - 1 'TO FUTURE TIME THAT IS LESS THAN FOR CURRENT TIME.'/4X, - 2 'THEREFORE, WE CONCLUDE THAT THERE IS A DATE/TIME ERROR ', - 3 'IN THE DUPLICATE RECORD (IETYP=',I3,').'/4X,'THE INDEX=', - 4 I3,' IS MARKED NEGATIVE TO INDICATE AN ERROR.') - - ELSE - IETYP=3 - WRITE(6,119) NREC,INDXDP(NDUP),NNNREC,ZZZREC,TSTREC(NREC), - 1 TSTREC(INDXDP(NDUP)) - 119 FORMAT(/'...DUPLICATE HAS DIFFERENCE WITH EXTRAPOLATED FUTURE ', - 1 'POSITION GREATER THAN THAT FOR CURRENT POSITION.'/ - 2 ' ******RECORD #',I3,' WILL BE SUPERCEDED BY RECORD #',I3, - 3 ', WHICH ARRIVED LATER AND HAS IDENTICAL RSMC, DATE/TIME', - 4 ' AND STORM ID'/2(1X,'@@@',A,'@@@'/),2(4X,A/)) - ENDIF - - ELSE - IETYP=3 - WRITE(6,121) NREC,INDXDP(NDUP),NNNREC,ZZZREC,TSTREC(NREC), - 1 TSTREC(INDXDP(NDUP)) - 121 FORMAT(/'...DUPLICATE HAS DIFFERENCE WITH EXTRAPOLATED PAST ', - 1 'POSITION LESS THAN OR EQUAL TO THAT FOR TARGET.'/ - 2 ' ******RECORD #',I3,' WILL BE SUPERCEDED BY RECORD #',I3, - 3 ', WHICH ARRIVED LATER AND HAS IDENTICAL RSMC, DATE/TIME', - 4 ' AND STORM ID'/2(1X,'@@@',A,'@@@'/),2(4X,A/)) - ENDIF - - ENDDO - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FIXNAM NAME RECOVERY FOR SYNDAT_QCTROPCY -C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01 -C -C ABSTRACT: ERRONEOUS STORM NAMES ARE CHECKED FOR OLD (RETIRED) STORM -C NAMES (ATLANTIC BASIN ONLY). IF A RETIRED NAME MATCHES THE -C INPUT STORM NAME, ERROR RECOVERY IS SUCCESSFUL. SEE REMARKS BELOW. -C -C PROGRAM HISTORY LOG: -C 1990-11-01 S. LORD -C 1993-08-25 S. LORD ADDED CATALOG CHECKING FOR STORM IDS -C -C USAGE: CALL FIXNAM(IUNTCA,NIDBSN,IYRN,IETYP,STMNAM,DUMREC) -C INPUT ARGUMENT LIST: -C IUNTCA - STORM CATALOG UNIT NUMBER -C NIDBSN - BASIN INDEX -C IYRN - 4 DIGIT YEAR OF STORM (YYYY) -C IETYP - INPUT ERROR CODE (SHOULD BE POSITIVE) -C STMNAM - CHARACTER VARIABLE CONTAINING ERRONEOUS STORM NAME -C -C OUTPUT ARGUMENT LIST: -C IETYP - SIGN OF INPUT IETYP IS CHANGED TO NEGATIVE IF -C - RECOVERY IS SUCCESSFUL -C DUMREC - CHARACTER VARIABLE CONTAINING ENTIRE INPUT DATA RECORD -C - WITH CORRECTED NAME. -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE FIXNAM(IUNTCA,NIDBSN,IYRN,IETYP,STMNAM,DUMREC) - - PARAMETER (NRETIR= 7) - - SAVE - - CHARACTER*(*) STMNAM,DUMREC - - PARAMETER (MAXCHR=95) - PARAMETER (MAXVIT=15) - PARAMETER (NBASIN=11) - - CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1, - 1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,RELOCZ*1,NABASN*16 - - DIMENSION IVTVAR(MAXVIT),ISTVAR(MAXVIT),IENVAR(MAXVIT) - - DIMENSION NABASN(NBASIN),BUFIN(MAXCHR),FMTVIT(MAXVIT) - - EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ), - 1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ), - 2 (BUFIN(37),LATNS),(BUFIN(43),LONEW), - 3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ) - - EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ) - - CHARACTER RETNAM(NRETIR,NBASIN)*9 - DIMENSION IRETYR(NRETIR,NBASIN),NUMRET(NBASIN) - - DIMENSION RINC(5) - - DATA FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)', - 1 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/, - 2 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/, - 3 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/ - - DATA NABASN/'ATLANTIC ','EAST PACIFIC ', - 1 'CENTRAL PACIFIC ','WEST PACIFIC ', - 2 'SOUTH CHINA SEA ','EAST CHINA SEA ', - 3 'AUSTRALIA ','SOUTH PACIFIC ', - 4 'SOUTH INDIAN OCN','BAY OF BENGAL ', - 5 'NRTH ARABIAN SEA'/ - - DATA RETNAM/'GILBERT ','JOAN ','HUGO ','GLORIA ', - 1 'DIANA ','BOB ','ANDREW ',70*' '/ - - DATA IRETYR/1988,1988,1989,1985,1990,1991,1992, - 1 70*00/ - - DATA NUMRET/7,1,9*0/,DYSPMX/2.0/ - - RETNAM(1,2)='INIKI' - IRETYR(1,2)=1992 - - BUFINZ=DUMREC - DO INUM=1,NUMRET(NIDBSN) - IF(STMNAM .EQ. RETNAM(INUM,NIDBSN) .AND. - 1 IYRN .EQ. IRETYR(INUM,NIDBSN)) THEN - WRITE(6,3) NABASN(NIDBSN),STMNAM,IYRN - 3 FORMAT(/'...SUCESSFUL RECOVERY OF STORM NAME FROM RETIRED STORM ', - 1 'NAMES OF THE ',A,'. NAME, YEAR=',A,1X,I5) - STMNMZ=STMNAM - DUMREC=BUFINZ - IETYP=-IETYP - RETURN - ENDIF - ENDDO - -C LOOK FOR NAME IN STORM CATALOG. IF THERE, CHECK THAT IT IS A -C RECENT STORM. IF SO, ASSUME THAT THE STORM ID IS OK. - - CALL STCATN(IUNTCA,STMNAM,IDATCA,IUTCCA,IFND) - IF(IFND .EQ. 0) THEN - WRITE(6,101) STMNAM - 101 FORMAT(/'...UNSUCESSFUL ATTEMPT TO RECOVER STORM NAME ...',A, - 1 '... HAS OCCURRED.') - ELSE - -C NOW CHECK DATE VERSUS SUBJECT RECORD - - do iv=1,2 - call decvar(istvar(iv),ienvar(iv),ivtvar(iv),ierdec,fmtvit(iv), - 1 bufinz) - enddo - CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYZ) - - CALL ZTIME(IDATCA,IUTCCA,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYCA) - WRITE(6,133) IDATEZ,IUTCZ,IDATCA,IUTCCA,DAYZ,DAYCA - 133 FORMAT('...COMPARING DATES BETWEEN RECORD AND CATALOG. IDATEZ, ', - 1 'IUTCZ=',I9,I5,' IDATCA,IUTCCA=',I9,I5/4X,'DAYZ,DAYCA=', - 2 2F12.3) - IF(ABS(DAYZ-DAYCA) .GT. DYSPMX) RETURN - IETYP=-IETYP - WRITE(6,201) STMNAM - 201 FORMAT(/'...SUCESSFUL ATTEMPT TO RECOVER STORM NAME ...',A, - 1 '... HAS OCCURRED.') - ENDIF - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: SECVCK SECONDARY VARIABLE Q/C CHECKING -C PRGMMR: S. LORD ORG: NP22 DATE: 1990-11-01 -C -C ABSTRACT: SECONDARY VARIABLES ARE: STORM DIRECTION AND SPEED, -C PCEN (CENTRAL PRESSURE), RMAX (RADIUS OF THE OUTERMOST CLOSED -C ISOBAR), PENV (PRESSURE AT RMAX), AND VMAX (MAXIMUM WIND SPEED). -C THIS ROUTINE CHECKS FOR MISSING AND OUT OF BOUNDS VALUES. -C FOR RMAX, PENV, AND VMAX, VALUES ARE SUBSTITUTED FROM THE LATEST -C HISTORICAL Q/C CHECKED RECORD IF THAT RECORD IS NO MORE THAN 12 -C HOURS OLD. -C -C PROGRAM HISTORY LOG: -C 1990-11-01 S. LORD -C 1991-11-17 S. LORD REVISED FOR MULTIPLE ERRORS -C 1992-08-20 S. LORD ADDED THE JTWC MEMORIAL SWITCH CHECK -C 1992-09-04 S. LORD ADDED PRESSURE WIND RELATIONSHIP -C -C USAGE: CALL SECVCK(IUNTOK,NTEST,NOKAY,NBAD,NUMTST,NUMOKA,NUMBAD, -C DAY0,DAYMIN,DAYMX1,DAYOFF,IFSECV,ZZZREC,NNNREC, -C SCRREC,TSTREC,BADREC,OKAREC) -C INPUT ARGUMENT LIST: -C IUNTOK - UNIT NUMBER FOR PRELIMINARY QUALITY CONTROLLED FILE. -C NTEST - NUMBER OF RECORDS TO BE TESTED. -C NUMTST - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH RECORD -C - TO BE TESTED. -C DAY0 - DATE AT WHICH THIS Q/C CHECK IS BEING MADE. -C - UNITS ARE DDD.FFF, WHERE DDD=JULIAN DAY, FFF=FRAC- -C - TIONAL DAY (E.G. .5=1200 UTC). -C DAYMIN - EARLIEST (MINIMUM) DATE FOR CONSTRUCTION OF A -C - HISTORICAL TRACK FOR EACH STORM. -C - UNITS SAME AS DAY0 ABOVE. -C DAYMX1 - LATEST (MAXIMUM) DATE FOR CONSTRUCTION OF HISTORICAL -C - TRACK FOR EACH STORM. UNITS ARE SAME AS DAY0 ABOVE. -C DAYOFF - OFFSET ADDED TO DAYMX1 IF DAYMIN REFERS TO THE YEAR -C - BEFORE DAYMX1. -C ZZZREC - CHARACTER VARIABLE CONTAINING VARIABLE NAMES. -C NNNREC - CHARACTER VARIABLE CONTAINING COLUMN NUMBERS. -C TSTREC - CHARACTER ARRAY CONTAINING RECORDS TO BE TESTED. -C -C OUTPUT ARGUMENT LIST: -C NOKAY - NUMBER OF RECORDS THAT PASSED THE SEC. VAR. CHECK. -C NBAD - NUMBER OF RECORDS THAT FAILED THE SEC. VAR. CHECK. -C IFSECV - INTEGER ARRAY CONTAINING ERROR CODE FOR EACH INPUT -C - RECORD. SEE COMMENTS IN PGM FOR KEY TO ERROR CODES. -C SCRREC - SCRATCH CHARACTER*9 ARRAY -C NUMOKA - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH GOOD -C - RECORD. -C NUMBAD - INTEGER ARRAY CONTAINING INDEX NUMBER OF EACH BAD -C - RECORD. -C BADREC - CHARACTER ARRAY CONTAINING BAD RECORDS THAT FAILED -C - THE SEC. VAR. CHECK. -C OKAREC - CHARACTER ARRAY CONTAINING ALL RECORDS THAT PASSED -C - THE SEC. VAR. CHECK. -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: WARNING: RECORDS WITH CORRECT FORMAT BUT MISSING OR -C ERRONEOUS DATA MAY BE MODIFIED BY THIS ROUTINE!! -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE SECVCK(IUNTOK,NTEST,NOKAY,NBAD,NUMTST,NUMOKA,NUMBAD, - 1 DAY0,DAYMIN,DAYMX1,DAYOFF,IFSECV,ZZZREC,NNNREC, - 2 SCRREC,TSTREC,BADREC,OKAREC) - - PARAMETER (NPRVMX=61) - PARAMETER (MAXSTM=70) - PARAMETER (NERCSV=9) - PARAMETER (MAXREC=1000) - - SAVE - - CHARACTER*(*) ZZZREC,NNNREC,SCRREC(0:NTEST),TSTREC(0:NTEST), - 1 BADREC(MAXREC),OKAREC(NTEST),ERCSV(NERCSV)*60, - 2 STDPTP(-NPRVMX:-1)*1,SUBTOP*1,SUBFLG*1 - - LOGICAL NEWSTM - - DIMENSION NUMOKA(NTEST),IFSECV(MAXREC),NUMBAD(MAXREC), - 1 NUMTST(NTEST) - - DIMENSION NUMSTM(MAXSTM),INDXST(MAXSTM,MAXSTM),IOPSTM(MAXSTM), - 1 SRTDAY(MAXSTM,MAXSTM),IDASRT(MAXSTM) - - DIMENSION STLATP(-NPRVMX:-1),STLONP(-NPRVMX:-1), - 1 STDAYP(-NPRVMX: 0),STVMXP(-NPRVMX:-1), - 2 STDIRP(-NPRVMX:-1),STSPDP(-NPRVMX:-1), - 3 STPCNP(-NPRVMX:-1),STPENP(-NPRVMX:-1), - 4 STRMXP(-NPRVMX:-1) - - PARAMETER (MAXCHR=95) - PARAMETER (MAXVIT=15) - PARAMETER (MAXTPC= 3) - PARAMETER (NBASIN=11) - PARAMETER (ISECVR= 5,ITERVR=10) - PARAMETER (NSECVR=ITERVR-ISECVR) - PARAMETER (NTERVR=MAXVIT-ITERVR+1) - - CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1, - 1 SHALO*1,MEDIUM*1,DEEP*1,LATNS*1,LONEW*1,FMTVIT*6, - 2 BUFINZ*100,STMREQ*9,RELOCZ*1,STMTPC*1,EXE*1,NAMVAR*5, - 3 IDBASN*1,NABASN*16 - - DIMENSION IVTVAR(MAXVIT),VITVAR(MAXVIT),VITFAC(MAXVIT), - 1 ISTVAR(MAXVIT),IENVAR(MAXVIT) - - DIMENSION NAMVAR(MAXVIT+1),IDBASN(NBASIN),NABASN(NBASIN), - 1 BUFIN(MAXCHR),STMTPC(0:MAXTPC),FMTVIT(MAXVIT) - - EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ), - 1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ), - 2 (BUFIN(37),LATNS),(BUFIN(43),LONEW), - 3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ) - - EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ) - - EQUIVALENCE (VITVAR( 3),STMLTZ),(VITVAR( 4),STMLNZ), - 1 (VITVAR( 5),STMDRZ),(VITVAR( 6),STMSPZ), - 2 (VITVAR( 7),PCENZ) - - EQUIVALENCE (STMTPC(0), EXE),(STMTPC(1),SHALO),(STMTPC(2),MEDIUM), - 1 (STMTPC(3),DEEP) - -C **** NOTE: SECBND AND PRVSVR ARE DIMENSIONED NSECVR+1 TO CARRY -C SPACE FOR VMAX, WHICH IS NOT STRICTLY A SECONDARY VARIABLE. -C THEREFORE, WE DO NOT ALLOW MISSING OR ERRONEOUS VALUES -C OF VMAX TO CAUSE RECORDS TO BE REJECTED. - -C ****NOTE: DEPTH OF CYCLONIC CIRCULATION IS CLASSIFIED AS A -C SECONDARY VARIABLE - - DIMENSION RINC(5) - - DIMENSION SECBND(NSECVR+1,2),PRVSVR(NSECVR+1,-NPRVMX:-1), - 1 TERBND(NTERVR,2),IERROR(NSECVR+2) - - EQUIVALENCE (DIRMN ,SECBND(1,1)),(DIRMX ,SECBND(1,2)), - 1 (SPDMN ,SECBND(2,1)),(SPDMX ,SECBND(2,2)), - 2 (PCENMN,SECBND(3,1)),(PCENMX,SECBND(3,2)), - 3 (PENVMN,SECBND(4,1)),(PENVMX,SECBND(4,2)), - 4 (RMAXMN,SECBND(5,1)),(RMAXMX,SECBND(5,2)), - 5 (VMAXMN,TERBND(1,1)),(VMAXMX,TERBND(1,2)) - - DATA SHALO/'S'/,MEDIUM/'M'/,DEEP/'D'/,EXE/'X'/, - 1 VITFAC/2*1.0,2*0.1,1.0,0.1,9*1.0/, - 2 FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)', - 3 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/, - 4 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/, - 5 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/ - - DATA IDBASN/'L','E','C','W','O','T','U','P','S','B','A'/ - - DATA NABASN/'ATLANTIC ','EAST PACIFIC ', - 1 'CENTRAL PACIFIC ','WEST PACIFIC ', - 2 'SOUTH CHINA SEA ','EAST CHINA SEA ', - 3 'AUSTRALIA ','SOUTH PACIFIC ', - 4 'SOUTH INDIAN OCN','BAY OF BENGAL ', - 5 'NRTH ARABIAN SEA'/ - - DATA NAMVAR/'DATE ','TIME ','LAT. ','LONG.','DIR ','SPEED', - 1 'PCEN ','PENV ','RMAX ','VMAX ','RMW ','R15NE', - 2 'R15SE','R15SW','R15NW','DEPTH'/ - -C RMISPR: MISSING CODE FOR RMAX, PCEN AND PENV -C RMISV: MISSING CODE FOR MAX. TANGENTIAL WIND (VMAX) -C EPSMIS: TOLERANCE FOR MISSING VMAX -C FIVMIN: FIVE MINUTES IN UNITS OF FRACTIONAL DAYS -C DTPERS: MAXIMUM TIME SEPARATION FOR SUBSTITUTION OF MISSING -C SECONDARY INFORMATION USING PERSISTENCE (12 HOURS) -C BOUNDS FOR SECONDARY VARIABLES: -C DIRMN =0.0 DEG DIRMX =360 DEG -C SPDMN =0.0 M/S SPDMX =30 M/S -C PCENMN=880 MB PCENMX=1020 MB -C PENVMN=970 MB PENVMX=1050 MB -C RMAXMN=100 KM RMAXMX=999 KM -C VMAXMN=7.7 M/S VMAXMX=100 M/S - - DATA RMISV/-9.0/,RMISPR/-999.0/,EPSMIS/1.E-1/,NUM/1/, - 1 FIVMIN/3.4722E-3/,DTPERS/0.5/ - - DATA DIRMN/0.0/,DIRMX/360./,SPDMN/0.0/,SPDMX/30./, - 1 PCENMN/880./,PCENMX/1020./,PENVMN/970./,PENVMX/1050./, - 2 RMAXMN/100./,RMAXMX/999.0/,VMAXMN/7.7 /,VMAXMX/100./ - - DATA ERCSV - 1 /'1: UNPHYSICAL OR MISSING DIRECTION (OUTSIDE BOUNDS) ', - 2 '2: UNPHYSICAL OR MISSING SPEED (OUTSIDE BOUNDS) ', - 3 '3: UNPHYSICAL OR MISSING CENTRAL PRESSURE (OUTSIDE BOUNDS) ', - 4 '4: UNPHYSICAL OR MISSING ENV. PRESSURE (OUTSIDE BOUNDS) ', - 5 '5: UNPHYSICAL OR MISSING RMAX (OUTSIDE BOUNDS) ', - 6 '6: UNPHYSICAL OR MISSING VMAX (OUTSIDE BOUNDS) ', - 7 '7: MISSING OR UNINTERPRETABLE DEPTH OF CYCLONE CIRCULATION ', - 8 '8: COMBINATION OF TWO OF THE ERROR TYPES 1-6 ', - 9 '9: COMBINATION OF THREE OR MORE OF THE ERROR TYPES 1-6 '/ - -C ERROR CODES FOR DIRECTION/SPEED GROUP CHECK ARE AS FOLLOWS: -C NEGATIVE NUMBERS INDICATE THAT AN ERRONEOUS OR MISSING VALUE -C WAS SUBSTITUTED USING PERSISTENCE OVER THE TIME DTPERS (12 H) -C MULTIPLE ERRORS ARE HANDLED AS FOLLOWS: -C THE FIRST ERROR OCCUPIES THE LEFT-MOST DIGIT -C THE SECOND ERROR OCCUPIES THE RIGHT-MOST DIGIT -C THREE OR MORE ERRORS REVERTS TO ERROR CODE=9 - -C 1: UNPHYSICAL DIRECTION (OUTSIDE BOUNDS) -C 2: UNPHYSICAL SPEED (OUTSIDE BOUNDS) -C 3: UNPHYSICAL CENTRAL PRESSURE (OUTSIDE BOUNDS) -C 4: UNPHYSICAL ENVIRONMENTAL PRESSURE (OUTSIDE BOUNDS) -C 5: UNPHYSICAL RMAX (OUTSIDE BOUNDS) -C 6: UNPHYSICAL VMAX (OUTSIDE BOUNDS) -C 7: MISSING OR UNINTERPRETABLE DEPTH OF CYCLONE CIRCULATION -C 8: COMBINATION OF TWO OF THE ERROR TYPES 1-6 -C 9: COMBINATION OF THREE OR MORE OF THE ERROR TYPES 1-6 - - NADD=0 - WRITE(6,1) NTEST,NOKAY,NBAD,DAY0,DAYMIN,DAYMX1, - 1 DAYOFF - 1 FORMAT(//'...ENTERING SECVCK TO CHECK SECONDARY VARIABLE ERRORS.', - 1 ' NTEST,NOKAY,NBAD=',3I4/4X,'TIME PARAMETERS ARE: DAY0,', - 2 'DAYMIN,DAYMX1,DAYOFF=',4F11.3///) - - CALL WRNING('SECVCK') - -C INITIALIZE SOME VARIABLES - - NUNI=0 - NSTART=0 - SCRREC(0)='ZZZZZ' - STDAYP(0)=-999.0 - SECBND(6,1:2)=TERBND(1,1:2) - - NUMSTM(1:MAXSTM)=0 - INDXST(1:MAXSTM,1:MAXSTM)=0 - -C FOR THE READABLE RECORDS, FIND THE UNIQUE STORMS AND SAVE THE -C INDEX FOR EACH STORM - - WRITE(6,31) - 31 FORMAT(/'...RECORDS THAT WILL BE CHECKED ARE:'/) - DO NREC=1,NTEST - - BUFINZ=TSTREC(NREC) - WRITE(6,33) NREC,NUMTST(NREC),BUFINZ - 33 FORMAT('...',I4,'...',I4,'...',A) - -C DECODE DATE FOR SORTING PURPOSES - - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 BUFINZ) - ENDDO - CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYZ) - -C CATEGORIZE ALL STORMS BY THEIR STORM ID - - IOPT=5 - STMREQ=STMIDZ - -C ENDIF - - NEWSTM=.TRUE. - DO NR=NSTART,NUNI - IF(STMREQ .EQ. SCRREC(NR)) THEN - NEWSTM=.FALSE. - INDX=NR - GO TO 85 - ENDIF - ENDDO - - 85 NSTART=1 - IF(NEWSTM) THEN - NUNI=NUNI+1 - SCRREC(NUNI)=STMREQ - IOPSTM(NUNI)=IOPT - INDX=NUNI - ENDIF - - NUMSTM(INDX)=NUMSTM(INDX)+1 - INDXST(NUMSTM(INDX),INDX)=NREC - SRTDAY(NUMSTM(INDX),INDX)=DAYZ - - ENDDO - - WRITE(6,101) NUNI - 101 FORMAT(/'...NUMBER OF UNIQUE STORMS=',I4) - -C CHECK SECONDARY VARIABLES DIRECTION,SPEED, PCEN, PENV, RMAX -C VMAX AND STORM DEPTH FOR MISSING AND OUT OF BOUNDS VALUES - - DO NUNIQ=1,NUNI - - BUFINZ=TSTREC(INDXST(1,NUNIQ)) - CALL DECVAR(ISTVAR(1),IENVAR(1),IVTVAR(1),IERDEC,FMTVIT(1), - 1 BUFINZ) - - print *, ' ' - print *, ' ' - IDTTRK=-IDATEZ - CALL SETTRK(IUNTOK,IOPSTM(NUNIQ),IDTTRK,DAY0,DAYMIN, - 1 DAYMX1,DAYOFF,STMDRZ,STMSPZ,STMLTZ,STMLNZ, - 2 SCRREC(NUNIQ),IERSET) - CALL PRVSTM(STLATP,STLONP,STDIRP,STSPDP,STDAYP, - 1 STRMXP,STPCNP,STPENP,STVMXP,STDPTP,KSTPRV) - PRVSVR(1,-1:-KSTPRV:-1)=STDIRP(-1:-KSTPRV:-1) - PRVSVR(2,-1:-KSTPRV:-1)=STSPDP(-1:-KSTPRV:-1) - PRVSVR(3,-1:-KSTPRV:-1)=STPCNP(-1:-KSTPRV:-1) - PRVSVR(4,-1:-KSTPRV:-1)=STPENP(-1:-KSTPRV:-1) - PRVSVR(5,-1:-KSTPRV:-1)=STRMXP(-1:-KSTPRV:-1) - PRVSVR(6,-1:-KSTPRV:-1)=STVMXP(-1:-KSTPRV:-1) - -C SORT ALL RECORDS BY TIME FOR EACH STORM SO THAT WE CAN TAKE -C THEM IN CHRONOLOGICAL ORDER - - CALL SORTRL(SRTDAY(1:NUMSTM(NUNIQ),NUNIQ),IDASRT(1:NUMSTM(NUNIQ)), - 1 NUMSTM(NUNIQ)) - - WRITE(6,107) KSTPRV,SCRREC(NUNIQ) - 107 FORMAT(/'...READY FOR ERROR CHECK WITH KSTPRV, STMID=',I3,1X,A) - - DO NUMST=1,NUMSTM(NUNIQ) - -C INITIALIZE ERROR COUNTERS - - NTOTER=0 - NPOSER=0 - IERROR(1:NSECVR+2)=0 - - NREC=INDXST(IDASRT(NUMST),NUNIQ) - BUFINZ=TSTREC(NREC) - -C GET DATE/TIME, STORM LAT/LON, AND THE SECONDARY -C VARIABLES DIRECTION/SPEED, PCEN, PENV, RMAX -C ****NOTE: ALTHOUGH NOT STRICTLY A SECONDARY VARIABLE, VMAX -C IS CHECKED HERE SINCE IT IS NEEDED FOR CLIPER. - - DO IV=1,ITERVR - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 BUFINZ) - VITVAR(IV)=REAL(IVTVAR(IV))*VITFAC(IV) - ENDDO - - CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYZ) - JDY=IFIX(DAYZ) - - INDX00=99 - DO NP=-1,-KSTPRV,-1 - IF(ABS(STDAYP(NP)-DAYZ) .LE. FIVMIN) INDX00=NP - ENDDO - IF(ABS(DAYZ-DAY0) .LT. FIVMIN) INDX00=0 - - IF(INDX00 .EQ. 99) THEN - WRITE(6,133) INDX00 - 133 FORMAT(/'******AN INDEXING ERROR HAS OCCURRED IN SECVCK, INDX00=', - 1 I4) - CALL ABORT1('SECVCK ',133) - ENDIF - -C ERROR RECOVERY FROM PERSISTENCE IS ALWAYS POSSIBLE. RECOVERY -C FROM CLIMATOLOGY IS POSSIBLE FOR ENVIRONMENTAL PRESSURE AND -C STORM SIZE. - -C THE JMA MEMORIAL DIRECTION/SPEED CHECK IS NOW IMPLEMENTED: -C IF BOTH DIRECTION AND SPEED ARE ZERO, AND THE RSMC IS JMA, -C WE TRY TO RECOVER A BETTER DIRECTION/SPEED. - - DO IV=ISECVR,ITERVR - - RMISVR=RMISPR - SUBVAR=-99.0 - IF(IV .EQ. ITERVR) RMISVR=RMISV - IF(ABS(VITVAR(IV)-RMISVR) .LE. EPSMIS .OR. - 1 VITVAR(IV) .LT. SECBND(IV-ISECVR+1,1) .OR. - 2 VITVAR(IV) .GT. SECBND(IV-ISECVR+1,2) .OR. - 3 (IV-ISECVR+1 .LE. 2 .AND. VITVAR(5) .EQ. 0.0 .AND. - 4 VITVAR(6) .EQ. 0.0 .AND. (RSMCZ .EQ. 'JMA' .OR. - 5 RSMCZ .EQ. '!WJ' .OR. RSMCZ .EQ. '!JW'))) THEN - - NTOTER=NTOTER+1 - IF(IV-ISECVR+1 .EQ. 3) THEN - NPOSER=NPOSER+1 - IERROR(NTOTER)=IABS(IV-ISECVR+1) - ELSE - IERROR(NTOTER)=-IABS(IV-ISECVR+1) - ENDIF - - WRITE(6,141) NUNIQ,NUMST,INDX00,DAYZ,NTOTER,IERROR(NTOTER), - 1 NAMVAR(IV),VITVAR(IV),RMISVR,SECBND(IV-ISECVR+1,1), - 2 SECBND(IV-ISECVR+1,2),NNNREC,ZZZREC,TSTREC(NREC) - 141 FORMAT(//'...ERROR CHECKING NUNIQ,NUMST,INDX00,DAYZ,NTOTER,', - 1 'IERROR=',3I4,F11.3,2I4/4X,'HAS FOUND SECONDARY ', - 2 'VARIABLE ',A,' WITH VALUE=',F7.1,' MISSING OR ', - 3 'EXCEEDING BOUNDS. RMISVR,MINVAL,MAXVAL=',3F7.1/2(1X, - 4 '@@@',A,'@@@'/),4X,A) - -C NEGATE THE ERROR FLAG SO THAT IT SERVES ONLY AS A REMINDER THAT -C AN ERROR IS PRESENT - - IF(IV-ISECVR+1 .LE. 2 .AND. - 1 ((VITVAR(5) .NE. 0.0 .OR. - 2 VITVAR(6) .NE. 0.0) .OR. (RSMCZ .NE. 'JMA' .AND. - 3 RSMCZ .NE. '!WJ' .AND. RSMCZ .NE. '!JW'))) THEN - - WRITE(6,151) NAMVAR(IV),IERROR(NTOTER) - 151 FORMAT('...ERROR RECOVERY FOR ',A,' WILL BE DELAYED UNTIL DRSPCK', - 1 ' (NO LONGER CALLED).'/4X,'THE ERROR TYPE ',I3,' IS MADE ', - 2 'NEGATIVE AS A REMINDER THAT AN ERROR HAS OCCURRED.') - - ELSE - -C FOR ALL OTHER VARIABLES, IS THERE A PREVIOUS HISTORY? - - IF(KSTPRV .GT. 0) THEN - INDPER=0 - DO NP=INDX00-1,-KSTPRV,-1 - IF(ABS(PRVSVR(IV-ISECVR+1,NP)-RMISVR) .GT. EPSMIS .AND. - 1 PRVSVR(IV-ISECVR+1,NP) .GE. SECBND(IV-ISECVR+1,1) .AND. - 2 PRVSVR(IV-ISECVR+1,NP) .LE. SECBND(IV-ISECVR+1,2)) THEN - -c Because of the JMA memorial problem, we are not allowed to use -c a motionless storm as a persistence value - - if(iv-isecvr+1 .le. 2 .and. prvsvr(1,np) .eq. 0 .and. - 1 prvsvr(2,np) .eq. 0) then - ipers=0 - - else - INDPER=NP - IPERS=1 -C WRITE(6,161) INDPER,DAYZ,STDAYP(INDPER), -C 1 PRVSVR(IV-ISECVR+1,INDPER) -C 161 FORMAT(/'...INDPER,DAYZ,STDAYP(INDPER),PRVSVR(IV-ISECVR+1, -C 1 'INDPER)=',I3,3F10.3) - GO TO 221 - ENDIF - ENDIF - ENDDO - 221 CONTINUE - -C IS PERSISTENCE SUBSTITUTION POSSIBLE? - - IF(DAYZ-STDAYP(INDPER) .LE. DTPERS .AND. IPERS .EQ. 1) THEN - SUBVAR=PRVSVR(IV-ISECVR+1,INDPER) - SUBFLG='P' - IF(NPOSER .GT. 0) NPOSER=NPOSER-1 - IERROR(NTOTER)=-IABS(IERROR(NTOTER)) - WRITE(6,223) SUBVAR - 223 FORMAT('...THE MISSING OR ERRONEOUS VALUE WILL BE REPLACED BY ', - 1 'A PERSISTENCE VALUE OF ',F7.1) - -C PERSISTENCE SUBSTITUTION NOT POSSIBLE - - ELSE - IF(IV-ISECVR+1 .LE. 3) THEN - SUBVAR=0.0 - WRITE(6,224) NAMVAR(IV),DAYZ,STDAYP(INDPER),DTPERS - 224 FORMAT(/'...TIME INTERVAL TO THE CLOSEST PREVIOUS RECORD WITH ', - 1 'A NON-MISSING ',A,' EXCEEDS DTPERS OR A '/4X,'NON-', - 2 'MISSING VALUE CANNOT BE FOUND. DAYZ,PREVIOUS DAY,', - 3 'DTPERS=',3F10.3,'.'/4X,'NO RECOVERY POSSIBLE FOR THIS', - 4 ' VARIABLE.') - - ELSE - WRITE(6,225) NAMVAR(IV),DAYZ,STDAYP(INDPER),DTPERS - 225 FORMAT(/'...TIME INTERVAL TO THE CLOSEST PREVIOUS RECORD WITH ', - 1 'A NON-MISSING ',A,' EXCEEDS DTPERS OR A '/4X,'NON-', - 2 'MISSING VALUE CANNOT BE FOUND. DAYZ,PREVIOUS DAY,', - 3 'DTPERS=',3F10.3/4X,'WE WILL SUBSTITUTE A ', - 4 'CLIMATOLOGICAL VALUE.') - ENDIF - ENDIF - -C NO PRIOR HISTORY - - ELSE - IF(IV-ISECVR+1 .LE. 3) THEN - SUBVAR=0.0 - WRITE(6,226) KSTPRV - 226 FORMAT(/'...KSTPRV=',I2,' SO THERE IS NO PRIOR HISTORY AND NO ', - 1 'CHECKING. NO RECOVERY POSSIBLE FOR THIS VARIABLE.') - - ELSE - WRITE(6,227) KSTPRV - 227 FORMAT(/'...KSTPRV=',I2,' SO THERE IS NO PRIOR HISTORY AND NO ', - 1 'CHECKING. CLIMATOLOGICAL VALUES WILL BE SUBSTITUTED.') - ENDIF - ENDIF - -C CLIMATOLOGICAL VARIABLE SUBSTITUTION - - IF(SUBVAR .EQ. -99.0) THEN - DO NBA=1,NBASIN - IF(STMIDZ(3:3) .EQ. IDBASN(NBA)) THEN - IBASN=NBA - GO TO 2228 - ENDIF - ENDDO - 2228 CONTINUE - -C SUBSTITUTE A PRESSURE-WIND RELATIONSHIP FOR MAX WIND - - IF(IV .EQ. ITERVR) THEN - SUBVAR=TCPWTB(VITVAR(7),IBASN) - ELSE - SUBVAR=TCCLIM(IV,IBASN) - ENDIF - SUBFLG='C' - WRITE(6,229) NAMVAR(IV),SUBVAR,NABASN(IBASN) - 229 FORMAT(/'...FOR VARIABLE ',A,', THE CLIMATOLOGICAL VALUE IS',F7.1, - 1 ' IN THE ',A,' BASIN.') - ENDIF - - IF(SUBVAR .NE. 0.0) THEN - WRITE(TSTREC(NREC)(ISTVAR(IV):IENVAR(IV)),FMTVIT(IV)) - 1 NINT(SUBVAR/VITFAC(IV)) - TSTREC(NREC)(ISTVAR(IV)-1:ISTVAR(IV)-1)=SUBFLG - WRITE(6,2219) TSTREC(NREC) - 2219 FORMAT('...AFTER SUBSTITUTION, THE RECORD IS:'/4X,A) - BUFINZ=TSTREC(NREC) - -c Only update vitvar after direction errors have been corrected -c in the rare case for a JMA report with 0000 direction and -c 0000 speed - - if(iv-isecvr+1 .ge. 2) then - DO IVZ=1,ITERVR - CALL DECVAR(ISTVAR(IVZ),IENVAR(IVZ),IVTVAR(IVZ),IERDEC, - 1 FMTVIT(IVZ),BUFINZ) - VITVAR(IVZ)=REAL(IVTVAR(IVZ))*VITFAC(IVZ) - ENDDO - endif - ENDIF - - ENDIF - ENDIF - -C THE JTWC MEMORIAL PRESSURE SWITCHING CHECK -C IV=7 IS PCEN -C IV=8 IS PENV - - IF(IV-ISECVR+1 .EQ. 3) THEN - IF(VITVAR(IV) .GE. VITVAR(IV+1)) THEN - NTOTER=NTOTER+1 - WRITE(6,2301) VITVAR(IV),VITVAR(IV+1) - 2301 FORMAT(/'...UNPHYSICAL PCEN=',F7.1,' >= PENV=',F7.1) - IF(SUBVAR .GT. 0.0) THEN - NPOSER=NPOSER+1 - IERROR(NTOTER)=IABS(IV-ISECVR+1) - WRITE(6,2303) - 2303 FORMAT('...WE CANNOT RECOVER THIS ERROR SINCE SUBSTITUTION HAS ', - 1 'GIVEN UNPHYSICAL RESULTS.') - ELSE - IF(VITVAR(IV) .NE. RMISVR .AND. VITVAR(IV+1) .NE. RMISVR) THEN - SUBFLG='Z' - SUBVR1=VITVAR(IV) - SUBVR2=VITVAR(IV+1)-1.0 - WRITE(TSTREC(NREC)(ISTVAR(IV):IENVAR(IV)),FMTVIT(IV)) - 1 NINT(SUBVR2/VITFAC(IV)) - WRITE(TSTREC(NREC)(ISTVAR(IV+1):IENVAR(IV+1)),FMTVIT(IV+1)) - 1 NINT(SUBVR1/VITFAC(IV+1)) - TSTREC(NREC)(ISTVAR(IV)-1:ISTVAR(IV)-1)=SUBFLG - TSTREC(NREC)(ISTVAR(IV+1)-1:ISTVAR(IV+1)-1)=SUBFLG - WRITE(6,2219) TSTREC(NREC) - BUFINZ=TSTREC(NREC) - DO IVZ=1,ITERVR - CALL DECVAR(ISTVAR(IVZ),IENVAR(IVZ),IVTVAR(IVZ),IERDEC, - 1 FMTVIT(IVZ),BUFINZ) - VITVAR(IVZ)=REAL(IVTVAR(IVZ))*VITFAC(IVZ) - ENDDO - ENDIF - ENDIF - ENDIF - ENDIF - ENDDO - -C CHECK FOR MISSING DEPTH OF THE CYCLONIC CIRCULATION - - ITPC=0 - DO KTPC=1,MAXTPC - IF(STMDPZ .EQ. STMTPC(KTPC)) THEN - ITPC=KTPC -C WRITE(6,239) NUMST,STMDPZ -C 239 FORMAT('...RECORD ',I3,' HAS A PROPER CODE=',A,' FOR DEPTH OF ', -C 'THE CYCLONIC CIRCULATION.') - ENDIF - ENDDO - - IF(ITPC .EQ. 0) THEN - - SUBTOP=EXE - NTOTER=NTOTER+1 - IERROR(NTOTER)=-7 - - WRITE(6,241) NUNIQ,NUMST,INDX00,DAYZ,NTOTER,IERROR(NTOTER), - 1 STMDPZ,NNNREC,ZZZREC,TSTREC(NREC) - 241 FORMAT(//'...ERROR CHECKING NUNIQ,NUMST,INDX00,DAYZ,NTOTER,', - 1 'IERROR=',3I4,F11.3,2I4/4X,'HAS FOUND MISSING OR BAD ', - 2 'CODE=',A,' FOR DEPTH OF THE CYCLONIC CIRCULATION. ', - 3 'RECORD='/2(1X,'@@@',A,'@@@'/),4X,A) - - IF(KSTPRV .GT. 0) THEN - INDPER=0 - DO NP=INDX00-1,-KSTPRV,-1 - DO ITPC=1,MAXTPC - IF(STDPTP(NP) .EQ. STMTPC(ITPC)) THEN - INDPER=NP - SUBTOP=STDPTP(NP) - SUBFLG='P' - WRITE(6,243) INDPER,DAYZ,STDAYP(INDPER),SUBTOP - 243 FORMAT(/'...INDPER,DAYZ,STDAYP(INDPER),SUBTOP=',I3,2F10.3,1X,A) - GO TO 261 - ENDIF - ENDDO - - ENDDO - - 261 CONTINUE - IF(DAYZ-STDAYP(INDPER) .LE. DTPERS) THEN - WRITE(6,263) NAMVAR(MAXVIT+1),SUBTOP - 263 FORMAT('...THE MISSING OR ERRONEOUS VALUE OF ',A,' WILL BE ', - 1 'REPLACED BY A PERSISTENCE VALUE OF ',A) - - ELSE - - WRITE(6,273) DAYZ,STDAYP(INDPER),DTPERS - 273 FORMAT(/'...TIME INTERVAL TO THE CLOSEST PREVIOUS RECORD WITH ', - 1 'A PROPER STORM DEPTH CODE EXCEEDS DTPERS OR AN '/4X, - 2 'ACCEPTABLE VALUE CANNOT BE FOUND. ', - 3 'DAYZ,PREVIOUS DAY,DTPERS=',3F10.3/,4X,'WE WILL ', - 4 'SUBSTITUTE A CLIMATOLOGICAL VALUE.') - ENDIF - - ELSE - WRITE(6,277) KSTPRV - 277 FORMAT(/'...KSTPRV=',I2,' SO THERE IS NO PRIOR HISTORY AND NO ', - 1 'CHECKING. CLIMATOLOGICAL VALUES WILL BE SUBSTITUTED.') - ENDIF - -C DETERMINE CLIMATOLOGICAL VALUE IF NECESSARY - - IF(SUBTOP .EQ. EXE) THEN - IF(PCENZ .LE. 980.0) THEN - SUBTOP=DEEP - WRITE(6,279) PCENZ,SUBTOP - 279 FORMAT('...CLIMATOLOGICAL SUBSTITUTION OF STORM DEPTH: PCEN, ', - 1 'DEPTH=',F7.1,1X,A) - ELSE IF(PCENZ .LE. 1000.0) THEN - SUBTOP=MEDIUM - WRITE(6,279) PCENZ,SUBTOP - ELSE - SUBTOP=SHALO - WRITE(6,279) PCENZ,SUBTOP - ENDIF - SUBFLG='C' - ENDIF - - WRITE(TSTREC(NREC)(MAXCHR:MAXCHR),'(A)') SUBTOP - TSTREC(NREC)(MAXCHR-1:MAXCHR-1)=SUBFLG - WRITE(6,269) TSTREC(NREC) - 269 FORMAT('...AFTER SUBSTITUTION, THE RECORD IS:'/4X,A) - ENDIF - -C ASSIGN SUMMARY ERROR CODE - -C NO ERRORS - - IF(NTOTER .EQ. 0) THEN - IETYP=0 - ISGNER=1 - -C IF ALL ERRORS HAVE BEEN FIXED, SUMMARY CODE IS NEGATIVE - - ELSE - IF(NPOSER .EQ. 0) THEN - ISGNER=-1 - ELSE - ISGNER=1 - ENDIF - -C ADD CODE FOR DEPTH OF THE CYCLONIC CIRCULATION FIRST - - NERZ=0 - NALLER=NTOTER - IF(IABS(IERROR(NTOTER)) .EQ. 7) THEN - NERZ=1 - IETYP=7 - NALLER=NTOTER-1 - ENDIF - -C ALL OTHER ERRORS. PICK OUT ONLY ALL ERRORS THAT REMAIN OR -C ALL ERRORS THAT HAVE BEEN FIXED IF THERE ARE NO REMAINING -C ERRORS. DO NOTHING WITH OTHER ERRORS. - - DO NER=1,NALLER - IF((ISGNER .LT. 0 .AND. IERROR(NER) .LT. 0) .OR. - 1 (ISGNER .GT. 0 .AND. IERROR(NER) .GT. 0)) THEN - NERZ=NERZ+1 - - ELSE - GO TO 280 - ENDIF - - IF(NERZ .EQ. 1) THEN - IETYP=IABS(IERROR(NER)) - - ELSE IF(NERZ .EQ. 2) THEN - IETYP=IABS(IETYP)*10+IABS(IERROR(NER)) - - ELSE IF(NERZ .EQ. 3) THEN - IF(IABS(IERROR(NTOTER)) .EQ. 7) THEN - IETYP=78 - ELSE - IETYP=9 - ENDIF - - ELSE - IF(IABS(IERROR(NTOTER)) .EQ. 7) THEN - IETYP=79 - ELSE - IETYP=9 - ENDIF - ENDIF - - 280 CONTINUE - ENDDO - ENDIF - IETYP=SIGN(IETYP,ISGNER) - - WRITE(6,281) SCRREC(NUNIQ),NUMST,NUMSTM(NUNIQ),NTOTER,NPOSER, - 1 ISGNER,IETYP,(IERROR(NER),NER=1,NTOTER) - 281 FORMAT(/'...ERROR SUMMARY FOR STMID,NUMST,NUMSTM=',A,2I3,':'/4X, - 1 'NTOTER,NPOSER,ISGNER,IETYP,IERROR=',4I4/(4X,10I4)) - -C WRITE(6,287) NREC,IETYP,NUMTST(NREC),NUMST,NUNIQ,BUFINZ -C 287 FORMAT(/'...DEBUGGING, NREC,IETYP,NUMTST(NREC),NUMST,NUNIQ,', -C 1 'BUFINZ=',5I4/4X,A) - IFSECV(NUMTST(NREC))=IETYP - IF(IETYP .GT. 0) THEN - NADD=NADD+1 - NUMBAD(NADD+NBAD)=NUMTST(NREC) - BADREC(NADD+NBAD)=TSTREC(NREC) - ELSE - NOKAY=NOKAY+1 - NUMOKA(NOKAY)=NUMTST(NREC) - OKAREC(NOKAY)=TSTREC(NREC) - ENDIF - - ENDDO - - ENDDO - - WRITE(6,301) NOKAY,NADD,NTEST,(ERCSV(NER),NER=1,NERCSV) - 301 FORMAT(//'...RESULTS OF THE SECONDARY VARIABLE ERROR CHECK ARE: ', - 1 'NOKAY=',I4,' AND NADD=',I4,' FOR A TOTAL OF ',I4, - 2 ' RECORDS.'//4X,'ERROR CODES ARE:'/(6X,A)) - WRITE(6,303) - 303 FORMAT(/'...NOTES: NEGATIVE ERROR CODES (EXCEPT DIR/SPD) INDICATE' - 1 ,' SUCCESSFUL RECOVERY FROM MISSING OR ERRONEOUS DATA'/11X - 2 ,'BY SUBSTITUTION FROM PERSISTENCE.'/11X,'A NEGATIVE ERR', - 3 'OR CODE FOR DIR/SPD INDICATES THAT ERROR RECOVERY WILL ', - 4 'BE POSTPONED UNTIL THE DIR/SPD CHECK.'/11X,'MULTIPLE ', - 5 'ERRORS ARE HANDLED AS FOLLOWS:'/13X,'THE FIRST SECONDARY' - 6 ,' ERROR OCCUPIES THE LEFT-MOST DIGIT.'/13X,'THE NEXT ', - 7 'SECONDARY ERROR OCCUPIES THE RIGHT-MOST DIGIT.'/13X, - 8 'THREE OR MORE ERRORS REVERTS TO ERROR CODE=7, ETC.'/13X, - 9 'ERRORS FOR THE DEPTH OF THE CYCLONIC CIRCULATION ARE ', - A 'COUNTED SEPARATELY.'//3X,'OKAY RECORDS ARE:',100X,'ERC'/) - - DO NOK=1,NOKAY - WRITE(6,309) NOK,NUMOKA(NOK),OKAREC(NOK),IFSECV(NUMOKA(NOK)) - 309 FORMAT(3X,I4,'...',I4,'...',A,'...',I3) - ENDDO - IF(NADD .GT. 0) WRITE(6,311) (NBAD+NBA,NUMBAD(NBAD+NBA), - 1 BADREC(NBAD+NBA), - 2 IFSECV(NUMBAD(NBAD+NBA)), - 3 NBA=1,NADD) - 311 FORMAT(/' ADDED BAD RECORDS ARE:',95X,'ERC'/(3X,I4,'...',I4, - 1 '...',A,'...',I3)) - NBAD=NBAD+NADD - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: WRNING WRITES WARNING MESSAGE ABOUT RECORD MODS -C PRGMMR: S. LORD ORG: NP22 DATE: 1992-02-21 -C -C ABSTRACT: WRITES SIMPLE WARNING MESSAGE. -C -C PROGRAM HISTORY LOG: -C 1992-02-21 S. LORD -C -C USAGE: CALL WRNING(IDSUB) -C INPUT ARGUMENT LIST: -C IDSUB - SUBROUTINE NAME -C -C REMARKS: SEE REMARKS IN CODE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE WRNING(IDSUB) - - CHARACTER*6 IDSUB - - WRITE(6,1) IDSUB - 1 FORMAT(21X,'***********************************************'/ - 1 21X,'***********************************************'/ - 2 21X,'**** ****'/ - 3 21X,'**** WARNING: RECORDS WITH CORRECT FORMAT ****'/ - 4 21X,'**** BUT MISSING OR ERRONEOUS ****'/ - 5 21X,'**** DATA MAY BE MODIFIED BY ****'/ - 6 21X,'**** THIS ROUTINE=',A6,'!!! ****'/ - 7 21X,'**** ****'/ - 8 21X,'**** TYPES OF SUBSTITUTIONS ARE: ****'/ - 9 21X,'**** CLIMATOLOGICAL SUBSTITUTION: C ****'/ - O 21X,'**** RSMC AVERAGING: A ****'/ - 1 21X,'**** PERSISTENCE SUBSTITUTION: P ****'/ - 2 21X,'**** OVERLAP MODIFICATION: O ****'/ - 3 21X,'**** DIRECTION/SPEED SUBSTITUTION: S ****'/ - 4 21X,'**** LATITUDE/LONGITUDE SUBSTITUTION: L ****'/ - 4 21X,'**** SWITCHED PCEN-PENV SUBSTITUTION: Z ****'/ - 8 21X,'**** ****'/ - 6 21X,'***********************************************'/ - 7 21X,'***********************************************') - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: F1 RECALCULATES LONGITUDES -C PRGMMR: S. LORD ORG: NP22 DATE: 1993-05-01 -C -C ABSTRACT: SEE COMMENTS IN PROGRAM. ORIGINALLY WRITTEN BY C. J. NEWMANN -C -C PROGRAM HISTORY LOG: -C 1993-05-01 S. LORD INSTALLED PROGRAM -C -C USAGE: CALL F1(ALON) -C INPUT ARGUMENT LIST: SEE COMMENTS IN PROGRAM -C -C OUTPUT ARGUMENT LIST: -C SEE COMMENTS IN PROGRAM -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - FUNCTION F1(ALON) - -C CONVERT FROM E LONGITUDE TO THOSE ACCEPTABLE IN AL TAYLOR ROUTINES - - IF(ALON.GT.180.)F1=360.-ALON - IF(ALON.LE.180.)F1=-ALON - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: F2 CALCULATES DATES -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-06-05 -C -C ABSTRACT: SEE COMMENTS IN PROGRAM. ORIGINALLY WRITTEN BY C. J. -C NEWMANN -C -C PROGRAM HISTORY LOG: -C 1993-05-01 S. LORD INSTALLED PROGRAM -C 1998-06-05 D. A. KEYSER - Y2K, FORTRAN 90 COMPLIANT -C -C USAGE: CALL F2(IDATIM) -C INPUT ARGUMENT LIST: -C IDATIM - 10-DIGIT DATE IN FORM YYYYDDMMHH -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - FUNCTION F2(IDATIM) - -C OBTAIN JULIAN DAY NUMBER -C 0000UTC ON 1 JAN IS SET TO DAY NUMBER 0 AND 1800UTC ON 31 DEC IS SET -C TO DAY NUMBER 364.75. LEAP YEARS ARE IGNORED. - - CHARACTER*10 ALFA - WRITE(ALFA,'(I10)')IDATIM - READ(ALFA,'(I4,3I2)')KYR,MO,KDA,KHR - MON=MO - IF(MON.EQ.13)MON=1 - DANBR=3055*(MON+2)/100-(MON+10)/13*2-91+KDA - F2=DANBR-1.+REAL(KHR/6)*0.25 - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: SLDATE RETRIEVES DATE FROM SYSTEM AND DATE FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-06-05 -C -C ABSTRACT: RETRIEVES DATE FROM SYSTEM AND FROM A DATE FILE, AND -C OBTAINS THE DIFFERENCE BETWEEN THE TWO. CONSTRUCTS DATE -C IN FORM YYYYMMDD AND HHMM. -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD -C 1998-06-05 D. A. KEYSER - Y2K/F90 COMPLIANCE -C -C USAGE: CALL SLDATE(IUNTDT,IDATEZ,IUTCZ,IOFFTM) -C INPUT ARGUMENT LIST: -C IUNTDT - UNIT NUMBER FOR FILE CONTAINING RUN DATE -C -C OUTPUT ARGUMENT LIST: -C IDATEZ - DATE IN FORM YYYYMMDD -C IUTCZ - DATE IN FORM HHMM -C IOFFTM - OFFSET (HOURS *100) BETWEEN SYSTEM DATE AND -C - FILE DATE (SYSTEM DATE MINUS FILE DATE) -C -C INPUT FILES: -C UNIT "IUNTDT" - FILE CONTAINING RUN DATE IN I4,3I2 FORMAT -C - ('YYYYMMDDHH') -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE SLDATE(IUNTDT,IDATEZ,IUTCZ,IOFFTM) - - CHARACTER USRDAT*10 - - SAVE - - DIMENSION IDAT(8),JDAT(6),RINC(5) - - EQUIVALENCE (IDAT(1),JW3YR),(IDAT(2),JW3MO),(IDAT(3),JW3DA), - 2 (IDAT(5),JW3HR),(IDAT(6),JW3MIN),(IDAT(7),JW3SEC) - - READ(IUNTDT,1) USRDAT - 1 FORMAT(A10) - WRITE(6,3) USRDAT - 3 FORMAT(/'...',A10,'...') - -C OBTAIN CURRENT SYSTEM DATE - IDAT (UTC) - - CALL W3UTCDAT(IDAT) - -C DECODE THE DATE LABEL INTO JDAT (UTC) - - READ(USRDAT(1: 4),'(I4)') JDAT(1) - READ(USRDAT(5: 6),'(I2)') JDAT(2) - READ(USRDAT(7: 8),'(I2)') JDAT(3) - READ(USRDAT(9:10),'(I2)') JDAT(5) - -C THIS IS THE TIME ZONE OFFSET (SAME AS FOR IDAT) - JDAT(4) = IDAT(4) - - JDAT(6) = 0 - -C COMBINE YEAR, MONTH, DAY, HOUR, MINUTE TO FORM YYYYMMDD - - IDATEZ=JDAT(1)*10000+JDAT(2)*100+JDAT(3) - IUTCZ =JDAT(5)*100+JDAT(6) - -C OBTAIN TIME DIFFERENCE (CURRENT TIME - LABEL TIME) IN HOURS * 100 - - CALL W3DIFDAT(IDAT,(/JDAT(1),JDAT(2),JDAT(3),JDAT(4),JDAT(5), - $ JDAT(6),0,0/),2,RINC) - IOFFTM=NINT(RINC(2)*100.) - - WRITE(6,5) JW3YR,JW3MO,JW3DA,JW3HR,JW3MIN,JW3SEC,IOFFTM - 5 FORMAT(/'...CURRENT DATE/TIME FROM W3UTCDAT CALL IS:'/'JW3YR=',I5, - 1 ' JW3MO=',I3,' JW3DA=',I3,' JW3HR=',I5,' JW3MIN=',I5, - 2 ' JW3SEC=',I5,' OFFTIM=',I8) - - WRITE(6,13) IDATEZ,IUTCZ - 13 FORMAT('...IN SLDATE, IDATEZ,IUTCZ=',I10,2X,I4) - - RETURN - -C----------------------------------------------------------------------- - ENTRY SLDTCK(IUNTDT) - - REWIND IUNTDT - WRITE(6,21) IUNTDT - 21 FORMAT('...WRITING USRDAT TO UNIT',I3) - WRITE(IUNTDT,1) USRDAT - - RETURN - -C----------------------------------------------------------------------- - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FIXSLM MODIFIES SEA-LAND MASK -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06 -C -C ABSTRACT: MODIFIES NCEP T126 GAUSSIAN GRID SEA-LAND MASK. CONVERTS -C SOME SMALL ISLANDS TO OCEAN POINTS. PROGRAM IS DEPENDENT -C ON MODEL RESOLUTION. -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD -C 1992-04-08 S. J. LORD CONVERTED TO T126 FROM T80 -C -C USAGE: CALL FIXSLM(LONF,LATG2,RLON,RLAT,SLMASK) -C INPUT ARGUMENT LIST: -C LONF - NUMBER OF LONGITUDINAL POINTS, FIRST INDEX OF SLMASK -C LATG2 - NUMBER OF LATITUDINAL POINTS, SECOND INDEX OF SLMASK -C RLON - LONGITUDES -C RLAT - LATITUDES -C SLMASK - T162 SEA-LAND MASK ON GAUSSIAN GRID -C -C OUTPUT ARGUMENT LIST: -C SLMASK - MODIFIED T162 SEA-LAND MASK ON GAUSSIAN GRID -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE FIXSLM(LONF,LATG2,RLON,RLAT,SLMASK) - - PARAMETER (MAXSLM=35) - - SAVE - - DIMENSION RLAT(LATG2),RLON(LONF),SLMASK(LONF,LATG2),IPT(MAXSLM), - 1 JPT(MAXSLM) - - DATA NOCEAN/21/, - -C INDONESIAN ARCHIPELAGO,NEW CALEDONIA - - 1 IPT/133,135,129,177, - -C YUCATAN - - 2 290,291,292,289,290,291,289,290,291, - -C CUBA - - 3 299,300,301,302,303,303,304,305,14*0.0/, - -C INDONESIAN ARCHIPELAGO,NEW CALEDONIA - - 1 JPT/106,105,106,118, - -C YUCATAN - - 2 3*73,3*74,3*75, - -C CUBA - - 3 3*72,2*73,3*74,14*0.0/ - -C WRITE(6,7) -C 7 FORMAT('...CONVERTING LAND TO OCEAN, NPT,IPT,RLON,JPT,RLAT=') - DO NPT=1,NOCEAN - SLMASK(IPT(NPT),JPT(NPT))=0.0 -C WRITE(6,9) NPT,IPT(NPT),RLON(IPT(NPT)),JPT(NPT),RLAT(JPT(NPT)) -C 9 FORMAT(4X,2I5,F10.3,I5,F10.3) - ENDDO - - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: GAULAT CALCULATES GAUSSIAN GRID LATITUDES -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06 -C -C ABSTRACT: CALCULATES GAUSSIAN GRID LATITUDES -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD - COPIED FROM KANAMITSU LIBRARY -C -C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... ) -C INPUT ARGUMENT LIST: -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C DDNAME1 - GENERIC NAME & CONTENT -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE -C FT06F001 - INCLUDE IF ANY PRINTOUT -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE GAULAT(GAUL,K) - - IMPLICIT REAL(8) (A-H,O-Z) - DIMENSION A(500) - REAL GAUL(1) - - SAVE - - ESP=1.D-14 - C=(1.D0-(2.D0/3.14159265358979D0)**2)*0.25D0 - FK=K - KK=K/2 - CALL BSSLZ1(A,KK) - DO IS=1,KK - XZ=COS(A(IS)/SQRT((FK+0.5D0)**2+C)) - ITER=0 - 10 PKM2=1.D0 - PKM1=XZ - ITER=ITER+1 - IF(ITER.GT.10) GO TO 70 - DO N=2,K - FN=N - PK=((2.D0*FN-1.D0)*XZ*PKM1-(FN-1.D0)*PKM2)/FN - PKM2=PKM1 - PKM1=PK - ENDDO - PKM1=PKM2 - PKMRK=(FK*(PKM1-XZ*PK))/(1.D0-XZ**2) - SP=PK/PKMRK - XZ=XZ-SP - AVSP=ABS(SP) - IF(AVSP.GT.ESP) GO TO 10 - A(IS)=XZ - ENDDO - IF(K.EQ.KK*2) GO TO 50 - A(KK+1)=0.D0 - PK=2.D0/FK**2 - DO N=2,K,2 - FN=N - PK=PK*FN**2/(FN-1.D0)**2 - ENDDO - 50 CONTINUE - DO N=1,KK - L=K+1-N - A(L)=-A(N) - ENDDO - - RADI=180./(4.*ATAN(1.)) - GAUL(1:K)=ACOS(A(1:K))*RADI -C PRINT *,'GAUSSIAN LAT (DEG) FOR JMAX=',K -C PRINT *,(GAUL(N),N=1,K) - - RETURN - 70 WRITE(6,6000) - 6000 FORMAT(//5X,14HERROR IN GAUAW//) - CALL ABORT1(' GAULAT',6000) - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: BSSLZ1 CALCULATES BESSEL FUNCTIONS -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06 -C -C ABSTRACT: CALCULATES BESSEL FUNCTIONS -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD - COPIED FROM KANAMITSU LIBRARY -C -C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... ) -C INPUT ARGUMENT LIST: -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C DDNAME1 - GENERIC NAME & CONTENT -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE -C FT06F001 - INCLUDE IF ANY PRINTOUT -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE BSSLZ1(BES,N) - - IMPLICIT REAL(8) (A-H,O-Z) - DIMENSION BES(N) - DIMENSION BZ(50) - - DATA PI/3.14159265358979D0/ - DATA BZ / 2.4048255577D0, 5.5200781103D0, - $ 8.6537279129D0,11.7915344391D0,14.9309177086D0,18.0710639679D0, - $ 21.2116366299D0,24.3524715308D0,27.4934791320D0,30.6346064684D0, - $ 33.7758202136D0,36.9170983537D0,40.0584257646D0,43.1997917132D0, - $ 46.3411883717D0,49.4826098974D0,52.6240518411D0,55.7655107550D0, - $ 58.9069839261D0,62.0484691902D0,65.1899648002D0,68.3314693299D0, - $ 71.4729816036D0,74.6145006437D0,77.7560256304D0,80.8975558711D0, - $ 84.0390907769D0,87.1806298436D0,90.3221726372D0,93.4637187819D0, - $ 96.6052679510D0,99.7468198587D0,102.888374254D0,106.029930916D0, - $ 109.171489649D0,112.313050280D0,115.454612653D0,118.596176630D0, - $ 121.737742088D0,124.879308913D0,128.020877005D0,131.162446275D0, - $ 134.304016638D0,137.445588020D0,140.587160352D0,143.728733573D0, - $ 146.870307625D0,150.011882457D0,153.153458019D0,156.295034268D0/ - NN=N - IF(N.LE.50) GO TO 12 - BES(50)=BZ(50) - BES(51:N)=BES(50:N-1)+PI - NN=49 - 12 CONTINUE - BES(1:NN)=BZ(1:NN) - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: TRKSUB DETERMINES OBS. TROP. CYCLONE TRACKS -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06 -C -C ABSTRACT: CONTAINS VARIOUS ENTRY POINTS TO DETERMINE TROPICAL -C CYCLONE TRACKS, CALCULATE STORM RELATIVE COORDINATE, DETERMINES -C FIRST OCCURRENCE OF A PARTICULAR STORM. -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD -C -C USAGE: CALL TRKSUB(IOVITL,IOPTZ,IDATTK,DAY0,DAYMN,DAYMX,DAYOFF, -C 1 STMDR0,STMSP0,STLAT0,STLON0,IERSET, -C 3 STLATP,STLONP,STDIRP,STSPDP,STDAYP, -C 4 STRMXP,STPCNP,STPENP,STVMXP,KSTPZ, -C 5 STDPTP,STMNTK) -C CALL SETTRK(IOVITL,IOPTZ,IDATTK,DAY0,DAYMN,DAYMX,DAYOFF, -C 1 STMDR0,STMSP0,STLAT0,STLON0,STMNTK,IERSET) -C INPUT ARGUMENT LIST: -C DAY0 - FRACTIONAL NUMBER OF DAYS SINCE 12/31/1899 -C DAYMX - FRACTIONAL NUMBER OF DAYS SINCE 12/31/1899 (MAX) -C DAYMN - FRACTIONAL NUMBER OF DAYS SINCE 12/31/1899 (MIN) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C DDNAME1 - GENERIC NAME & CONTENT -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE TRKSUB(IOVITL,IOPTZ,IDATTK,DAY0,DAYMN,DAYMX,DAYOFF, - 1 STMDR0,STMSP0,STLAT0,STLON0,IERSET,STLATP, - 2 STLONP,STDIRP,STSPDP,STDAYP,STRMXP,STPCNP, - 3 STPENP,STVMXP,KSTPZ,STDPTP,STMNTK) - - PARAMETER (MAXSTM=70) - PARAMETER (NSTM=MAXSTM,NSTM1=NSTM+1) - PARAMETER (NPRVMX=61) - - LOGICAL NOMIN,NOMAX,EXTRPB,EXTRPF - CHARACTER STMNTK*(*),STDPTP*1 - - SAVE - - DIMENSION STDPTP(-NPRVMX:-1) - - DIMENSION RINC(5) - - CHARACTER STMNAM*9,STMID*3,RSMC*4 - - LOGICAL FSTFLG - - DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM), - 1 STMDIR(MAXSTM),STMSPD(MAXSTM),IDATE(MAXSTM), - 2 IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM),PCEN(MAXSTM), - 3 PTOP(MAXSTM),RSMC(MAXSTM),RMW(MAXSTM),VMAX(MAXSTM), - 4 R15NW(MAXSTM),R15NE(MAXSTM),R15SE(MAXSTM),R15SW(MAXSTM), - 5 STMID(MAXSTM),FSTFLG(MAXSTM) - - PARAMETER (MAXTPC= 3) - - CHARACTER SHALO*1,MEDIUM*1,DEEP*1,STMTPC*1,EXE*1 - - DIMENSION STMTOP(0:MAXTPC) - - DIMENSION STMTPC(0:MAXTPC) - - EQUIVALENCE (STMTPC(0), EXE),(STMTPC(1),SHALO),(STMTPC(2),MEDIUM), - 1 (STMTPC(3),DEEP) - - DIMENSION TRKLTZ(0:NSTM1),TRKLNZ(0:NSTM1), - 1 TRKDRZ(0:NSTM1),TRKSPZ(0:NSTM1), - 2 TRKRMX(0:NSTM1),TRKPCN(0:NSTM1), - 3 TRKPEN(0:NSTM1),TRKVMX(0:NSTM1), - 4 TRKDPT(0:NSTM1) - - DIMENSION STMDAY(0:NSTM1),SRTDAY(NSTM),IDASRT(0:NSTM1), - 1 SRTLAT(NSTM),SRTLON(NSTM),SRTDIR(NSTM),SRTSPD(NSTM), - 2 ISRTDA(NSTM),ISRTUT(NSTM),SRTRMX(NSTM),SRTPCN(NSTM), - 3 SRTPEN(NSTM),SRTVMX(NSTM),SRTDPT(NSTM) - - DIMENSION STLATP(-NPRVMX:-1),STLONP(-NPRVMX:-1), - 1 STDIRP(-NPRVMX:-1),STSPDP(-NPRVMX:-1), - 1 STDAYP(-NPRVMX: 0),STRMXP(-NPRVMX:-1), - 1 STPCNP(-NPRVMX:-1),STPENP(-NPRVMX:-1), - 2 STVMXP(-NPRVMX:-1) - - EQUIVALENCE (TRKLTZ(1),STMLAT(1)),(TRKLNZ(1),STMLON(1)), - 1 (TRKDRZ(1),STMDIR(1)),(TRKSPZ(1),STMSPD(1)), - 2 (TRKRMX(1),RMAX (1)),(TRKPCN(1),PCEN (1)), - 3 (TRKPEN(1),PENV (1)),(TRKVMX(1),VMAX (1)), - 4 (TRKDPT(1),PTOP (1)) - - DATA SHALO/'S'/,MEDIUM/'M'/,DEEP/'D'/,EXE/'X'/, - 1 STMTOP/-99.0,700.,400.,200./ - -C FIVMIN IS FIVE MINUTES IN UNITS OF FRACTIONAL DAYS -C FACSPD IS CONVERSION FACTOR FOR R(DEG LAT)=V(M/S)*T(FRAC DAY)* - - DATA IPRNT/0/,FIVMIN/3.4722E-3/,FACSPD/0.77719/ - -C----------------------------------------------------------------------- - - ENTRY SETTRK(IOVITL,IOPTZ,IDATTK,DAY0,DAYMN,DAYMX,DAYOFF, - 1 STMDR0,STMSP0,STLAT0,STLON0,STMNTK,IERSET) - - IERSET=0 - IOPT=IOPTZ - IDTREQ=IDATTK - IF(IOPT .EQ. 5) THEN - STMID (1)=STMNTK(1:3) - ELSE IF(IOPT .EQ. 6) THEN - STMNAM(1)=STMNTK(1:9) - ELSE - WRITE(6,1) IOPT - 1 FORMAT(/'******ILLEGAL OPTION IN SETTRK=',I4) - IERSET=1 - RETURN - ENDIF - - WRITE(6,6) IOPT,STMNTK,DAY0,DAYMN,DAYMX,IDTREQ,IHRREQ - 6 FORMAT(/'...ENTERING SETTRK, WITH IOPT=',I2,'. LOOKING FOR ALL ', - 1 'FIXES FOR ',A,' WITH CENTRAL TIME=',F12.2,/4X,' MIN/MAX', - 2 ' TIMES=',2F12.2,' AND REQUESTED DATE/TIME=',2I10) - - CALL NEWVIT(IOVITL,IPRNT,IOPT,IERVIT,MAXSTM,KSTORM,IDTREQ,IHRREQ, - 1 IHRWIN,IDATE,IUTC,STMLAT,STMLON,STMDIR,STMSPD, - 2 PCEN,PENV,RMAX,VMAX,RMW,R15NE,R15SE,R15SW,R15NW, - 3 PTOP,FSTFLG,STMNAM,STMID,RSMC) - -C CONVERT FIX TIMES TO FLOATING POINT JULIAN DAY - - DO KST=1,KSTORM - CALL ZTIME(IDATE(KST),IUTC(KST),IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/), - $ 1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,STMDAY(KST)) - STMDAY(KST)=STMDAY(KST)+DAYOFF - -c WRITE(6,16) IDATE(KST),IUTC(KST),IYR,IMO,IDA,IHR,IMIN,JDY, -c 1 STMDAY(KST) -c 16 FORMAT('...STORM FIX TIMES ARE: IDATE,IUTC,IYR,IMO,IDA,IHR,IMIN,', -c 1 'JDY,STMDAY'/4X,8I8,F15.5) - - ENDDO - - CALL SORTRL(STMDAY(1:KSTORM),IDASRT(1:KSTORM),KSTORM) - -c WRITE(6,26) (STMDAY(KST),IDASRT(KST),KST=1,KSTORM) -c 26 FORMAT(/'...SORTED STORM DAYS AND INDEX ARE:'/(5X,F15.5,I6)) - -C PICK OUT TIMES AND LOCATIONS FROM SORTED LIST OF STORM DAYS - - NOMIN=.TRUE. - NOMAX=.TRUE. - EXTRPB=.FALSE. - EXTRPF=.FALSE. - KSRTMN=-1 - KSRTMX=-1 - - DO KSRT=1,KSTORM - - IF(STMDAY(KSRT) .GT. DAYMN .AND. NOMIN) THEN - NOMIN=.FALSE. - KSRTMN=KSRT-1 - ENDIF - - IF(STMDAY(KSRT) .GT. DAYMX .AND. NOMAX) THEN - NOMAX=.FALSE. - KSRTMX=KSRT - ENDIF - - ENDDO - - IF(KSRTMN .LE. 0) THEN - -C WE HAVENT'T BEEN ABLE TO FIND A STMDAY THAT IS LESS THAN 8 HOURS -C EARLIER THAN THE TIME WINDOW. EITHER THIS IS THE FIRST TIME -C THIS STORM HAS BEEN RUN OR THERE MAY BE AN ERROR. IN EITHER -C CASE, WE ALLOW EXTRAPOLATION OF THE OBSERVED MOTION BACK -C IN TIME, BUT SET AN ERROR FLAG. THE SAME METHOD IS -C USED FOR THE LAST RUN OF A PARTICULAR STORM. - - DT=STMDAY(1)-DAYMN - IF(DT .LE. 0.333333) THEN - WRITE(6,41) KSTORM,KSRT,DAYMN,(STMDAY(KST),KST=1,KSTORM) - 41 FORMAT(/'######CANNOT FIND STORM RECORDS LESS THAN 8 HOURS ', - 1 'BEFORE WINDOW MINIMUM.'/7X,'THIS IS THE FIRST RECORD ', - 2 'FOR THIS STORM OR THERE MAY BE AN ERROR. KSTORM,KSRT,', - 3 'DAYMN,STMDAY=',2I4,F10.3/(5X,10F12.3)) - IERSET=41 - ENDIF - - EXTRPB=.TRUE. - KSRTMN=0 - ISRT=IDASRT(1) - IDASRT(KSRTMN)=0 - STMDAY(KSRTMN)=DAYMN - TRKDRZ(KSRTMN)=STMDIR(ISRT) - TRKSPZ(KSRTMN)=STMSPD(ISRT) - CALL DS2UV(USTM,VSTM,STMDIR(ISRT),STMSPD(ISRT)) - TRKLTZ(KSRTMN)=STMLAT(ISRT)-VSTM*DT*FACSPD - TRKLNZ(KSRTMN)=STMLON(ISRT)-USTM*DT*FACSPD/COSD(STMLAT(ISRT)) - TRKRMX(KSRTMN)=RMAX(ISRT) - TRKPCN(KSRTMN)=PCEN(ISRT) - TRKPEN(KSRTMN)=PENV(ISRT) - TRKVMX(KSRTMN)=VMAX(ISRT) - TRKDPT(KSRTMN)=PTOP(ISRT) - WRITE(6,39) ISRT,KSRTMN,STMDAY(KSRTMN),TRKDRZ(KSRTMN), - 1 TRKSPZ(KSRTMN),USTM,VSTM,DT,TRKLTZ(KSRTMN), - 2 TRKLNZ(KSRTMN),STMLAT(ISRT),STMLON(ISRT) - 39 FORMAT(/'...EXTRAPOLATING FIX BACKWARDS IN TIME: ISRT,KSRTMN,', - 1 '(STMDAY,TRKDRZ,TRKSPZ(KSRTMN)),USTM,VSTM,DT,'/41X, - 2 '(TRKLTZ,TRKLNZ(KSRTMN)),(STMLAT,STMLON(ISRT))='/40X, - 3 2I3,6F12.3/43X,4F12.3) - ENDIF - - IF(KSRTMX .LE. 0) THEN - DT=DAYMX-STMDAY(KSTORM) - IF(DT .LE. 0.333333) THEN - WRITE(6,51) KSTORM,KSRT,DAYMX,(STMDAY(KST),KST=1,KSTORM) - 51 FORMAT(/'######CANNOT FIND STORM RECORDS MORE THAN 8 HOURS ', - 1 'AFTER WINDOW MAXIMUM.'/7X,'THIS IS THE LAST RECORD ', - 2 'FOR THIS STORM OR THERE MAY BE AN ERROR. KSTORM,KSRT,', - 3 'DAYMX,STMDAY=',2I4,F10.3/(5X,10F12.3)) - IERSET=51 - ENDIF - - EXTRPF=.TRUE. - KSRTMX=KSTORM+1 - ISRT=IDASRT(KSTORM) - IDASRT(KSRTMX)=KSTORM+1 - STMDAY(KSRTMX)=DAYMX - TRKDRZ(KSRTMX)=STMDIR(ISRT) - TRKSPZ(KSRTMX)=STMSPD(ISRT) - CALL DS2UV(USTM,VSTM,TRKDRZ(ISRT),TRKSPZ(ISRT)) - TRKLTZ(KSRTMX)=STMLAT(ISRT)+VSTM*DT*FACSPD - TRKLNZ(KSRTMX)=STMLON(ISRT)+USTM*DT*FACSPD/COSD(STMLAT(ISRT)) - TRKRMX(KSRTMX)=RMAX(ISRT) - TRKPCN(KSRTMX)=PCEN(ISRT) - TRKPEN(KSRTMX)=PENV(ISRT) - TRKVMX(KSRTMX)=VMAX(ISRT) - TRKDPT(KSRTMX)=PTOP(ISRT) - WRITE(6,49) ISRT,STMDAY(KSRTMX),TRKDRZ(KSRTMX),TRKSPZ(KSRTMX), - 1 USTM,VSTM,DT,TRKLTZ(KSRTMX),TRKLNZ(KSRTMX), - 2 STMLAT(ISRT),STMLON(ISRT) - 49 FORMAT(/'...EXTRAPOLATING FIX FORWARDS IN TIME: ISRT,(STMDAY,', - 1 'TRKDIR,TRKSPD(KSRTMX)),USTM,VSTM,DT,'/41X,'(TRKLTZ,', - 2 'TRKLNZ(KSRTMX)),(STMLAT,STMLON(ISRT))='/40X,I3,6F12.3/ - 3 43X,4F12.3) - - ENDIF - - KK=1 - KST0=-1 - TIMMIN=1.E10 - -C PUT ALL FIXES THAT DEFINE THE TIME WINDOW INTO ARRAYS SORTED -C BY TIME. FIRST, ELIMINATE RECORDS WITH DUPLICATE TIMES. -C OUR ARBITRARY CONVENTION IS TO KEEP THE LATEST RECORD. ANY -C FIX TIME WITHIN 5 MINUTES OF ITS PREDECESSOR IN THE SORTED -C LIST IS CONSIDERED DUPLICATE. - - DO KST=KSRTMN,KSRTMX - IF(KST .GT. KSRTMN) THEN - IF(STMDAY(KST)-SRTDAY(KK) .LT. FIVMIN) THEN - WRITE(6,53) KST,KK,STMDAY(KST),SRTDAY(KK) - 53 FORMAT(/'...TIME SORTED FIX RECORDS SHOW A DUPLICATE, KST,KK,', - 1 'STMDAY(KST),SRTDAY(KK)=',2I5,2F12.3) - ELSE - KK=KK+1 - ENDIF - ENDIF - -C STORE SORTED LAT/LON, DIRECTION, SPEED FOR FUTURE USE. - - SRTLAT(KK)=TRKLTZ(IDASRT(KST)) - SRTLON(KK)=TRKLNZ(IDASRT(KST)) - SRTDIR(KK)=TRKDRZ(IDASRT(KST)) - SRTSPD(KK)=TRKSPZ(IDASRT(KST)) - SRTDAY(KK)=STMDAY(KST) - SRTRMX(KK)=TRKRMX(IDASRT(KST)) - SRTPCN(KK)=TRKPCN(IDASRT(KST)) - SRTPEN(KK)=TRKPEN(IDASRT(KST)) - SRTVMX(KK)=TRKVMX(IDASRT(KST)) - SRTDPT(KK)=TRKDPT(IDASRT(KST)) - -c fixit?? - to avoid subscript zero warning on next two lines, I did -c the following .... -cdak ISRTDA(KK)=IDATE(IDASRT(KST)) -cdak ISRTUT(KK)=IUTC (IDASRT(KST)) - if(IDASRT(KST).ne.0) then - ISRTDA(KK)=IDATE(IDASRT(KST)) - ISRTUT(KK)=IUTC (IDASRT(KST)) - else - ISRTDA(KK)=0 - ISRTUT(KK)=0 - end if - - IF(ABS(SRTDAY(KK)-DAY0) .LT. TIMMIN) THEN - IF(ABS(SRTDAY(KK)-DAY0) .LT. FIVMIN) KST0=KK - KSTZ=KK - TIMMIN=ABS(SRTDAY(KK)-DAY0) - ENDIF - ENDDO - - KSTMX=KK - -C ZERO OUT EXTRAPOLATED DATE AND TIME AS A REMINDER - - IF(EXTRPF) THEN - ISRTDA(KSTMX)=0 - ISRTUT(KSTMX)=0 - ENDIF - - IF(EXTRPB) THEN - ISRTDA(1)=0 - ISRTUT(1)=0 - ENDIF - - IF(KSTZ .EQ. KSTMX .AND. .NOT. (EXTRPB .OR. EXTRPF)) THEN - WRITE(6,61) KSTZ,KSTMX,(SRTDAY(KST),KST=1,KSTMX) - 61 FORMAT(/'******THE REFERENCE STORM INDEX IS THE MAXIMUM ALLOWED ', - 1 'A PROBABLE ERROR HAS OCCURRED'/8X,'KSTZ,KSTMX,SRTDAY=', - 2 2I5/(5X,10F12.3)) - CALL ABORT1(' SETTRK',61) - ENDIF - - IF(KST0 .LE. 0) THEN - WRITE(6,72) DAY0,KST0,(SRTDAY(KST),KST=1,KSTMX) - 72 FORMAT(/'******THERE IS NO FIX AT THE ANALYSIS TIME, AN ', - 1 'INTERPOLATED POSITION WILL BE CALCULATED'/5X,'DAY0,', - 2 'KST0,SRTDAY=',F12.3,I6/(5X,10F12.3)) - IF(DAY0-SRTDAY(KSTZ) .GT. 0.0) THEN - RATIO=(DAY0-SRTDAY(KSTZ))/(SRTDAY(KSTZ+1)-SRTDAY(KSTZ)) - STLAT0=SRTLAT(KSTZ)+(SRTLAT(KSTZ+1)-SRTLAT(KSTZ))*RATIO - STLON0=SRTLON(KSTZ)+(SRTLON(KSTZ+1)-SRTLON(KSTZ))*RATIO - STMDR0=SRTDIR(KSTZ)+(SRTDIR(KSTZ+1)-SRTDIR(KSTZ))*RATIO - STMSP0=SRTSPD(KSTZ)+(SRTSPD(KSTZ+1)-SRTSPD(KSTZ))*RATIO - STDAY0=DAY0 - ELSE - RATIO=(DAY0-SRTDAY(KSTZ-1))/(SRTDAY(KSTZ)-SRTDAY(KSTZ-1)) - STLAT0=SRTLAT(KSTZ-1)+(SRTLAT(KSTZ)-SRTLAT(KSTZ-1))*RATIO - STLON0=SRTLON(KSTZ-1)+(SRTLON(KSTZ)-SRTLON(KSTZ-1))*RATIO - STMDR0=SRTDIR(KSTZ-1)+(SRTDIR(KSTZ)-SRTDIR(KSTZ-1))*RATIO - STMSP0=SRTSPD(KSTZ-1)+(SRTSPD(KSTZ)-SRTSPD(KSTZ-1))*RATIO - STDAY0=DAY0 - ENDIF - - ELSE - STLAT0=SRTLAT(KST0) - STLON0=SRTLON(KST0) - STMDR0=SRTDIR(KST0) - STMSP0=SRTSPD(KST0) - STDAY0=SRTDAY(KST0) - ENDIF - - WRITE(6,77) (KSRT,ISRTDA(KSRT),ISRTUT(KSRT), - 1 SRTDAY(KSRT),SRTLAT(KSRT),SRTLON(KSRT), - 2 SRTDIR(KSRT),SRTSPD(KSRT), - 3 SRTPCN(KSRT),SRTPEN(KSRT),SRTRMX(KSRT), - 4 SRTVMX(KSRT),SRTDPT(KSRT),KSRT=1,KSTMX) - 77 FORMAT(/'...FINAL SORTED LIST IS:'/6X,'YYYYMMDD',2X,'HHMM',4X, - 1 'RJDAY',7X,'LAT',7X,'LON',6X,'DIR',7X,'SPEED',4X,' PCEN', - 2 26X,'PENV',6X,'RMAX',5X,'VMAX',4X,'PTOP'/(1X,I3,2X,I8,2X, - 3 I4,8F10.2,2(3X,F5.1))) - - WRITE(6,79) STDAY0,STLAT0,STLON0,STMDR0,STMSP0 - 79 FORMAT(/'...THE REFERENCE TIME, LATITUDE, LONGITUDE, DIRECTION ', - 1 'AND SPEED ARE:',5F12.3) - - WRITE(6,89) - 89 FORMAT(/'...END SETTRK') - - RETURN - -C----------------------------------------------------------------------- - - ENTRY PRVSTM(STLATP,STLONP,STDIRP,STSPDP,STDAYP, - 1 STRMXP,STPCNP,STPENP,STVMXP,STDPTP,KSTPZ) - -C THIS ENTRY IS CURRENTLY SET UP TO RETURN THE TWO PREVIOUS -C SETS OF STORM LAT/LON, DIR/SPD, TIME. FOR CASES IN WHICH -C INSUFFICIENT STORM RECORDS HAVE BEEN FOUND, THE SLOTS ARE -C FILLED WITH -99.0 OR A DASH - -C KSTPZ IS THE NUMBER OF PREVIOUS, NON-EXTRAPOLATED, STORM RECORDS - - KSTPZ=MIN0(MAX0(KSTZ-1,0),NPRVMX) - STLATP(-NPRVMX:-1)=-99.0 - STLONP(-NPRVMX:-1)=-99.0 - STDIRP(-NPRVMX:-1)=-99.0 - STSPDP(-NPRVMX:-1)=-99.0 - STDAYP(-NPRVMX:-1)=-99.0 - STRMXP(-NPRVMX:-1)=-99.0 - STPCNP(-NPRVMX:-1)=-99.0 - STPENP(-NPRVMX:-1)=-99.0 - STVMXP(-NPRVMX:-1)=-99.0 - STDPTP(-NPRVMX:-1)='-' - - DO KSTP=1,KSTPZ - STLATP(-KSTP)=SRTLAT(KSTZ-KSTP) - STLONP(-KSTP)=SRTLON(KSTZ-KSTP) - STDIRP(-KSTP)=SRTDIR(KSTZ-KSTP) - STSPDP(-KSTP)=SRTSPD(KSTZ-KSTP) - STDAYP(-KSTP)=SRTDAY(KSTZ-KSTP) - STRMXP(-KSTP)=SRTRMX(KSTZ-KSTP) - STPCNP(-KSTP)=SRTPCN(KSTZ-KSTP) - STPENP(-KSTP)=SRTPEN(KSTZ-KSTP) - STVMXP(-KSTP)=SRTVMX(KSTZ-KSTP) - -C RECODE PRESSURE STORM DEPTH INTO A CHARACTER - - KTPC=0 - DO KTOP=1,MAXTPC - IF(SRTDPT(KSTZ-KSTP) .EQ. STMTOP(KTOP)) KTPC=KTOP - ENDDO - STDPTP(-KSTP)=STMTPC(KTPC) - - ENDDO - IF(EXTRPB .AND. KSTZ-KSTPZ .LE. 1) KSTPZ=KSTPZ-1 - - IF(KSTPZ .EQ. 0) THEN - WRITE(6,97) - 97 FORMAT(/'...NO STORM RECORDS PRECEEDING THE REFERENCE TIME HAVE ', - 1 'BEEN FOUND BY PRVSTM.') - - ELSE - WRITE(6,98) KSTPZ,NPRVMX,STDAYP(-1) - 98 FORMAT(/'...PRVSTM HAS FOUND',I3,' STORM RECORDS PRECEEDING THE ', - 1 'REFERENCE TIME (MAX ALLOWED=',I2,').'/4X,'THE TIME ', - 2 'CORRESPONDING TO INDEX -1 IS',F12.3,'.') - ENDIF - -C WRITE(6,99) KSTZ,KSTPZ,(STLATP(KK),STLONP(KK),STDIRP(KK), -C 1 STSPDP(KK),STDAYP(KK),STRMXP(KK),STPCNP(KK), -C 2 STPENP(KK),STVMXP(KK),KK=-1,-NPRVMX,-1) -C 99 FORMAT(/'...FROM PRVSTM, KSTZ,KSTPZ,STLATP,STLONP,STDIRP,STSPDP,', -C 1 'STDAYP,STRMXP,STPCNP,STPENP,STVMXP=',2I3/(5X,9F10.2)) - RETURN - -C----------------------------------------------------------------------- - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: NEWVIT READS TROPICAL CYCLONE VITAL STAT. FILE -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06 -C -C ABSTRACT: GENERAL FILE READER FOR TROPICAL CYCLONE VITAL STATISTICS -C FILE. CAN FIND ALL STORMS OF A PARTICULAR NAME OR ID, ALL -C STORMS ON A PARTICULAR DATE/TIME AND VARIOUS COMBINATIONS OF -C THE ABOVE. -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD -C -C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... ) -C INPUT ARGUMENT LIST: -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C DDNAME1 - GENERIC NAME & CONTENT -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE -C FT06F001 - INCLUDE IF ANY PRINTOUT -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE NEWVIT(IOVITL,IPRNT,IOPT,IERVIT,MAXSTM,KSTORM,IDTREQ, - 1 IHRREQ,IHRWIN,IDATE,IUTC,STMLAT,STMLON,STMDIR,STMSPD, - 2 PCEN,PENV,RMAX,VMAX,RMW,R15NE,R15SE,R15SW,R15NW, - 3 PTOP,FSTFLG,STMNAM,STMID,RSMC) - - SAVE - - DIMENSION RINC(5) - - CHARACTER STMNAM*9,STMID*3,RSMC*4 - - LOGICAL FSTFLG - - DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM), - 1 STMDIR(MAXSTM),STMSPD(MAXSTM),IDATE(MAXSTM), - 2 IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM),PCEN(MAXSTM), - 3 PTOP(MAXSTM),RSMC(MAXSTM),RMW(MAXSTM),VMAX(MAXSTM), - 4 R15NW(MAXSTM),R15NE(MAXSTM),R15SE(MAXSTM),R15SW(MAXSTM), - 5 STMID(MAXSTM),FSTFLG(MAXSTM) - - PARAMETER (MAXCHR=95) - PARAMETER (MAXVIT=15) - PARAMETER (MAXTPC= 3) - - CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1, - 1 LATNS*1,LONEW*1,FMTVIT*6,BUFINZ*100,STMREQ*9,RELOCZ*1 - CHARACTER BUFY2K*1 - - DIMENSION IVTVAR(MAXVIT),VITVAR(MAXVIT),VITFAC(MAXVIT), - 1 ISTVAR(MAXVIT),IENVAR(MAXVIT),STMTOP(0:MAXTPC) - - DIMENSION BUFIN(MAXCHR),FMTVIT(MAXVIT) - DIMENSION BUFY2K(MAXCHR) - - EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ), - 1 (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ), - 2 (BUFIN(37),LATNS),(BUFIN(43),LONEW), - 3 (BUFIN(95),STMDPZ),(BUFIN(1),BUFINZ) - - EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ) - - EQUIVALENCE (VITVAR( 3),STMLTZ),(VITVAR( 4),STMLNZ), - 1 (VITVAR( 5),STMDRZ),(VITVAR( 6),STMSPZ), - 2 (VITVAR( 7),PCENZ), (VITVAR( 8),PENVZ), - 3 (VITVAR( 9),RMAXZ), (VITVAR(10),VMAXZ), - 4 (VITVAR(11),RMWZ), (VITVAR(12),R15NEZ), - 5 (VITVAR(13),R15SEZ),(VITVAR(14),R15SWZ), - 6 (VITVAR(15),R15NWZ) - - DATA VITFAC/2*1.0,2*0.1,1.0,0.1,9*1.0/, - 1 FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',2*'(I3.3)', - 2 3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/, - 3 ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/, - 4 IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/, - 5 STMTOP/-99.0,700.,400.,200./ - -C FIVMIN IS FIVE MINUTES IN UNITS OF FRACTIONAL DAYS - - DATA FIVMIN/3.4722E-3/,IRDERM/20/,NUM/1/ - -C THIS SUBROUTINE READS A GLOBAL VITAL STATISTICS FILE FOR -C TROPICAL CYCLONES. THERE ARE A NUMBER OF OPTIONS (IOPT) -C UNDER WHICH THIS ROUTINE WILL OPERATE: -C 1) FIND ALL STORMS ON A SPECIFIED DATE/TIME (+WINDOW) -C 2) FIND A PARTICULAR STORM NAME ON A SPECIFIED DATE/TIME -C (+WINDOW) -C 3) FIND ALL OCCURRENCES OF A PARTICULAR STORM NAME -C 4) SAME AS OPTION 2, EXCEPT FOR A PARTICULAR STORM ID -C 5) SAME AS OPTION 3, EXCEPT FOR A PARTICULAR STORM ID -C 6) ALL OCCURRENCES OF A PARTICULAR STORM NAME, EVEN -C BEFORE IT HAD A NAME (FIND FIRST OCCURRENCE OF -C STORM NAME, SUBSTITUE STORM ID, REWIND, THEN -C EXECUTE OPTION 5 - -C STORM ID POSITON CONTAINS THE BASIN IDENTIFIER IN THE -C LAST CHARACTER. THESE ABBREVIATIONS ARE: -C NORTH ATLANTIC: L -C EAST PACIFIC: E -C CENTRAL PACIFIC: C -C WEST PACIFIC: W -C AUSTRALIAN: U -C SOUTH INDIAN: S -C SOUTH PACIFIC P -C N ARABIAN SEA A -C BAY OF BENGAL B -C SOUTH CHINA SEA O -C EAST CHINA SEA T - -C CHECK INPUT ARGUMENTS ACCORDING TO OPTION. ALSO DO OVERHEAD -C CHORES IF NECESSARY - - IERVIT=0 - STMREQ=' ' - IYRREQ=-9999 - - IF(IOPT .LE. 2 .OR. IOPT .EQ. 4) THEN - IF(IDTREQ .LE. 0) THEN - WRITE(6,11) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1) - 11 FORMAT(/'****** ILLEGAL DATE IN NEWVIT, IOPT,IDTREQ,IHRREQ,', - 1 'IHRWIN,MAXSTM,STMNAM,STMID='/9X,5I10,2X,A9,2X,A3) - IERVIT=10 - ENDIF - - IF(IHRREQ .LT. 0) THEN - WRITE(6,21) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1) - 21 FORMAT(/'****** ILLEGAL HOUR IN NEWVIT, IOPT,IDTREQ,IHRREQ,', - 1 'IHRWIN,MAXSTM,STMNAM,STMID='/9X,5I10,2X,A9,2X,A3) - IERVIT=20 - ENDIF - - IF(IHRWIN .LT. 0) THEN - WRITE(6,31) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1) - 31 FORMAT(/'****** ILLEGAL WINDOW IN NEWVIT, IOPT,IDTREQ,IHRREQ,', - 1 'IHRWIN,MAXSTM,STMNAM,STMID='/9X,5I10,2X,A9,2X,A3) - IERVIT=30 - -C SET UP PARAMETERS FOR TIME WINDOW - - ELSE IF(IHRWIN .GT. 0) THEN - CALL ZTIME(IDTREQ,IHRREQ,IYRWIN,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYRWIN,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0, - $ 0/),1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAY0) - -C NORMAL CASE - - WINDOW=REAL(IHRWIN)/24. - DAYPLS=DAY0+WINDOW+FIVMIN - DAYMNS=DAY0-WINDOW-FIVMIN - ENDIF - ENDIF - - IF(IOPT .EQ. 2 .OR. IOPT .EQ. 3 .OR. IOPT .EQ. 6) THEN - IF(STMNAM(1) .EQ. ' ') THEN - WRITE(6,41) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1) - 41 FORMAT(/'****** ILLEGAL STMNAM IN NEWVIT, IOPT,IDTREQ,IHRREQ,', - 1 'IHRWIN,MAXSTM,STMNAM,STMID='/9X,5I10,2X,A9,2X,A3) - IERVIT=40 - - ELSE - STMREQ=STMNAM(1) - ENDIF - - ELSE IF(IOPT .EQ. 4 .OR. IOPT .EQ. 5) THEN - IF(STMID(1) .EQ. ' ') THEN - WRITE(6,51) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1) - 51 FORMAT(/'****** ILLEGAL STMID IN NEWVIT, IOPT,IDTREQ,IHRREQ,', - 1 'IHRWIN,MAXSTM,STMNAM,STMID='/9X,5I10,2X,A9,2X,A3) - IERVIT=50 - - ELSE - STMREQ=STMID(1) - ENDIF - - ELSE IF(IOPT .NE. 1) THEN - WRITE(6,61) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1) - 61 FORMAT(/'****** ILLEGAL OPTION IN NEWVIT, IOPT,IDTREQ,IHRREQ,', - 1 'IHRWIN,MAXSTM,STMNAM,STMID='/9X,5I10,2X,A9,2X,A3) - IERVIT=60 - ENDIF - -C FOR OPTIONS 3, 5, 6 (ALL OCCURRENCES OPTIONS), SEARCH IS -C RESTRICTED TO A SPECIFIC YEAR when idtreq is positive - - IF(IOPT .EQ. 3 .OR. IOPT .EQ. 5 .OR. IOPT .EQ. 6) - 1 IYRREQ=IDTREQ/10000 - -C ****** ERROR EXIT ****** - - IF(IERVIT .GT. 0) RETURN - -C INITIALIZE FILE AND COUNTERS - - 90 REWIND IOVITL - KREC=0 - KSTORM=0 - NERROR=0 - -C READ A RECORD INTO BUFFER - - 100 CONTINUE - - READ(IOVITL,101,ERR=990,END=200) (BUFIN(NCH),NCH=1,MAXCHR) - 101 FORMAT(95A1) - -C AT THIS POINT WE DO NOT KNOW IF A 2-DIGIT YEAR BEGINS IN COLUMN 20 -C OF THE RECORD (OLD NON-Y2K COMPLIANT FORM) OR IF A 4-DIGIT YEAR -C BEGINS IN COLUMN 20 (NEW Y2K COMPLIANT FORM) - TEST ON LOCATION OF -C LATITUDE N/S INDICATOR TO FIND OUT ... - - IF(BUFIN(35).EQ.'N' .OR. BUFIN(35).EQ.'S') THEN - -C ... THIS RECORD STILL CONTAINS THE OLD 2-DIGIT FORM OF THE YEAR -C ... THIS PROGRAM WILL CONVERT THE RECORD TO A 4-DIGIT YEAR USING THE -C "WINDOWING" TECHNIQUE SINCE SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 2-digit year "',BUFIN(20:21),'"' - PRINT *, ' ' - PRINT '(a,i0,a,a)', 'From unit ',iovitl,'; BUFIN-10: ',bufin - PRINT *, ' ' - BUFY2K(1:19) = BUFIN(1:19) - IF(BUFIN(20)//BUFIN(21).GT.'20') THEN - BUFY2K(20) = '1' - BUFY2K(21) = '9' - ELSE - BUFY2K(20) = '2' - BUFY2K(21) = '0' - ENDIF - BUFY2K(22:95) = BUFIN(20:93) - BUFIN = BUFY2K - PRINT *, ' ' - PRINT *, '==> 2-digit year converted to 4-digit year "', - $ BUFIN(20:23),'" via windowing technique' - PRINT *, ' ' - PRINT *, 'From unit ',iovitl,'; BUFIN-10: ',bufin - PRINT *, ' ' - - ELSE IF(BUFIN(37).EQ.'N' .OR. BUFIN(37).EQ.'S') THEN - -C ... THIS RECORD CONTAINS THE NEW 4-DIGIT FORM OF THE YEAR -C ... NO CONVERSION NECESSARY SINCE THIS SUBSEQUENT LOGIC EXPECTS THIS - - PRINT *, ' ' - PRINT *, '==> Read in RECORD from tcvitals file -- contains a', - $ ' 4-digit year "',BUFIN(20:23),'"' - PRINT *, ' ' - PRINT *, 'From unit ',iovitl,'; BUFIN-10: ',bufin - PRINT *, ' ' - PRINT *, '==> No conversion necessary' - PRINT *, ' ' - - ELSE - - PRINT *, ' ' - PRINT *, '***** Cannot determine if this record contains ', - $ 'a 2-digit year or a 4-digit year - skip it and try reading ', - $ 'the next record' - PRINT *, ' ' - GO TO 100 - - END IF - - KREC=KREC+1 - -C DECODE DATE AND TIME - - DO IV=1,2 - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 BUFINZ) -c WRITE(6,109) IV,ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC, -c 1 FMTVIT(IV) -c 109 FORMAT(/'...DECODING VARIABLE #',I2,' ISTART,IEND,IVALUE,IER,', -c 1 'FMT=',2I4,I10,I3,2X,A10) - ENDDO - -C FILTER OUT RECORDS THAT ARE NOT GATHERED BY CURRENT OPTION - -C FIRST: DATE/TIME/WINDOW FILTER - - IF(IOPT .LE. 2 .OR. IOPT .EQ. 4) THEN - -C EXACT DATE/UTC ARE SPECIFIED - - IF(IHRWIN .EQ. 0) THEN -C WRITE(6,117) IDATEZ,IUTCZ -C 117 FORMAT(/'...NO WINDOW OPTION: IDATEZ,IUTCZ=',2I10) - IF(IDTREQ .NE. IDATEZ) GO TO 100 - IF(IHRREQ .NE. IUTCZ ) GO TO 100 - - ELSE - CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN) - CALL W3DIFDAT((/IYR,IMO,IDA,0,0,0,0,0/),(/1899,12,31,0,0,0,0,0/) - $ ,1,RINC) - JDY = NINT(RINC(1)) - CALL FLDAY(JDY,IHR,IMIN,DAYZ) - -C WRITE(6,119) IYR,IMO,IDA,IHR,IMIN,JDY,DAYZ,DAYMNS,DAYPLS,IYRMNS -C 119 FORMAT('...DEBUGGING WINDOW TIME SELECTION: IYR,IMO,IDA,IHR,', -C 1 'IMIN,JDY,DAYZ,DAYMNS,DAYPLS,IYRMNS='/15X,6I5,3F12.4,I5) - -C YEAR WINDOW, THEN FRACTIONAL JULIAN DAY WINDOW - - IF(IYR .NE. IYRWIN) GO TO 100 - IF(DAYZ .LT. DAYMNS .OR. DAYZ .GT. DAYPLS) GO TO 100 - ENDIF - ENDIF - -C SECOND: STORM NAME FILTER - - IF(IOPT .EQ. 2 .OR. IOPT .EQ. 3 .OR. IOPT .EQ. 6) THEN - IF(IPRNT .GT. 0) WRITE(6,123) STMNMZ,STMREQ - 123 FORMAT('...STORM NAME FILTER, STMNMZ,STMREQ=',A9,2X,A9) - IF(STMNMZ .NE. STMREQ) GO TO 100 - IF(IOPT .EQ. 3 .OR. IOPT .EQ. 6) then - if(iyrreq .gt. 0 .and. IDATEZ/10000 .NE. IYRREQ) go to 100 - endif - -C FOR OPTION 6, BRANCH BACK TO LOOK FOR STORM ID INSTEAD OF -C STORM NAME - - IF(IOPT .EQ. 6) THEN - IOPT=5 - STMREQ=STMIDZ - GO TO 90 - ENDIF - - ENDIF - -C THIRD: STORM ID FILTER - - IF(IOPT .EQ. 4 .AND. STMIDZ .NE. STMREQ) GO TO 100 - IF(IOPT .EQ. 5 .AND. (STMIDZ .NE. STMREQ .OR. (iyrreq .gt. 0 - 1 .and. IDATEZ/10000 .NE. IYRREQ))) GO TO 100 - -C EUREKA - - IF(IPRNT .GT. 0) WRITE(6,137) STMREQ,KREC - 137 FORMAT('...REQUESTED STORM FOUND, NAME/ID=',A9,' AT RECORD #',I6) - - DO IV=3,MAXVIT - CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV), - 1 BUFINZ) - VITVAR(IV)=REAL(IVTVAR(IV))*VITFAC(IV) - ENDDO - -C DEPTH OF CYCLONIC CIRCULATION - - IF(STMDPZ .EQ. 'S') THEN - PTOPZ=STMTOP(1) - ELSE IF(STMDPZ .EQ. 'M') THEN - PTOPZ=STMTOP(2) - ELSE IF(STMDPZ .EQ. 'D') THEN - PTOPZ=STMTOP(3) - ELSE IF(STMDPZ .EQ. 'X') THEN - PTOPZ=-99.0 -C WRITE(6,141) STMDPZ -C 141 FORMAT('******DEPTH OF CYCLONIC CIRCULATION HAS MISSING CODE=',A, -C 1 '.') - ELSE - WRITE(6,143) STMDPZ - 143 FORMAT('******ERROR DECODING DEPTH OF CYCLONIC CIRCULATION, ', - 1 'STMDPZ=',A1,'. ERROR RECOVERY NEEDED.') - ENDIF - -C ***************************************************** -C ***************************************************** -C **** IMPORTANT NOTES: **** -C **** **** -C **** ALL STORM LONGITUDES CONVERTED TO **** -C **** 0-360 DEGREES, POSITIVE EASTWARD !!! **** -C **** **** -C **** ALL STORM SPEEDS ARE IN M/SEC **** -C **** **** -C **** ALL DISTANCE DATA ARE IN KM **** -C **** **** -C **** ALL PRESSURE DATA ARE IN HPA (MB) **** -C ***************************************************** -C ***************************************************** - -C SIGN OF LATITUDE AND CONVERT LONGITUDE - - IF(LATNS .EQ. 'S') THEN - STMLTZ=-STMLTZ - ELSE IF(LATNS .NE. 'N') THEN - WRITE(6,153) STMLTZ,STMLNZ,LATNS - 153 FORMAT('******ERROR DECODING LATNS, ERROR RECOVERY NEEDED. ', - 1 'STMLTZ,STMLNZ,LATNS=',2F12.2,2X,A1) - GO TO 100 - ENDIF - - IF(LONEW .EQ. 'W') THEN - STMLNZ=360.-STMLNZ - ELSE IF(LONEW .NE. 'E') THEN - WRITE(6,157) STMLTZ,STMLNZ,LATNS - 157 FORMAT('******ERROR DECODING LONEW, ERROR RECOVERY NEEDED. ', - 1 'STMLTZ,STMLNZ,LATNS=',2F12.2,2X,A1) - ENDIF - - IF(IPRNT .EQ. 1) - 1 WRITE(6,161) IDATEZ,IUTCZ,STMLTZ,STMLNZ,STMDRZ,STMSPZ,PENVZ, - 2 PCENZ,RMAXZ,VMAXZ,RMWZ,R15NEZ,R15SEZ,R15SWZ,R15NWZ - 161 FORMAT('...ALL STORM DATA CALCULATED: IDATEZ,IUTCZ,STMLTZ,', - 1 'STMLNZ,STMDRZ,STMSPZ,PENVZ,PCENZ,RMAXZ,VMAXZ,RMWZ,', - 2 'R15NEZ,R15SEZ,R15SWZ,R15NWZ='/5X,2I10,13F8.2) - - IF(KSTORM .LT. MAXSTM) THEN - KSTORM=KSTORM+1 - IDATE(KSTORM)=IDATEZ - IUTC(KSTORM)=IUTCZ - PTOP(KSTORM)=PTOPZ - STMLAT(KSTORM)=STMLTZ - STMLON(KSTORM)=STMLNZ - STMDIR(KSTORM)=STMDRZ - STMSPD(KSTORM)=STMSPZ - STMNAM(KSTORM)=STMNMZ - STMID (KSTORM)=STMIDZ - RSMC (KSTORM)=RSMCZ - RMAX(KSTORM)=RMAXZ - PENV(KSTORM)=PENVZ - PCEN(KSTORM)=PCENZ - VMAX(KSTORM)=VMAXZ - RMW(KSTORM)=RMWZ - R15NE(KSTORM)=R15NEZ - R15SE(KSTORM)=R15SEZ - R15SW(KSTORM)=R15SWZ - R15NW(KSTORM)=R15NWZ - -C SET THE FIRST OCCURRENCE FLAG IF PRESENT - - IF(FSTFLZ .EQ. ':') THEN - FSTFLG(KSTORM)=.TRUE. - ELSE - FSTFLG(KSTORM)=.FALSE. - ENDIF - - GO TO 100 - - ELSE - GO TO 300 - ENDIF - - 200 CONTINUE - - IF(KSTORM .GT. 0) THEN - -C NORMAL RETURN HAVING FOUND REQUESTED STORM (S) AT DATE/TIME/WINDOW - - IF(IPRNT .EQ. 1) WRITE(6,201) STMREQ,IDTREQ,IHRREQ,KSTORM,KREC - 201 FORMAT(/'...FOUND STORM NAME/ID ',A12,' AT DATE, TIME=',I9,'/', - 1 I5,' UTC IN VITALS FILE.'/4X,I5,' RECORDS FOUND. ', - 2 'TOTAL NUMBER OF RECORDS READ=',I7) - RETURN - -C UNABLE TO FIND REQUESTED STORM AT DATE/TIME/WINDOW - - ELSE - IF(IOPT .EQ. 1) STMREQ='ALLSTORMS' - WRITE(6,207) IOPT,STMREQ,STMNMZ - 207 FORMAT(/'**** OPTION=',I3,' CANNOT FIND STORM NAME/ID=',A9, - 1 '... LAST STORM FOUND=',A9) - - WRITE(6,209) IDATEZ,IDTREQ,IUTCZ,IHRREQ - 209 FORMAT('**** CANNOT FIND REQUESTED DATE/TIME, (FOUND, ', - 1 'REQUESTED) (DATE/TIME)=',4I10/) - IERVIT=210 - RETURN - - ENDIF - - 300 WRITE(6,301) KSTORM - 301 FORMAT(/'******KSTORM EXCEEDS AVAILABLE SPACE, KSTORM=',I5) - RETURN - - 990 WRITE(6,991) BUFIN - 991 FORMAT('******ERROR READING STORM RECORD. BUFIN IS:'/' ******',A, - 1 '******') - NERROR=NERROR+1 - IF(NERROR .LE. IRDERM) GO TO 100 - IERVIT=990 - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: DECVAR DECODES VARIALES -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2004-06-08 -C -C ABSTRACT: DECODES A PARTICULAR INTEGER VARIABLE FROM AN INPUT -C CHARACTER- BASED RECORD IN THE TROPICAL CYCLONE VITAL STATISTICS -C FILE. THIS IS DONE THROUGH AN INTERNAL READ. -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD -C 2004-06-08 D. A. KEYSER - WHEN INTEGER VALUES ARE DECODED FROM -C CHARACTER-BASED RECORD VIA INTERNAL READ IN THIS SUBR., -C IF BYTE IN UNITS DIGIT LOCATION IS ERRONEOUSLY CODED AS -C BLANK (" "), IT IS REPLACED WITH A "5" IN ORDER TO -C PREVENT INVALID VALUE FROM BEING RETURNED (I.E., IF -C "022 " WAS READ, IT WAS DECODED AS "22", IT IS NOW -C DECODED AS "225" - THIS HAPPENED FOR VALUE OF RADIUS OF -C LAST CLOSED ISOBAR FOR JTWC RECORDS FROM 13 JULY 2000 -C THROUGH FNMOC FIX ON 26 MAY 2004 - THE VALUE WAS REPLACED -C BY CLIMATOLOGY BECAUSE IT FAILED A GROSS CHECK, HAD THIS -C CHANGE BEEN IN PLACE THE DECODED VALUE WOULD HAVE BEEN -C W/I 0.5 KM OF THE ACTUAL VALUE) -C -C USAGE: CALL DECVAR(ISTART,IEND,IVALUE,IERDEC,FMT,BUFF) -C INPUT ARGUMENT LIST: -C ISTART - INTEGER BYTE IN BUFF FROM WHICH TO BEGIN INTERNAL READ -C IEND - INTEGER BYTE IN BUFF FROM WHICH TO END INTERNAL READ -C FMT - CHARACTER*(*) FORMAT TO USE FOR INTERNAL READ -C BUFF - CHARACTER*(*) TROPICAL CYCLONE RECORD -C -C OUTPUT ARGUMENT LIST: -C IVALUE - INTEGER VALUE DECODED FROM BUFF -C IERDEC - ERROR RETURN CODE (= 0 - SUCCESSFUL DECODE, -C =10 - DECODE ERROR) -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: IF IERDEC = 10, IVALUE IS RETURNED AS -9, -99, -999 -C OR -9999999 DEPENDING UPON THE VALUE OF FMT. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE DECVAR(ISTART,IEND,IVALUE,IERDEC,FMT,BUFF) - - PARAMETER (NCHLIN=130) - - CHARACTER FMT*(*),BUFF*(*),BUFF_save*130,OUTLIN*1 - - SAVE - - DIMENSION OUTLIN(NCHLIN) - DIMENSION MISSNG(2:8) - - DATA MISSNG/-9,-99,-999,-9999,-99999,-999999,-9999999/ - -C WRITE(6,1) FMT,ISTART,IEND,BUFF -C 1 FORMAT(/'...FMT,ISTART,IEND=',A10,2I5/' ...BUFF=',A,'...') - - IF(BUFF(IEND:IEND).EQ.' ') THEN - BUFF_save = BUFF - BUFF(IEND:IEND) = '5' - WRITE(6,888) IEND - 888 FORMAT(/' ++++++DECVAR: WARNING -- BLANK (" ") CHARACTER READ IN', - 1 ' UNITS DIGIT IN BYTE',I4,' OF RECORD - CHANGE TO "5" ', - 2 'AND CONTINUE DECODE'/) - OUTLIN=' ' - OUTLIN(IEND:IEND)='5' - WRITE(6,'(130A1)') OUTLIN - WRITE(6,'(A130/)') BUFF_save(1:130) - ENDIF - - READ(BUFF(ISTART:IEND),FMT,ERR=10) IVALUE - - IERDEC=0 - - RETURN - - 10 CONTINUE - - OUTLIN=' ' - OUTLIN(ISTART:IEND)='*' - - IVALUE = -9999999 - K = IEND - ISTART + 1 - IF(K.GT.1 .AND. K.LT.9) IVALUE = MISSNG(K) - - WRITE(6,31) OUTLIN - WRITE(6,32) BUFF(1:130),IVALUE - 31 FORMAT(/' ******DECVAR: ERROR DECODING, BUFF='/130A1) - 32 FORMAT(A130/7X,'VALUE RETURNED AS ',I9/) - - IERDEC=10 - - RETURN - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: TIMSUB PERFORMS TIME CHORES -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-06-05 -C -C ABSTRACT: VARIOUS ENTRIES CONVERT 8 DIGIT YYYYMMDD INTO YEAR, MONTH -C AND DAY, AND FRACTIONAL JULIAN DAY FROM INTEGER JULIAN DAY, HOUR -C AND MINUTE. -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD -C 1998-06-05 D. A. KEYSER - Y2K/F90 COMPLIANCE -C -C USAGE: CALL TIMSUB(IDATE,IUTC,IYR,IMO,IDA,IHR,IMIN,JDY,DAY) -C CALL FLDAY(JDY,IHR,IMIN,DAY) -C INPUT ARGUMENT LIST: -C IDATE - DATE IN FORM YYYYMMDD -C JDY - NUMBER OF DAYS SINCE 12/31/1899 -C -C OUTPUT ARGUMENT LIST: -C IYR - YEAR IN FORM YYYY -C IMO - MONTH OF YEAR -C IDA - DAY OF MONTH -C IHR - HOUR OF DAY -C IMIN - MINUTE OF HOUR -C DAY - FRACTIONAL NUMBER OF DAYS SINCE 12/31/1899 -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE TIMSUB(IDATE,IUTC,IYR,IMO,IDA,IHR,IMIN,JDY,DAY) - -C----------------------------------------------------------------------- - - ENTRY ZTIME(IDATE,IUTC,IYR,IMO,IDA,IHR,IMIN) - -C PARSE 8 DIGIT YYYYMMDD INTO YEAR MONTH AND DAY - - IYR = IDATE/10000 - IMO =(IDATE-IYR*10000)/100 - IDA = IDATE-IYR*10000-IMO*100 - IHR =IUTC/100 - IMIN=IUTC-IHR*100 - RETURN - -C----------------------------------------------------------------------- -C THIS ENTRY CALCULATES THE FRACTIONAL JULIAN DAY FROM INTEGERS -C JULIAN DAY, HOUR AND MINUTE (ACUALLY, JDY HERE IS NO. OF DAYS -C SINCE 12/31/1899) - - ENTRY FLDAY(JDY,IHR,IMIN,DAY) - DAY=REAL(JDY)+(REAL(IHR)*60.+REAL(IMIN))/1440. - RETURN - -C----------------------------------------------------------------------- - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: YTIME GETS INTEGER YYYY, YYYYMMDD, HHMM -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-10-29 -C -C ABSTRACT: CALCULATES 8-DIGIT INTEGER YYYYMMDD, 4-DIGIT INTEGER YYYY, -C AND 6-DIGIT INTEGER HHMMSS FROM FRACTIONAL NUMBER OF DAYS SINCE -C 12/31/1899 -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD -C 1998-10-29 D. A. KEYSER - Y2K/F90 COMPLIANCE -C -C USAGE: CALL YTIME(IYR,DAYZ,IDATE,JUTC) -C INPUT ARGUMENT LIST: -C DAYZ - FRACTIONAL NUMBER OF DAYS SINCE 12/31/1899 -C -C OUTPUT ARGUMENT LIST: -C IYR - YEAR (YYYY) -C IDATEZ - DATE IN FORM YYYYMMDD -C JUTC - DATE IN FORM HHMMSS -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE YTIME(IYR,DAYZ,IDATE,JUTC) - DIMENSION JDAT(8) - - CALL W3MOVDAT((/DAYZ,0.,0.,0.,0./),(/1899,12,31,0,0,0,0,0/),JDAT) - IYR = JDAT(1) - IMO = JDAT(2) - IDA = JDAT(3) - IHR = JDAT(5) - IMN = JDAT(6) - ISC = JDAT(7) - - IDATE=IDA+(100*IMO)+(10000*IYR) - JUTC =ISC+100*IMN+10000*IHR - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: SORTRL SORTS REAL NUMBERS -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-04 -C -C ABSTRACT: SORTS REAL NUMBERS. OUTPUT ARRAY IS THE INDEX OF -C THE INPUT VALUES THAT ARE SORTED. -C -C PROGRAM HISTORY LOG: -C 1991-06-04 S. J. LORD (MODIFIED FROM NCAR CODE) -C -C USAGE: CALL SORTRL(A,LA,NL) -C INPUT ARGUMENT LIST: -C A - ARRAY OF ELEMENTS TO BE SORTED. -C NL - NUMBER OF ELEMENTS TO BE SORTED. -C -C OUTPUT ARGUMENT LIST: -C LA - INTEGER ARRAY CONTAINING THE INDEX OF THE SORTED -C - ELEMENTS. SORTING IS FROM SMALL TO LARGE. E.G. -C - LA(1) CONTAINS THE INDEX OF THE SMALLEST ELEMENT IN -C - ARRAY. LA(NL) CONTAINS THE INDEX OF THE LARGEST. -C -C -C REMARKS: NONE -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE SORTRL(A,LA,NL) - -C ENTRY SORTRL(A,LA,NL) SORT UP REAL NUMBERS -C ** REVISED (6/13/84) FOR THE USE IN VAX-11 -C ARGUMENTS ... -C A INPUT ARRAY OF NL ELEMENTS TO BE SORTED OR RE-ORDERED -C LA OUTPUT ARRAY OF NL ELEMENTS IN WHICH THE ORIGINAL LOCATION -C OF THE SORTED ELEMENTS OF A ARE SAVED, OR -C INPUT ARRAY TO SPECIFY THE REORDERING OF ARRAY A BY SORTED -C NL THE NUMBER OF ELEMENTS TO BE TREATED - - SAVE - - DIMENSION A(NL),LA(NL),LS1(64),LS2(64) - DATA NSX/64/ - -C SET THE ORIGINAL ORDER IN LA - - DO L=1,NL - LA(L)=L - ENDDO - -C SEPARATE NEGATIVES FROM POSITIVES - - L = 0 - M = NL + 1 - 12 L = L + 1 - IF(L.GE.M) GO TO 19 - IF(A(L)) 12,15,15 - 15 M = M - 1 - IF(L.GE.M) GO TO 19 - IF(A(M)) 18,15,15 - 18 AZ = A(M) - A(M) = A(L) - A(L) = AZ - LZ = LA(M) - LA(M) = LA(L) - LA(L) = LZ - GO TO 12 - 19 L = L - 1 - -C NOTE THAT MIN AND MAX FOR INTERVAL (1,NL) HAVE NOT BEEN DETERMINED - - LS1(1) = 0 - L2 = NL + 1 - NS = 1 - -C STEP UP - - 20 LS1(NS) = LS1(NS) + 1 - LS2(NS) = L - NS = NS + 1 - IF(NS.GT.NSX) GO TO 80 - L1 = L + 1 - LS1(NS) = L1 - L2 = L2 - 1 - GO TO 40 - -C STEP DOWN - - 30 NS=NS-1 - IF (NS.LE.0) GO TO 90 - L1 = LS1(NS) - L2 = LS2(NS) - 40 IF(L2.LE.L1) GO TO 30 - -C FIND MAX AND MIN OF THE INTERVAL (L1,L2) - - IF (A(L1)-A(L2) .LE. 0) GO TO 52 - AN = A(L2) - LN = L2 - AX = A(L1) - LX = L1 - GO TO 54 - 52 AN = A(L1) - LN = L1 - AX = A(L2) - LX = L2 - 54 L1A = L1 + 1 - L2A = L2 - 1 - IF(L1A.GT.L2A) GO TO 60 - - DO L=L1A,L2A - IF (A(L)-AX .GT. 0) GO TO 56 - IF (A(L)-AN .GE. 0) GO TO 58 - AN = A(L) - LN = L - GO TO 58 - 56 AX = A(L) - LX = L - 58 CONTINUE - ENDDO - -C IF ALL ELEMENTS ARE EQUAL (AN=AX), STEP DOWN - - 60 IF (AN .EQ. AX) GO TO 30 - -C PLACE MIN AT L1, AND MAX AT L2 -C IF EITHER LN=L2 OR LX=L1, FIRST EXCHANGE L1 AND L2 - - IF(LN.EQ.L2.OR.LX.EQ.L1) GO TO 62 - GO TO 64 - 62 AZ=A(L1) - A(L1)=A(L2) - A(L2)=AZ - LZ=LA(L1) - LA(L1)=LA(L2) - LA(L2)=LZ - -C MIN TO L1, IF LN IS NOT AT EITHER END - - 64 IF(LN.EQ.L1.OR.LN.EQ.L2) GO TO 66 - A(LN)=A(L1) - A(L1)=AN - LZ=LA(LN) - LA(LN)=LA(L1) - LA(L1)=LZ - -C MAX TO L2, IF LX IS NOT AT EITHER END - - 66 IF(LX.EQ.L2.OR.LX.EQ.L1) GO TO 68 - A(LX)=A(L2) - A(L2)=AX - LZ=LA(LX) - LA(LX)=LA(L2) - LA(L2)=LZ - -C IF ONLY THREE ELEMENTS IN (L1,L2), STEP DOWN. - - 68 IF(L1A.GE.L2A) GO TO 30 - -C SET A CRITERION TO SPLIT THE INTERVAL (L1A,L2A) -C AC IS AN APPROXIMATE ARITHMETIC AVERAGE OF AX AND AN, -C PROVIDED THAT AX IS GREATER THAN AN. (IT IS THE CASE, HERE) -C ** IF A IS DISTRIBUTED EXPONENTIALLY, GEOMETRIC MEAN MAY -C BE MORE EFFICIENT - - AC = (AX+AN)/2 - -C MIN AT L1 AND MAX AT L2 ARE OUTSIDE THE INTERVAL - - L = L1 - M = L2 - 72 L = L + 1 - IF(L.GE.M) GO TO 78 -cc 73 CONTINUE - IF (A(L)-AC .LE. 0) GO TO 72 - 75 M = M - 1 - IF(L.GE.M) GO TO 78 -cc 76 CONTINUE - IF (A(M)-AC .GT. 0) GO TO 75 - AZ = A(M) - A(M) = A(L) - A(L) = AZ - LZ = LA(M) - LA(M) = LA(L) - LA(L) = LZ - GO TO 72 - -C SINCE 75 IS ENTERED ONLY IF 73 IS FALSE, 75 IS NOT TENTATIVE -C BUT 72 IS TENTATIVE, AND MUST BE CORRECTED IF NO FALSE 76 OCCURS - - 78 L = L - 1 - GO TO 20 - 80 WRITE(6,85) NSX - 85 FORMAT(/' === SORTING INCOMPLETE. SPLIT EXCEEDED',I3,' ==='/) - 90 RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: DS2UV CONVERTS DIRECTION/SPEED TO U/V MOTION -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06 -C -C ABSTRACT: CONVERTS DIRECTION AND SPEED TO ZONAL AND MERIDIONAL -C MOTION. -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD -C -C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... ) -C INPUT ARGUMENT LIST: -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C DDNAME1 - GENERIC NAME & CONTENT -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE -C FT06F001 - INCLUDE IF ANY PRINTOUT -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE DS2UV(UZ,VZ,DIRZ,SPDZ) - -C THIS SUBROUTINE PRODUCES U, V CARTESIAN WINDS FROM DIRECTION,SPEED -C ****** IMPORTANT NOTE: DIRECTION IS DIRECTION WIND IS -C BLOWING, THE OPPOSITE OF METEOROLOGICAL CONVENTION *** - - UZ=SPDZ*SIND(DIRZ) - VZ=SPDZ*COSD(DIRZ) - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: ATAN2D ARC TAN FUNCTION FROM DEGREES INPUT -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06 -C -C ABSTRACT: ARC TAN FUNCTION FROM DEGREES INPUT. -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD -C -C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... ) -C INPUT ARGUMENT LIST: -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C DDNAME1 - GENERIC NAME & CONTENT -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE -C FT06F001 - INCLUDE IF ANY PRINTOUT -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - FUNCTION ATAN2D(ARG1,ARG2) - -C DEGRAD CONVERTS DEGREES TO RADIANS - - DATA DEGRAD/0.017453/ - IF(ARG1 .EQ. 0.0 .AND. ARG2 .EQ. 0.0) THEN - ATAN2D=0.0 - ELSE - ATAN2D=ATAN2(ARG1,ARG2)/DEGRAD - ENDIF - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: SIND SINE FUNCTION FROM DEGREES INPUT -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06 -C -C ABSTRACT: SINE FUNCTION FROM DEGREES INPUT. -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD -C -C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... ) -C INPUT ARGUMENT LIST: -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C DDNAME1 - GENERIC NAME & CONTENT -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE -C FT06F001 - INCLUDE IF ANY PRINTOUT -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - FUNCTION SIND(ARG) - -C DEGRAD CONVERTS DEGREES TO RADIANS - - DATA DEGRAD/0.017453/ - SIND=SIN(ARG*DEGRAD) - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: COSD COSINE FUNCTION FROM DEGREES INPUT -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06 -C -C ABSTRACT: RETURNS COSINE FUNCTION FROM DEGREES INPUT -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD -C -C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... ) -C INPUT ARGUMENT LIST: -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C DDNAME1 - GENERIC NAME & CONTENT -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE -C FT06F001 - INCLUDE IF ANY PRINTOUT -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - FUNCTION COSD(ARG) - -C DEGRAD CONVERTS DEGREES TO RADIANS - - DATA DEGRAD/0.017453/ - COSD=COS(ARG*DEGRAD) - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: DISTSP DISTANCE ON GREAT CIRCLE -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06 -C -C ABSTRACT: CALCULATES DISTANCE ON GREAT CIRCLE BETWEEN TWO LAT/LON -C POINTS. -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD -C -C USAGE: DXY=DISTSP(DLAT1,DLON1,DLAT2,DLON2) -C INPUT ARGUMENT LIST: -C DLAT1 - LATITUDE OF POINT 1 (-90<=LAT<=90) -C DLON1 - LONGITUDE OF POINT 1 (-180 TO 180 OR 0 TO 360) -C DLAT2 - LATITUDE OF POINT 2 (-90<=LAT<=90) -C DLON1 - LONGITUDE OF POINT 2 -C -C -C REMARKS: DISTANCE IS IN METERS -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - FUNCTION DISTSP(DLAT1,DLON1,DLAT2,DLON2) - DATA REARTH/6.37E6/ - - XXD=COSD(DLON1-DLON2)*COSD(DLAT1)*COSD(DLAT2)+ - 1 SIND(DLAT1)*SIND(DLAT2) - - XXM=AMIN1(1.0,AMAX1(-1.0,XXD)) - - DISTSP=ACOS(XXM)*REARTH - RETURN - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AVGSUB CALCULATES AVERAGES -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-06 -C -C ABSTRACT: CALCULATES AVERAGES WEIGHTED AND UNWEIGHTED FOR ALL -C INPUT NUMBERS OR JUST POSITIVE ONES. -C -C PROGRAM HISTORY LOG: -C 1991-06-06 S. J. LORD -C -C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... ) -C INPUT ARGUMENT LIST: -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C DDNAME1 - GENERIC NAME & CONTENT -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE -C FT06F001 - INCLUDE IF ANY PRINTOUT -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE AVGSUB(XX,WT,LX,AVX) - - DIMENSION XX(LX),WT(LX) - - AVX=0.0 - N=0 - DO L=1,LX - AVX=AVX+XX(L) - N=N+1 - ENDDO - AVX=AVX/REAL(N) - RETURN - -C----------------------------------------------------------------------- - - ENTRY WTAVRG(XX,WT,LX,AVX) - - AVX=0.0 - W=0.0 - DO L=1,LX - AVX=AVX+XX(L)*WT(L) - W=W+WT(L) - ENDDO - AVX=AVX/W - RETURN - -C----------------------------------------------------------------------- - - ENTRY WTAVGP(XX,WT,LX,AVX) - - AVX=0.0 - W=0.0 - DO L=1,LX - IF(XX(L) .GE. 0.0) THEN - AVX=AVX+XX(L)*WT(L) - W=W+WT(L) - ENDIF - ENDDO - IF(W .NE. 0.0) THEN - AVX=AVX/W - ELSE - AVX=XX(1) - ENDIF - RETURN - -C----------------------------------------------------------------------- - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: ABORT1 ERROR EXIT ROUTINE -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-05 -C -C ABSTRACT: ERROR TERMINATION ROUTINE THAT LISTS ROUTINE WHERE -C ERROR OCCURRED AND THE NEAREST STATEMENT NUMBER. -C -C PROGRAM HISTORY LOG: -C 1991-06-05 S. J. LORD -C -C USAGE: CALL ABORT1(ME(KENTRY,ISTMT) -C INPUT ARGUMENT LIST: -C KENTRY - CHARACTER VARIABLE (*7) GIVING PROGRAM OR SUBROUTINE -C - WHERE ERROR OCCURRED. -C ISTMT - STATEMENT NUMBER NEAR WHERE ERROR OCCURRED. -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: THIS ROUTINE IS CALLED WHENEVER AN INTERNAL PROBLEM -C TO THE CODE IS FOUND. EXAMPLES ARE CALLING PARAMETERS THAT -C WILL OVERFLOW ARRAY BOUNDARIES AND OBVIOUS INCONSISTENCIES -C IN NUMBERS GENERATED BY THE CODE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE ABORT1(KENTRY,ISTMT) - CHARACTER*7 KENTRY - WRITE(6,10) KENTRY,ISTMT - 10 FORMAT(//21X,'*********************************************'/ - 1 21X,'*********************************************'/ - 2 21X,'**** PROGRAM FAILED DUE TO FATAL ERROR ****'/ - 3 21X,'**** IN ROUTINE ',A,' NEAR ****'/ - 4 21X,'**** STATEMENT NUMBER',I5,'. ****'/ - 5 21X,'*********************************************'/ - 6 21X,'*********************************************') - CALL W3TAGE('SYNDAT_QCTROPCY') - call ERREXIT (20) - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: OFILE0 OPENS ALL DATA FILES LISTED IN TEXT FILE -C PRGMMR: S. J. LORD ORG: NP22 DATE: 1991-06-07 -C -C ABSTRACT: OPENS ALL OF THE DATA FILES READ FROM A LIST IN A TEXT -C FILE. -C -C PROGRAM HISTORY LOG: -C 1991-06-07 S. J. LORD -C -C USAGE: CALL OFILE0(IUNTOP,NFILMX,NFTOT,FILNAM) -C INPUT ARGUMENT LIST: -C IUNTOP - UNIT NUMBER OF TEXT FILE ASSOCIATING UNIT NUMBERS -C - WITH FILE NAMES -C FILNAM - FILE NAMES (UPON INPUT ONLY ELEMENT 0 STORED - -C - THE FILE NAME ASSOCIATED WITH UNIT IUNTOP) -C NFILMX - THE MAXIMUM NUMBER OF FILES THAT CAN BE OPENED IN -C - THIS SUBROUTINE -C -C OUTPUT ARGUMENT LIST: -C NFTOT - NUMBER OF DATA FILES OPENED IN THIS SUBROUTINE -C -C INPUT FILES: -C UNIT "IUNTOP" -C - TEXT FILE ASSOCIATING UNIT NUMBERS WITH FILE NAMES -C MANY - READ FROM LIST IN UNIT IUNTOP -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: NONE. -C -C ATTRIBUTES: -C MACHINE: IBM-SP -C LANGUAGE: FORTRAN 90 -C -C$$$ - SUBROUTINE OFILE0(IUNTOP,NFILMX,NFTOT,FILNAM) - - PARAMETER (IDGMAX=7) - - SAVE - - CHARACTER FILNAM*(*),CFORM*11,CSTAT*7,CACCES*10,MACHIN*10, - 1 CFZ*1,CSTZ*1,CACZ*1,CPOS*10 - - DIMENSION IUNIT(NFILMX),CFORM(NFILMX),CSTAT(NFILMX), - 1 CACCES(NFILMX),CPOS(NFILMX) - DIMENSION FILNAM(0:NFILMX) - - INTEGER(4) IARGC,NDEF - - NF=0 - -C DEFAULT FILENAME IS SPECIFIED BY THE CALLING PROGRAM. -C RUNNING THE PROGRAM WITH ARGUMENTS ALLOWS -C YOU TO SPECIFY THE FILENAM AS FOLLOWS: - - NDEF=IARGC() - - IF(NDEF .LT. 0) CALL GETARG(1_4,FILNAM(0)) - - LENG0=INDEX(FILNAM(0),' ')-1 - WRITE(6,5) NDEF,FILNAM(0)(1:LENG0) - 5 FORMAT(/'...SETTING UP TO READ I/O FILENAMES AND OPEN PARMS.', - 1 ' NDEF,FILNAM(0)=',I2,1X,'...',A,'...') - - OPEN(UNIT=IUNTOP,FORM='FORMATTED',STATUS='OLD',ACCESS= - 1 'SEQUENTIAL',FILE=FILNAM(0)(1:leng0),ERR=95,IOSTAT=IOS) - - READ(IUNTOP,11,ERR=90) MACHIN - 11 FORMAT(A) - WRITE(6,13) MACHIN - 13 FORMAT('...READY TO READ FILES TO OPEN ON MACHINE ',A) - - DO IFILE=1,NFILMX - NF=NF+1 - READ(IUNTOP,21,END=50,ERR=90,IOSTAT=IOS) IUNIT(NF), - 1 CFZ,CSTZ,CACZ,FILNAM(NF) - 21 FORMAT(I2,3(1X,A1),1X,A) - - LENGTH=INDEX(FILNAM(NF),' ')-1 - WRITE(6,23) NF,IUNIT(NF),CFZ,CSTZ,CACZ,FILNAM(NF)(1:LENGTH) - 23 FORMAT('...FOR FILE #',I3,', READING IUNIT, ABBREVIATIONS CFZ', - 1 ',CSTZ,CACZ='/4X,I3,3(1X,A,1X),5x,'...FILENAME=',A,'...') - -c Interpret the abbreviations - - if(CFZ .eq. 'f' .or. CFZ .eq. 'F') then - cform(nf)='FORMATTED' - else if(CFZ .eq. 'u' .or. CFZ .eq. 'U') then - cform(nf)='UNFORMATTED' - else - write(6,25) CFZ - 25 format('******option ',a,' for format is not allowed. Abort') - call abort1(' OFILE0',25) - endif - - if(CSTZ .eq. 'o' .or. CSTZ .eq. 'O') then - cstat(nf)='OLD' - else if(CSTZ .eq. 'n' .or. CSTZ .eq. 'N') then - cstat(nf)='NEW' - else if(CSTZ .eq. 'k' .or. CSTZ .eq. 'K') then - cstat(nf)='UNKNOWN' - else if(CSTZ .eq. 's' .or. CSTZ .eq. 'S') then - cstat(nf)='SCRATCH' - else - write(6,27) CSTZ - 27 format('******option ',a,' for status is not allowed. Abort') - call abort1(' OFILE0',27) - endif - - cpos(nf)=' ' - if(CACZ .eq. 'd' .or. CACZ .eq. 'D') then - cacces(nf)='DIRECT' - else if(CACZ .eq. 'q' .or. CACZ .eq. 'Q') then - cacces(nf)='SEQUENTIAL' - else if(CACZ .eq. 'a' .or. CACZ .eq. 'A') then - cacces(nf)='APPEND' - else if(CACZ .eq. 's' .or. CACZ .eq. 'S') then - cacces(nf)='SEQUENTIAL' - cpos(nf)='APPEND' - else if(CACZ .eq. 't' .or. CACZ .eq. 'T') then - cacces(nf)='DIRECT' - cpos(nf)='APPEND' - else - write(6,29) CACZ - 29 format('******option ',a,' for access is not allowed. Abort') - call abort1(' OFILE0',29) - endif - - IF(CACCES(NF) .NE. 'DIRECT') THEN - if(cpos(nf) .eq. ' ') then - if (cstat(nf).eq.'OLD') then - OPEN(UNIT=IUNIT(NF),FORM=cform(nf),STATUS='OLD', - 1 ACCESS=cacces(nf),FILE=FILNAM(NF)(1:LENGTH), - 2 ERR=95,IOSTAT=IOS) - elseif (cstat(nf).eq.'NEW') then - OPEN(UNIT=IUNIT(NF),FORM=cform(nf),STATUS='NEW', - 1 ACCESS=cacces(nf),FILE=FILNAM(NF)(1:LENGTH), - 2 ERR=95,IOSTAT=IOS) - elseif (cstat(nf).eq.'UNKNOWN') then - OPEN(UNIT=IUNIT(NF),FORM=cform(nf),STATUS='UNKNOWN', - 1 ACCESS=cacces(nf),FILE=FILNAM(NF)(1:LENGTH), - 2 ERR=95,IOSTAT=IOS) - else - OPEN(UNIT=IUNIT(NF),FORM=cform(nf),STATUS=cstat(nf), - 1 ACCESS=cacces(nf), - 2 ERR=95,IOSTAT=IOS) - endif - else - if (cstat(nf).eq.'OLD') then - open(unit=iunit(nf),form=cform(nf),status='OLD', - 1 access=cacces(nf),position=cpos(nf), - 2 file=filnam(nf)(1:length),err=95,iostat=ios) - elseif (cstat(nf).eq.'NEW') then - open(unit=iunit(nf),form=cform(nf),status='NEW', - 1 access=cacces(nf),position=cpos(nf), - 2 file=filnam(nf)(1:length),err=95,iostat=ios) - elseif (cstat(nf).eq.'UNKNOWN') then - open(unit=iunit(nf),form=cform(nf),status='UNKNOWN', - 1 access=cacces(nf),position=cpos(nf), - 2 file=filnam(nf)(1:length),err=95,iostat=ios) - else - open(unit=iunit(nf),form=cform(nf),status=cstat(nf), - 1 access=cacces(nf),position=cpos(nf), - 2 err=95,iostat=ios) - endif - endif - ELSE - read(filnam(nf)(length+2:length+2+idgmax-1),37) lrec - 37 format(i7) - write(6,39) lrec - 39 format('...Direct access record length:',i7,'...') - if(cpos(nf) .eq. ' ') then - if (cstat(nf).eq.'OLD') then - OPEN(UNIT=IUNIT(NF),FORM=CFORM(NF),STATUS='OLD', - 1 ACCESS=CACCES(NF),FILE=FILNAM(NF)(1:LENGTH), - 2 ERR=95,IOSTAT=IOS,RECL=lrec) - elseif (cstat(nf).eq.'NEW') then - OPEN(UNIT=IUNIT(NF),FORM=CFORM(NF),STATUS='NEW', - 1 ACCESS=CACCES(NF),FILE=FILNAM(NF)(1:LENGTH), - 2 ERR=95,IOSTAT=IOS,RECL=lrec) - elseif (cstat(nf).eq.'UNKNOWN') then - OPEN(UNIT=IUNIT(NF),FORM=CFORM(NF),STATUS='UNKNOWN', - 1 ACCESS=CACCES(NF),FILE=FILNAM(NF)(1:LENGTH), - 2 ERR=95,IOSTAT=IOS,RECL=lrec) - else - OPEN(UNIT=IUNIT(NF),FORM=CFORM(NF),STATUS=CSTAT(NF), - 1 ACCESS=CACCES(NF), - 2 ERR=95,IOSTAT=IOS,RECL=lrec) - endif - else - if (cstat(nf).eq.'OLD') then - open(unit=iunit(nf),form=cform(nf),status='OLD', - 1 access=cacces(nf),file=filnam(nf)(1:length), - 2 position=cpos(nf),err=95,iostat=ios,recl=lrec) - elseif (cstat(nf).eq.'NEW') then - open(unit=iunit(nf),form=cform(nf),status='NEW', - 1 access=cacces(nf),file=filnam(nf)(1:length), - 2 position=cpos(nf),err=95,iostat=ios,recl=lrec) - elseif (cstat(nf).eq.'UNKNOWN') then - open(unit=iunit(nf),form=cform(nf),status='UNKNOWN', - 1 access=cacces(nf),file=filnam(nf)(1:length), - 2 position=cpos(nf),err=95,iostat=ios,recl=lrec) - else - open(unit=iunit(nf),form=cform(nf),status=cstat(nf), - 1 access=cacces(nf), - 2 position=cpos(nf),err=95,iostat=ios,recl=lrec) - endif - endif - ENDIF - ENDDO - - WRITE(6,391) NFILMX - 391 FORMAT('******NUMBER OF FILES TO BE OPENED MEETS OR EXCEEDS ', - 1 'MAXIMUM SET BY PROGRAM (=',I3) - CALL ABORT1(' OFILE0',50) - - 50 CONTINUE - -C WE HAVE DEFINED AND OPENED ALL FILES - - NFTOT=NF-1 - WRITE(6,51) NFTOT,MACHIN - 51 FORMAT(/'...SUCCESSFULLY OPENED ',I3,' FILES ON ',A) - RETURN - - 90 CONTINUE - WRITE(6,91) FILNAM(0)(1:leng0),ios - 91 FORMAT('******ERROR READING OPEN FILE=',A,' error=',i4) - CALL ABORT1(' OFILE0',91) - - 95 CONTINUE - WRITE(6,96) NF,IOS - 96 FORMAT('******ERROR UPON OPENING FILE, NF,IOS=',2I5) - CALL ABORT1(' OFILE0',96) - - END diff --git a/sorc/tave.fd/CMakeLists.txt b/sorc/tave.fd/CMakeLists.txt deleted file mode 100644 index b24a91fe9a..0000000000 --- a/sorc/tave.fd/CMakeLists.txt +++ /dev/null @@ -1,19 +0,0 @@ -list(APPEND fortran_src - tave.f -) - -if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -i4 -r8") -elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8") -endif() - -set(exe_name tave.x) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - bacio::bacio_4 - w3nco::w3nco_d - g2::g2_d) - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/tave.fd/makefile b/sorc/tave.fd/makefile deleted file mode 100755 index 3ccaf4b87b..0000000000 --- a/sorc/tave.fd/makefile +++ /dev/null @@ -1,25 +0,0 @@ -SHELL= /bin/sh -ISIZE = 4 -RSIZE = 8 -COMP= ifort -##INC = /contrib/nceplibs/nwprod/lib/incmod/g2_d -##LIBS= -L/contrib/nceplibs/nwprod/lib -lw3emc_d -lw3nco_d -lg2_d -lbacio_4 -ljasper -lpng -lz -LDFLAGS= -# DEBUG= -check all -debug all -traceback -FFLAGS= -O2 -g -traceback -I $(INC) -i$(ISIZE) -r$(RSIZE) -# FFLAGS= -O3 -I $(INC) -i$(ISIZE) -r$(RSIZE) - -tave: tave.f - @echo " " - @echo " Compiling the interpolation program....." - $(COMP) $(FFLAGS) $(LDFLAGS) tave.f $(LIBS) -o tave.x - @echo " " - -CMD = tave.x - -clean: - -rm -f *.o *.mod - -install: - mv $(CMD) ../../exec/$(CMD) - diff --git a/sorc/tave.fd/tave.f b/sorc/tave.fd/tave.f deleted file mode 100755 index bbf5263463..0000000000 --- a/sorc/tave.fd/tave.f +++ /dev/null @@ -1,1083 +0,0 @@ - program tave -c -c ABSTRACT: This program averages the temperatures from an input -c grib file and produces an output grib file containing the mean -c temperature in the 300-500 mb layer. For each model and each -c lead time, there will need to be data from 300 to 500 mb in -c 50 mb increments, such that all 5 of these layers then get -c averaged together. -c -c Written by Tim Marchok - - USE params - USE grib_mod - - implicit none - - type(gribfield) :: holdgfld - integer, parameter :: lugb=11,lulv=16,lugi=31,lout=51 - integer, parameter :: nlevsout=1,nlevsin=5 - integer kpds(200),kgds(200) - integer iriret,iogret,kf,iggret,igdret,iidret,gribver,g2_jpdtn - integer iha,iho,iva,irfa,iodret,ifcsthour,iia,iparm - integer ilevs(nlevsin) - real, allocatable :: xinptmp(:,:),xouttmp(:) - logical(1), allocatable :: valid_pt(:),readflag(:) - real xoutlev - - namelist/timein/ifcsthour,iparm,gribver,g2_jpdtn -c - data ilevs /300, 350, 400, 450, 500/ - xoutlev = 401. -c - read (5,NML=timein,END=201) - 201 continue - print *,' ' - print *,'*---------------------------------------------*' - print *,' ' - print *,' +++ Top of tave +++ ' - print *,' ' - print *,'After tave namelist read, input forecast hour= ' - & ,ifcsthour - print *,' input GRIB parm= ',iparm - print *,' GRIB version= ',gribver - print *,' GRIB2 JPDTN= g2_jpdtn= ' - & ,g2_jpdtn - -c ilevs = -999 -c call read_input_levels (lulv,nlevsin,ilevs,iriret) -c -c if (iriret /= 0) then -c print *,' ' -c print *,'!!! RETURN CODE FROM read_input_levels /= 0' -c print *,'!!! RETURN CODE = iriret = ',iriret -c print *,'!!! EXITING....' -c print *,' ' -c goto 899 -c endif - - call open_grib_files (lugb,lugi,lout,gribver,iogret) - if (iogret /= 0) then - print '(/,a35,a5,i4,/)','!!! ERROR: in tave open_grib_files,' - & ,' rc= ',iogret - goto 899 - endif - call getgridinfo (lugb,lugi,kf,kpds,kgds,holdgfld,ifcsthour,iparm - & ,gribver,g2_jpdtn,iggret) - - allocate (xinptmp(kf,nlevsin),stat=iha) - allocate (xouttmp(kf),stat=iho) - allocate (valid_pt(kf),stat=iva) - allocate (readflag(nlevsin),stat=irfa) - if (iha /= 0 .or. iho /= 0 .or. iva /= 0 .or. irfa /= 0) then - print *,' ' - print *,'!!! ERROR in tave allocating arrays.' - print *,'!!! ERROR allocating the xinptmp, readflag, or the' - print *,'!!! valid_pt array, iha= ',iha,' iva= ',iva - print *,'!!! irfa= ',irfa,' iho= ',iho - print *,' ' - goto 899 - endif - - call getdata (lugb,lugi,kf,valid_pt,nlevsin,ilevs - & ,readflag,xinptmp,ifcsthour,iparm,gribver - & ,g2_jpdtn,igdret) - - call average_data (kf,valid_pt,nlevsin,ilevs,readflag - & ,xinptmp,xouttmp,iidret) - - call output_data (lout,kf,kpds,kgds,holdgfld,xouttmp,valid_pt - & ,xoutlev,nlevsout,gribver,ifcsthour,iodret) - - deallocate (xinptmp) - deallocate (xouttmp) - deallocate (valid_pt) - deallocate (readflag) - - 899 continue -c - stop - end -c -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine read_input_levels (lulv,nlevsin,ilevs,iriret) -c -c ABSTRACT: This subroutine reads in a text file that contains -c the number of input pressure levels for a given model. The -c format of the file goes like this, from upper levels to -c lower, for example: -c -c 1 200 -c 2 400 -c 3 500 -c 4 700 -c 5 850 -c 6 925 -c 7 1000 -c -c - implicit none - - integer lulv,nlevsin,iriret,inplev,ict,lvix - integer ilevs(nlevsin) -c - iriret=0 - ict = 0 - do while (.true.) - - print *,'Top of while loop in tave read_input_levels' - - read (lulv,85,end=130) lvix,inplev - - if (inplev > 0 .and. inplev <= 1000) then - ict = ict + 1 - ilevs(ict) = inplev - else - print *,' ' - print *,'!!! ERROR: Input level not between 0 and 1000' - print *,'!!! in tave. inplev= ',inplev - print *,'!!! STOPPING EXECUTION' - STOP 91 - endif - - print *,'tave readloop, ict= ',ict,' inplev= ',inplev - - enddo - - 85 format (i4,1x,i4) - 130 continue - - nlevsin = ict - - print *,' ' - print *,'Total number of tave levels read in = ',nlevsin -c - return - end - -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine getgridinfo (lugb,lugi,kf,kpds,kgds,holdgfld,ifcsthour - & ,iparm,gribver,g2_jpdtn,iggret) -c -c ABSTRACT: The purpose of this subroutine is just to get the max -c values of i and j and the dx and dy grid spacing intervals for the -c grid to be used in the rest of the program. So just read the -c grib file to get the lon and lat data. Also, get the info for -c the data grids boundaries. This boundary information will be -c used later in the tracking algorithm, and is accessed via Module -c grid_bounds. -c -C INPUT: -C lugb The Fortran unit number for the GRIB data file -C lugi The Fortran unit number for the GRIB index file -c ifcsthour input forecast hour to search for -c iparm input grib parm to search for -c gribver integer (1 or 2) to indicate if using GRIB1 / GRIB2 -c g2_jpdtn If GRIB2 data being read, this is the value for JPDTN -c that is input to getgb2. -C -C OUTPUT: -c kf Number of gridpoints on the grid -c kpds pds array for a GRIB1 record -c kgds gds array for a GRIB1 record -c holdgfld info for a GRIB2 record -c -C iggret The return code from this subroutine -c - USE params - USE grib_mod - - implicit none -c - CHARACTER(len=8) :: ctemp - CHARACTER(len=80) :: ftemplate - type(gribfield) :: gfld,prevfld,holdgfld - integer,dimension(200) :: jids,jpdt,jgdt - logical(1), allocatable :: lb(:) - integer, parameter :: jf=4000000 - integer jpds(200),jgds(200) - integer kpds(200),kgds(200) - integer :: listsec1(13) - integer ila,ifa,iret,ifcsthour,imax,jmax,jskp,jdisc - integer lugb,lugi,kf,j,k,iggret,iparm,gribver,g2_jpdtn - integer jpdtn,jgdtn,npoints,icount,ipack,krec - integer :: listsec0(2)=(/0,2/) - integer :: igds(5)=(/0,0,0,0,0/),previgds(5) - integer :: idrstmpl(200) - integer :: currlen=1000000 - logical :: unpack=.true. - logical :: open_grb=.false. - real, allocatable :: f(:) - real dx,dy -c - iggret = 0 - - allocate (lb(jf),stat=ila) - allocate (f(jf),stat=ifa) - if (ila /= 0 .or. ifa /= 0) then - print *,' ' - print *,'!!! ERROR in tave.' - print *,'!!! ERROR in getgridinfo allocating either lb or f' - print *,'!!! ila = ',ila,' ifa= ',ifa - iggret = 97 - return - endif - - if (gribver == 2) then - - ! Search for a record from a GRIB2 file - - ! - ! --- Initialize Variables --- - ! - - gfld%idsect => NULL() - gfld%local => NULL() - gfld%list_opt => NULL() - gfld%igdtmpl => NULL() - gfld%ipdtmpl => NULL() - gfld%coord_list => NULL() - gfld%idrtmpl => NULL() - gfld%bmap => NULL() - gfld%fld => NULL() - - jdisc=0 ! Meteorological products - jids=-9999 - jpdtn=g2_jpdtn ! 0 = analysis or forecast; 1 = ens fcst - jgdtn=0 ! lat/lon grid - jgdt=-9999 - jpdt=-9999 - - npoints=0 - icount=0 - jskp=0 - -c Search for Temperature by production template 4.0 - - JPDT(1:15)=(/ -9999,-9999,-9999,-9999,-9999,-9999,-9999,-9999 - & ,-9999,-9999,-9999,-9999,-9999,-9999,-9999/) - - call getgb2(lugb,lugi,jskp,jdisc,jids,jpdtn,jpdt,jgdtn,jgdt - & ,unpack,krec,gfld,iret) - if ( iret.ne.0) then - print *,' ' - print *,' ERROR: getgb2 error in getgridinfo = ',iret - endif - -c Determine packing information from GRIB2 file -c The default packing is 40 JPEG 2000 - - ipack = 40 - - print *,' gfld%idrtnum = ', gfld%idrtnum - - ! Set DRT info ( packing info ) - if ( gfld%idrtnum.eq.0 ) then ! Simple packing - ipack = 0 - elseif ( gfld%idrtnum.eq.2 ) then ! Complex packing - ipack = 2 - elseif ( gfld%idrtnum.eq.3 ) then ! Complex & spatial packing - ipack = 31 - elseif ( gfld%idrtnum.eq.40.or.gfld%idrtnum.eq.15 ) then - ! JPEG 2000 packing - ipack = 40 - elseif ( gfld%idrtnum.eq.41 ) then ! PNG packing - ipack = 41 - endif - - print *,'After check of idrtnum, ipack= ',ipack - - print *,'Number of gridpts= gfld%ngrdpts= ',gfld%ngrdpts - print *,'Number of elements= gfld%igdtlen= ',gfld%igdtlen - print *,'PDT num= gfld%ipdtnum= ',gfld%ipdtnum - print *,'GDT num= gfld%igdtnum= ',gfld%igdtnum - - imax = gfld%igdtmpl(8) - jmax = gfld%igdtmpl(9) - dx = float(gfld%igdtmpl(17))/1.e6 - dy = float(gfld%igdtmpl(17))/1.e6 - kf = gfld%ngrdpts - - holdgfld = gfld - - else - - ! Search for a record from a GRIB1 file - - jpds = -1 - jgds = -1 - - j=0 - - jpds(5) = iparm ! Get a temperature record - jpds(6) = 100 ! Get a record on a standard pressure level - jpds(14) = ifcsthour - - call getgb(lugb,lugi,jf,j,jpds,jgds, - & kf,k,kpds,kgds,lb,f,iret) - - if (iret.ne.0) then - print *,' ' - print *,'!!! ERROR in tave getgridinfo calling getgb' - print *,'!!! Return code from getgb = iret = ',iret - iggret = iret - return - else - iggret=0 - imax = kgds(2) - jmax = kgds(3) - dx = float(kgds(9))/1000. - dy = float(kgds(10))/1000. - endif - - endif - - print *,' ' - print *,'In getgridinfo, grid dimensions follow:' - print *,'imax= ',imax,' jmax= ',jmax - print *,' dx= ',dx,' dy= ',dy - print *,'number of gridpoints = ',kf - - deallocate (lb); deallocate(f) - - return - end - -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine getdata (lugb,lugi,kf,valid_pt,nlevsin,ilevs - & ,readflag,xinptmp,ifcsthour,iparm,gribver - & ,g2_jpdtn,igdret) -c -c ABSTRACT: This subroutine reads the input GRIB file for the -c tracked parameters. - - USE params - USE grib_mod - - implicit none -c - type(gribfield) :: gfld,prevfld - CHARACTER(len=8) :: ctemp,pabbrev - CHARACTER(len=80) :: ftemplate - integer,dimension(200) :: jids,jpdt,jgdt - integer, parameter :: jf=4000000 - integer ilevs(nlevsin) - integer jpds(200),jgds(200),kpds(200),kgds(200) - integer lugb,lugi,kf,nlevsin,igdret,iparm,jskp,jdisc - integer jpdtn,jgdtn,npoints,icount,ipack,krec - integer i,j,k,ict,np,lev,ifcsthour,iret,gribver,g2_jpdtn - integer pdt_4p0_vert_level,pdt_4p0_vtime,mm - integer :: listsec0(2)=(/0,2/) - integer :: listsec1(13) - integer :: igds(5)=(/0,0,0,0,0/),previgds(5) - integer :: idrstmpl(200) - integer :: currlen=1000000 - logical :: unpack=.true. - logical :: open_grb=.false. - logical(1) valid_pt(kf),lb(kf),readflag(nlevsin) - real f(kf),xinptmp(kf,nlevsin),xtemp(kf) - real dmin,dmax,firstval,lastval -c - igdret=0 - ict = 0 - - print *,'At top of getdata, ifcsthour= ',ifcsthour - - level_loop: do lev = 1,nlevsin - - print *,' ' - print *,'------------------------------------------------' - print *,'In tave getdata read loop, lev= ',lev,' level= ' - & ,ilevs(lev) - - if (gribver == 2) then - - ! - ! --- Initialize Variables --- - ! - - gfld%idsect => NULL() - gfld%local => NULL() - gfld%list_opt => NULL() - gfld%igdtmpl => NULL() - gfld%ipdtmpl => NULL() - gfld%coord_list => NULL() - gfld%idrtmpl => NULL() - gfld%bmap => NULL() - gfld%fld => NULL() - - jdisc=0 ! Meteorological products - jids=-9999 - jpdtn=g2_jpdtn ! 0 = analysis or forecast; 1 = ens fcst - jgdtn=0 ! lat/lon grid - jgdt=-9999 - jpdt=-9999 - - npoints=0 - icount=0 - jskp=0 - -c Search for input parameter by production template 4.0. This -c tave program is used primarily for temperature, but still we -c will leave that as a variable and not-hard wire it in case we -c choose to average something else in the future. - - if (iparm == 11) then - - ! Set defaults for JPDT, then override in array - ! assignments below... - - JPDT(1:15)=(/ -9999,-9999,-9999,-9999,-9999,-9999,-9999 - & ,-9999,-9999,-9999,-9999,-9999,-9999,-9999,-9999/) - JPDT(1) = 0 ! Param category from Table 4.1 - JPDT(2) = 0 ! Param number from Table 4.2 - JPDT(9) = ifcsthour - JPDT(10) = 100 ! Isobaric surface requested (Table 4.5) - JPDT(12) = ilevs(lev) * 100 ! value of specific level - - print *,'In getdata, just set JPDT inputs....' - - endif - - print *,'before getgb2 call, value of unpack = ',unpack - - do mm = 1,15 - print *,'tave getdata mm= ',mm,' JPDT(mm)= ',JPDT(mm) - enddo - - call getgb2(lugb,lugi,jskp,jdisc,jids,jpdtn,jpdt,jgdtn,jgdt - & ,unpack,krec,gfld,iret) - - print *,'iret from getgb2 in getdata = ',iret - - print *,'after getgb2 call, value of unpacked = ' - & ,gfld%unpacked - - print *,'after getgb2 call, gfld%ndpts = ',gfld%ndpts - print *,'after getgb2 call, gfld%ibmap = ',gfld%ibmap - - if ( iret == 0) then - -c Determine packing information from GRIB2 file -c The default packing is 40 JPEG 2000 - - ipack = 40 - - print *,' gfld%idrtnum = ', gfld%idrtnum - - ! Set DRT info ( packing info ) - if ( gfld%idrtnum.eq.0 ) then ! Simple packing - ipack = 0 - elseif ( gfld%idrtnum.eq.2 ) then ! Complex packing - ipack = 2 - elseif ( gfld%idrtnum.eq.3 ) then ! Complex & spatial - & ! packing - ipack = 31 - elseif ( gfld%idrtnum.eq.40.or.gfld%idrtnum.eq.15 ) then - ! JPEG 2000 packing - ipack = 40 - elseif ( gfld%idrtnum.eq.41 ) then ! PNG packing - ipack = 41 - endif - - print *,'After check of idrtnum, ipack= ',ipack - - print *,'Number of gridpts= gfld%ngrdpts= ',gfld%ngrdpts - print *,'Number of elements= gfld%igdtlen= ',gfld%igdtlen - print *,'GDT num= gfld%igdtnum= ',gfld%igdtnum - - kf = gfld%ndpts ! Number of gridpoints returned from read - - do np = 1,kf - xinptmp(np,lev) = gfld%fld(np) - xtemp(np) = gfld%fld(np) - if (gfld%ibmap == 0) then - valid_pt(np) = gfld%bmap(np) - else - valid_pt(np) = .true. - endif - enddo - - readflag(lev) = .TRUE. -c call bitmapchk(kf,gfld%bmap,gfld%fld,dmin,dmax) - call bitmapchk(kf,valid_pt,xtemp,dmin,dmax) - - if (ict == 0) then -c do np = 1,kf -c valid_pt(np) = gfld%bmap(np) -c enddo - ict = ict + 1 - endif - - firstval=gfld%fld(1) - lastval=gfld%fld(kf) - - print *,' ' - print *,' SECTION 0: discipl= ',gfld%discipline - & ,' gribver= ',gfld%version - - print *,' ' - print *,' SECTION 1: ' - - do j = 1,gfld%idsectlen - print *,' sect1, j= ',j,' gfld%idsect(j)= ' - & ,gfld%idsect(j) - enddo - - if ( associated(gfld%local).AND.gfld%locallen.gt.0) then - print *,' ' - print *,' SECTION 2: ',gfld%locallen,' bytes' - else - print *,' ' - print *,' SECTION 2 DOES NOT EXIST IN THIS RECORD' - endif - - print *,' ' - print *,' SECTION 3: griddef= ',gfld%griddef - print *,' ngrdpts= ',gfld%ngrdpts - print *,' numoct_opt= ',gfld%numoct_opt - print *,' interp_opt= ',gfld%interp_opt - print *,' igdtnum= ',gfld%igdtnum - print *,' igdtlen= ',gfld%igdtlen - - print *,' ' - print '(a17,i3,a2)',' GRID TEMPLATE 3.',gfld%igdtnum,': ' - do j=1,gfld%igdtlen - print *,' j= ',j,' gfld%igdtmpl(j)= ',gfld%igdtmpl(j) - enddo - - print *,' ' - print *,' PDT num (gfld%ipdtnum) = ',gfld%ipdtnum - print *,' ' - print '(a20,i3,a2)',' PRODUCT TEMPLATE 4.',gfld%ipdtnum,': ' - do j=1,gfld%ipdtlen - print *,' sect 4 j= ',j,' gfld%ipdtmpl(j)= ' - & ,gfld%ipdtmpl(j) - enddo - -c Print out values for data representation type - - print *,' ' - print '(a21,i3,a2)',' DATA REP TEMPLATE 5.',gfld%idrtnum - & ,': ' - do j=1,gfld%idrtlen - print *,' sect 5 j= ',j,' gfld%idrtmpl(j)= ' - & ,gfld%idrtmpl(j) - enddo - - pdt_4p0_vtime = gfld%ipdtmpl(9) - pdt_4p0_vert_level = gfld%ipdtmpl(12) - -c Get parameter abbrev for record that was retrieved - - pabbrev=param_get_abbrev(gfld%discipline,gfld%ipdtmpl(1) - & ,gfld%ipdtmpl(2)) - - print *,' ' - write (6,131) - 131 format (' rec# param level byy bmm bdd bhh ' - & ,'fhr npts firstval lastval minval ' - & ,' maxval') - print '(i5,3x,a8,2x,6i5,2x,i8,4g12.4)' - & ,krec,pabbrev,pdt_4p0_vert_level/100,gfld%idsect(6) - & ,gfld%idsect(7),gfld%idsect(8),gfld%idsect(9) - & ,pdt_4p0_vtime,gfld%ndpts,firstval,lastval,dmin,dmax - -c do np = 1,kf -c xinptmp(np,lev) = gfld%fld(np) -c enddo - - else - - print *,' ' - print *,'!!! ERROR: GRIB2 TAVE READ IN GETDATA FAILED FOR ' - & ,'LEVEL LEV= ',LEV - print *,' ' - - readflag(lev) = .FALSE. - - do np = 1,kf - xinptmp(np,lev) = -99999.0 - enddo - - endif - - else - - ! Reading a GRIB1 file.... - - jpds = -1 - jgds = -1 - j=0 - - jpds(5) = iparm ! parameter id for temperature - jpds(6) = 100 ! level id to indicate a pressure level - jpds(7) = ilevs(lev) ! actual level of the layer - jpds(14) = ifcsthour ! lead time to search for - - call getgb (lugb,lugi,jf,j,jpds,jgds, - & kf,k,kpds,kgds,lb,f,iret) - - print *,' ' - print *,'After tave getgb call, j= ',j,' k= ',k,' level= ' - & ,ilevs(lev),' iret= ',iret - - if (iret == 0) then - - readflag(lev) = .TRUE. - call bitmapchk(kf,lb,f,dmin,dmax) - - if (ict == 0) then - do np = 1,kf - valid_pt(np) = lb(np) - enddo - ict = ict + 1 - endif - - write (6,31) - 31 format (' rec# parm# levt lev byy bmm bdd bhh fhr ' - & ,'npts minval maxval') - print '(i4,2x,8i5,i8,2g12.4)', - & k,(kpds(i),i=5,11),kpds(14),kf,dmin,dmax - - do np = 1,kf - xinptmp(np,lev) = f(np) - enddo - - else - - print *,' ' - print *,'!!! ERROR: TAVE READ FAILED FOR LEVEL LEV= ',LEV - print *,' ' - - readflag(lev) = .FALSE. - - do np = 1,kf - xinptmp(np,lev) = -99999.0 - enddo - - endif - - endif - - enddo level_loop -c - return - end -c -c----------------------------------------------------------------------- -c -c----------------------------------------------------------------------- - subroutine average_data (kf,valid_pt,nlevsin,ilevs,readflag - & ,xinptmp,xouttmp,iidret) -c -c ABSTRACT: This routine averages data between 300 and 500 mb to get -c a mean temperature at 400 mb. The input data should be at 50 mb -c resolution, giving 5 input levels in total. - - implicit none - - logical(1) valid_pt(kf),readflag(nlevsin) - integer ilevs(nlevsin) - integer nlevsin,kf,k,n,iidret - real xinptmp(kf,nlevsin),xouttmp(kf) - real xinlevs_p(nlevsin),xinlevs_lnp(nlevsin) - real xsum -c - iidret=0 - print *,'*----------------------------------------------*' - print *,' Top of average data routine' - print *,'*----------------------------------------------*' - print *,' ' - - do n = 1,kf - xsum = 0.0 -c print *,' ' - do k = 1,nlevsin - xsum = xsum + xinptmp(n,k) -c print *,'n= ',n,' k= ',k,' xsum= ',xsum - enddo - xouttmp(n) = xsum / float(nlevsin) -c print *,'n= ',n,' mean= ',xouttmp(n) - enddo -c - return - end -c -c---------------------------------------------------------------------- -c -c---------------------------------------------------------------------- - subroutine output_data (lout,kf,kpds,kgds,holdgfld,xouttmp - & ,valid_pt,xoutlev,nlevsout,gribver,ifcsthour,iodret) -c -c ABSTRACT: This routine writes out the output data on the -c specified output pressure levels. - - USE params - USE grib_mod - - implicit none - - CHARACTER(len=1),pointer,dimension(:) :: cgrib -c CHARACTER(len=1),pointer,allocatable :: cgrib(:) - type(gribfield) :: holdgfld - logical(1) valid_pt(kf),bmap(kf) - integer lout,kf,lugb,lugi,iodret,nlevsout,igoret,ipret,lev - integer gribver,ierr,ipack,lengrib,npoints,newlen,idrsnum - integer numcoord,ica,n,j,ifcsthour - integer :: idrstmpl(200) - integer :: currlen=1000000 - integer :: listsec0(2)=(/0,2/) - integer :: igds(5)=(/0,0,0,0,0/),previgds(5) - integer kpds(200),kgds(200) - integer(4), parameter::idefnum=1 - integer(4) ideflist(idefnum),ibmap - real xouttmp(kf),xoutlev,coordlist -c - iodret=0 - call baopenw (lout,"fort.51",igoret) - print *,'baopenw: igoret= ',igoret - - if (igoret /= 0) then - print *,' ' - print *,'!!! ERROR in sub output_data opening' - print *,'!!! **OUTPUT** grib file. baopenw return codes:' - print *,'!!! grib file 1 return code = igoret = ',igoret - STOP 95 - return - endif - - if (gribver == 2) then - - ! Write data out as a GRIB2 message.... - - allocate(cgrib(currlen),stat=ica) - if (ica /= 0) then - print *,' ' - print *,'ERROR in output_data allocating cgrib' - print *,'ica= ',ica - iodret=95 - return - endif - - - ! Ensure that cgrib array is large enough - - if (holdgfld%ifldnum == 1 ) then ! start new GRIB2 message - npoints=holdgfld%ngrdpts - else - npoints=npoints+holdgfld%ngrdpts - endif - newlen=npoints*4 - if ( newlen.gt.currlen ) then -ccc if (allocated(cgrib)) deallocate(cgrib) - if (associated(cgrib)) deallocate(cgrib) - allocate(cgrib(newlen),stat=ierr) -c call realloc (cgrib,currlen,newlen,ierr) - if (ierr == 0) then - print *,' ' - print *,'re-allocate for large grib msg: ' - print *,' currlen= ',currlen - print *,' newlen= ',newlen - currlen=newlen - else - print *,'ERROR returned from 2nd allocate cgrib = ',ierr - stop 95 - endif - endif - - ! Create new GRIB Message - listsec0(1)=holdgfld%discipline - listsec0(2)=holdgfld%version - - print *,'output, holdgfld%idsectlen= ',holdgfld%idsectlen - do j = 1,holdgfld%idsectlen - print *,' sect1, j= ',j,' holdgfld%idsect(j)= ' - & ,holdgfld%idsect(j) - enddo - - call gribcreate(cgrib,currlen,listsec0,holdgfld%idsect,ierr) - if (ierr.ne.0) then - write(6,*) ' ERROR creating new GRIB2 field (gribcreate)= ' - & ,ierr - stop 95 - endif - - previgds=igds - igds(1)=holdgfld%griddef - igds(2)=holdgfld%ngrdpts - igds(3)=holdgfld%numoct_opt - igds(4)=holdgfld%interp_opt - igds(5)=holdgfld%igdtnum - - if (igds(3) == 0) then - ideflist = 0 - endif - - call addgrid (cgrib,currlen,igds,holdgfld%igdtmpl - & ,holdgfld%igdtlen,ideflist,idefnum,ierr) - - if (ierr.ne.0) then - write(6,*) ' ERROR from addgrid adding GRIB2 grid = ',ierr - stop 95 - endif - - - holdgfld%ipdtmpl(12) = int(xoutlev) * 100 - - ipack = 40 - idrsnum = ipack - idrstmpl = 0 - - idrstmpl(2)= holdgfld%idrtmpl(2) - idrstmpl(3)= holdgfld%idrtmpl(3) - idrstmpl(6)= 0 - idrstmpl(7)= 255 - - numcoord=0 - coordlist=0.0 ! Only needed for hybrid vertical coordinate, - ! not here, so set it to 0.0 - - ! 0 - A bit map applies to this product and is specified in - ! this section - ! 255 - A bit map does not apply to this product - ibmap=255 ! Bitmap indicator (see Code Table 6.0) - - print *,' ' - print *,'output, holdgfld%ipdtlen= ',holdgfld%ipdtlen - do n = 1,holdgfld%ipdtlen - print *,'output, n= ',n,' holdgfld%ipdtmpl= ' - & ,holdgfld%ipdtmpl(n) - enddo - - print *,'output, kf= ',kf - -c if (ifcsthour < 6) then -c do n = 1,kf -cc print *,'output, n= ',n,' xouttmp(n)= ',xouttmp(n) -c write (92,151) n,xouttmp(n) -c 151 format (1x,'n= ',i6,' xouttmp(n)= ',f10.4) -c enddo -c endif - - call addfield (cgrib,currlen,holdgfld%ipdtnum,holdgfld%ipdtmpl - & ,holdgfld%ipdtlen,coordlist - & ,numcoord - & ,idrsnum,idrstmpl,200 - & ,xouttmp,kf,ibmap,bmap,ierr) - - if (ierr /= 0) then - write(6,*) ' ERROR from addfield adding GRIB2 data = ',ierr - stop 95 - endif - -! Finalize GRIB message after all grids -! and fields have been added. It adds the End Section ( "7777" ) - - call gribend(cgrib,currlen,lengrib,ierr) - call wryte(lout,lengrib,cgrib) - - if (ierr == 0) then - print *,' ' - print *,'+++ GRIB2 write successful. ' - print *,' Len of message = currlen= ',currlen - print *,' Len of entire GRIB2 message = lengrib= ',lengrib - else - print *,' ERROR from gribend writing GRIB2 msg = ',ierr - stop 95 - endif - - else - - ! Write data out as a GRIB1 message.... - - kpds(6) = 100 - - do lev = 1,nlevsout - - kpds(7) = int(xoutlev) - - print *,'tave: just before call to putgb, kf= ',kf - - print *,'output, kf= ',kf -c do n = 1,kf -c print *,'output, n= ',n,' xouttmp(n)= ',xouttmp(n) -c enddo - - if (ifcsthour < 6) then - do n = 1,kf -c print *,'output, n= ',n,' xouttmp(n)= ',xouttmp(n) - write (91,161) n,xouttmp(n) - 161 format (1x,'n= ',i6,' xouttmp(n)= ',f10.4) - enddo - endif - - call putgb (lout,kf,kpds,kgds,valid_pt,xouttmp,ipret) - print *,'tave: just after call to putgb, kf= ',kf - if (ipret == 0) then - print *,' ' - print *,'+++ IPRET = 0 after call to putgb' - print *,' ' - else - print *,' ' - print *,'!!!!!! ERROR in tave' - print *,'!!!!!! ERROR: IPRET NE 0 AFTER CALL TO PUTGB !!!' - print *,'!!!!!! Level index= ',lev - print *,'!!!!!! pressure= ',xoutlev - print *,' ' - endif - - write(*,980) kpds(1),kpds(2) - write(*,981) kpds(3),kpds(4) - write(*,982) kpds(5),kpds(6) - write(*,983) kpds(7),kpds(8) - write(*,984) kpds(9),kpds(10) - write(*,985) kpds(11),kpds(12) - write(*,986) kpds(13),kpds(14) - write(*,987) kpds(15),kpds(16) - write(*,988) kpds(17),kpds(18) - write(*,989) kpds(19),kpds(20) - write(*,990) kpds(21),kpds(22) - write(*,991) kpds(23),kpds(24) - write(*,992) kpds(25) - write(*,880) kgds(1),kgds(2) - write(*,881) kgds(3),kgds(4) - write(*,882) kgds(5),kgds(6) - write(*,883) kgds(7),kgds(8) - write(*,884) kgds(9),kgds(10) - write(*,885) kgds(11),kgds(12) - write(*,886) kgds(13),kgds(14) - write(*,887) kgds(15),kgds(16) - write(*,888) kgds(17),kgds(18) - write(*,889) kgds(19),kgds(20) - write(*,890) kgds(21),kgds(22) - - enddo - - 980 format(' kpds(1) = ',i7,' kpds(2) = ',i7) - 981 format(' kpds(3) = ',i7,' kpds(4) = ',i7) - 982 format(' kpds(5) = ',i7,' kpds(6) = ',i7) - 983 format(' kpds(7) = ',i7,' kpds(8) = ',i7) - 984 format(' kpds(9) = ',i7,' kpds(10) = ',i7) - 985 format(' kpds(11) = ',i7,' kpds(12) = ',i7) - 986 format(' kpds(13) = ',i7,' kpds(14) = ',i7) - 987 format(' kpds(15) = ',i7,' kpds(16) = ',i7) - 988 format(' kpds(17) = ',i7,' kpds(18) = ',i7) - 989 format(' kpds(19) = ',i7,' kpds(20) = ',i7) - 990 format(' kpds(21) = ',i7,' kpds(22) = ',i7) - 991 format(' kpds(23) = ',i7,' kpds(24) = ',i7) - 992 format(' kpds(25) = ',i7) - 880 format(' kgds(1) = ',i7,' kgds(2) = ',i7) - 881 format(' kgds(3) = ',i7,' kgds(4) = ',i7) - 882 format(' kgds(5) = ',i7,' kgds(6) = ',i7) - 883 format(' kgds(7) = ',i7,' kgds(8) = ',i7) - 884 format(' kgds(9) = ',i7,' kgds(10) = ',i7) - 885 format(' kgds(11) = ',i7,' kgds(12) = ',i7) - 886 format(' kgds(13) = ',i7,' kgds(14) = ',i7) - 887 format(' kgds(15) = ',i7,' kgds(16) = ',i7) - 888 format(' kgds(17) = ',i7,' kgds(18) = ',i7) - 889 format(' kgds(19) = ',i7,' kgds(20) = ',i7) - 890 format(' kgds(20) = ',i7,' kgds(22) = ',i7) - - endif -c - return - end -c -c----------------------------------------------------------------------- -c -c----------------------------------------------------------------------- - subroutine open_grib_files (lugb,lugi,lout,gribver,iret) - -C ABSTRACT: This subroutine must be called before any attempt is -C made to read from the input GRIB files. The GRIB and index files -C are opened with a call to baopenr. This call to baopenr was not -C needed in the cray version of this program (the files could be -C opened with a simple Cray assign statement), but the GRIB-reading -C utilities on the SP do require calls to this subroutine (it has -C something to do with the GRIB I/O being done in C on the SP, and -C the C I/O package needs an explicit open statement). -C -C INPUT: -C lugb The Fortran unit number for the GRIB data file -C lugi The Fortran unit number for the GRIB index file -C lout The Fortran unit number for the output grib file -c gribver integer (1 or 2) to indicate if using GRIB1 / GRIB2 -C -C OUTPUT: -C iret The return code from this subroutine - - implicit none - - character fnameg*7,fnamei*7,fnameo*7 - integer iret,gribver,lugb,lugi,lout,igoret,iioret,iooret - - iret=0 - fnameg(1:5) = "fort." - fnamei(1:5) = "fort." - fnameo(1:5) = "fort." - write(fnameg(6:7),'(I2)') lugb - write(fnamei(6:7),'(I2)') lugi - write(fnameo(6:7),'(I2)') lout - call baopenr (lugb,fnameg,igoret) - call baopenr (lugi,fnamei,iioret) - call baopenw (lout,fnameo,iooret) - - print *,' ' - print *,'tave baopen: igoret= ',igoret,' iioret= ',iioret - & ,' iooret= ',iooret - - if (igoret /= 0 .or. iioret /= 0 .or. iooret /= 0) then - print *,' ' - print *,'!!! ERROR in tave' - print *,'!!! ERROR in sub open_grib_files opening grib file' - print *,'!!! or grib index file. baopen return codes:' - print *,'!!! grib file return code = igoret = ',igoret - print *,'!!! index file return code = iioret = ',iioret - print *,'!!! output file return code = iooret = ',iooret - iret = 93 - return - endif - - return - end -c -c------------------------------------------------------------------- -c -c------------------------------------------------------------------- - subroutine bitmapchk (n,ld,d,dmin,dmax) -c -c This subroutine checks the bitmap for non-existent data values. -c Since the data from the regional models have been interpolated -c from either a polar stereographic or lambert conformal grid -c onto a lat/lon grid, there will be some gridpoints around the -c edges of this lat/lon grid that have no data; these grid -c points have been bitmapped out by Mark Iredell's interpolater. -c To provide another means of checking for invalid data points -c later in the program, set these bitmapped data values to a -c value of -999.0. The min and max of this array are also -c returned if a user wants to check for reasonable values. -c - logical(1) ld - dimension ld(n),d(n) -c - dmin=1.E15 - dmax=-1.E15 -c - do i=1,n - if (ld(i)) then - dmin=min(dmin,d(i)) - dmax=max(dmax,d(i)) - else - d(i) = -999.0 - endif - enddo -c - return - end diff --git a/sorc/tocsbufr.fd/CMakeLists.txt b/sorc/tocsbufr.fd/CMakeLists.txt deleted file mode 100644 index ed1dc8e6ca..0000000000 --- a/sorc/tocsbufr.fd/CMakeLists.txt +++ /dev/null @@ -1,22 +0,0 @@ -list(APPEND fortran_src - tocsbufr.f -) - -if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -convert big_endian -fp-model source") -elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fconvert=big-endian") -endif() - -set(exe_name tocsbufr.x) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - bacio::bacio_4 - sigio::sigio - sp::sp_4 - w3emc::w3emc_4 - w3nco::w3nco_4 - bufr::bufr_4_DA) - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/tocsbufr.fd/makefile_module b/sorc/tocsbufr.fd/makefile_module deleted file mode 100755 index 06f5ba7092..0000000000 --- a/sorc/tocsbufr.fd/makefile_module +++ /dev/null @@ -1,82 +0,0 @@ -SHELL=/bin/sh -# -# This makefile was produced by /usr/bin/fmgen at 11:21:07 AM on 10/28/94 -# If it is invoked by the command line -# make -f makefile -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable named a.out. -# -# If it is invoked by the command line -# make -f makefile a.out.prof -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable which profiles -# named a.out.prof. -# -# To remove all the objects but leave the executables use the command line -# make -f makefile clean -# -# To remove everything but the source files use the command line -# make -f makefile clobber -# -# To remove the source files created by /usr/bin/fmgen and this makefile -# use the command line -# make -f makefile void -# -# The parameters SRCS and OBJS should not need to be changed. If, however, -# you need to add a new module add the name of the source module to the -# SRCS parameter and add the name of the resulting object file to the OBJS -# parameter. The new modules are not limited to fortran, but may be C, YACC, -# LEX, or CAL. An explicit rule will need to be added for PASCAL modules. -# -SRCS= tocsbufr.f - -OBJS= tocsbufr.o - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# PROFLIB Library needed for profiling -# -FC = $(myFC) -LDFLAGS = $(myFCFLAGS) -LIBS = $(W3EMC_LIB4) \ - $(W3NCO_LIB4) \ - $(BUFR_LIB4) \ - $(BACIO_LIB4) \ - $(SP_LIB4) \ - $(SIGIO_LIB) -CMD = ../../exec/tocsbufr -PROFLIB = -lprof - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# WARNING: SIMULTANEOUSLY PROFILING AND FLOWTRACING IS NOT RECOMMENDED -FFLAGS = $(FFLAGSM) -#FFLAGS = -F -#FFLAGS = -Wf"-ez" - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(LIBS) - -# Make the profiled version of the command and call it a.out.prof -# -$(CMD).prof: $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(PROFLIB) $(LIBS) - -clean: - -rm -f $(OBJS) - -clobber: clean - -rm -f $(CMD) $(CMD).prof - -void: clobber - -rm -f $(SRCS) makefile diff --git a/sorc/tocsbufr.fd/tocsbufr.f b/sorc/tocsbufr.fd/tocsbufr.f deleted file mode 100755 index 0f1914cd1a..0000000000 --- a/sorc/tocsbufr.fd/tocsbufr.f +++ /dev/null @@ -1,272 +0,0 @@ - PROGRAM TOCSBUFR -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C . . . . -C MAIN PROGRAM: TOCSBUFR -C PRGMMR: GILBERT ORG: NP11 DATE: 2004-02-23 -C -C ABSTRACT: Reads each BUFR message from a standard fortran blocked (f77) -C file and adds a TOC -C Flag Field separator block and WMO Header in front of each BUFR -C field, and writes them out to a new file. The output file -C is in the format required for TOC's FTP Input Service, which -C can be used to disseminate the BUFR messages. -C This service is described at http://weather.gov/tg/ftpingest.html. -C -C TOCSBUFR contains two options that are selected using -C a namelist on unit 5 ( see INPUT FILES below ): -C 1) The specified WMO HEADER can be added to each BUFR -C message in the file OR once at the beginning of the -C file. -C 2) The BUFR messages can be used "as is", or if they -C in NCEP format they can be "standardized" for external -C users. -C -C PROGRAM HISTORY LOG: -C 2001-03-01 Gilbert modified from WMOGRIB -C 2004-02-23 Gilbert modified from WMOBUFR to write out BUFR -C messages in the NTC/FTP Input Service format -C instead of the old STATFILE format. -C 2005-04-07 Gilbert This version was created from original program -C TOCBUFR. A new more thorough "standardizing" -C routine is being used to create WMO standard -C BUFR messages for AWIPS. -C 2009-06-16 J. Ator The program was modified in response to BUFRLIB -C changes, including a change to the WRITSA call -C sequence. Also added a call to MAXOUT to stop -C BUFR messages larger than 10k bytes from being -C truncated when standardizing. The program can -C now standardize BUFR messages as large as the -C MAXOUT limit without any loss of data. -C 2012-12-06 J. Ator modified for WCOSS -C -C USAGE: -C INPUT FILES: -C 5 - STANDARD INPUT - NAMELIST /INPUT/. -C BULHED = "TTAAII" part of WMO Header (CHAR*6) -C KWBX = "CCCC" orig center part of WMO Header (CHAR*4) -C NCEP2STD = .true. - will convert NCEP format -C BUFR messages to standard WMO -C format. -C = .false. - No conversion done to BUFR -C messages. -C SEPARATE = .true. - Add Flag Field Separator and WMO -C Header to each BUFR message in -C file. -C = .false. - Add Flag Field Separator and WMO -C Header once at beginning of -C output file. -C MAXFILESIZE = Max size of output file in bytes. -C Used only when SEPARATE = .false. -C 11 - INPUT BUFR FILE -C -C OUTPUT FILES: (INCLUDING SCRATCH FILES) -C 6 - STANDARD FORTRAN PRINT FILE -C 51 - AWIPS BUFR FILE WITH WMO HEADERS ADDED -C -C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES) -C UNIQUE: - makwmo mkfldsep -C LIBRARY: -C W3LIB - W3TAGB W3UTCDAT -C W3TAGE -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN -C 19 - ERROR READING COMMAND LINE ARGS FOR WMOHEADER -C 20 - Error opening output BUFR transmission file -C 30 - NO BUFR MESSSAGES FOUND -C -C REMARKS: This utility was written for the ETA BUFR sounding -C collectives, and assumes all BUFR messages in the input -C file require the same WMO Header. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: WCOSS -C -C$$$ -C - PARAMETER (MXSIZE=500000,MXSIZED4=MXSIZE/4) - INTEGER,PARAMETER :: INBUFR=11,OUTBUFR=51,TMPBUFR=91,iopt=2 -C - INTEGER,dimension(8):: ITIME=(/0,0,0,-500,0,0,0,0/) - INTEGER,dimension(MXSIZED4):: MBAY - INTEGER NBUL - INTEGER iday,hour - INTEGER :: MAXFILESIZE=1000000 -C - CHARACTER * 80 fileo - CHARACTER * 11 envvar - CHARACTER * 8 SUBSET - CHARACTER * 6 :: BULHED="CHEK12" - CHARACTER * 1 BUFR(MXSIZE) - CHARACTER * 4 :: ctemp,KWBX="OUTT" - CHARACTER * 1 CSEP(80) - integer,parameter :: lenhead=21 - CHARACTER * 1 WMOHDR(lenhead) - character*1,allocatable :: filebuf(:) - LOGICAL :: NCEP2STD=.false.,SEPARATE=.true. -C - EQUIVALENCE (BUFR(1), MBAY(1)) -C - NAMELIST /INPUT/ BULHED,KWBX,NCEP2STD,SEPARATE,MAXFILESIZE -C - CALL W3TAGB('TOCSBUFR',2012,0341,0083,'NP12') -C -C Read input values from namelist -C - READ(5,INPUT) - - PRINT * - PRINT *,'- Adding WMO Header: ',BULHED,' ',KWBX - IF (NCEP2STD) then - print *,'- Convert BUFR messages from NCEP format to standard', - & ' BUFR Format.' - else - print *,'- No conversion of BUFR messages will be done.' - endif - IF (SEPARATE) then - print *,'- Add Flag Field Separator and WMO Header to each ', - & 'BUFR message in file.' - else - print *,'- Add Flag Field Separator and WMO Header once at', - & ' beginning of file.' - allocate(filebuf(MAXFILESIZE)) - endif - PRINT * - -C -C Read output BUFR file name from FORT -C environment variable, and open file. -C - envvar='FORT ' - write(envvar(5:6),fmt='(I2)') outbufr - call get_environment_variable(envvar,fileo) - call baopenw(outbufr,fileo,iret1) - if ( iret1 .ne. 0 ) then - write(6,fmt='(" Error opening BUFR file: ",A80)') fileo - write(6,fmt='(" baopenw error = ",I5)') iret1 - stop 20 - endif -C -C Open input NCEP formatted BUFR file, if NCEP2STD = .true. -C - if (NCEP2STD) then - call OPENBF(INBUFR,'IN',INBUFR) - CALL MAXOUT(0) - call OPENBF(TMPBUFR,'NUL',INBUFR) - CALL STDMSG('Y') - endif - -C -C Get system date and time -C - call w3utcdat(itime) -C -C loop through input control records. -C - NBUL = 0 - nrec = 0 - itot = 0 - foreachbufrmessage: do - - if (NCEP2STD) then - if ( IREADMG (INBUFR,SUBSET,JDATE) .ne. 0 ) exit - if ( NMSUB(INBUFR) .gt. 0 ) then - nrec = nrec + 1 - CALL OPENMG (TMPBUFR,SUBSET,JDATE) - DO WHILE ( ICOPYSB(INBUFR,TMPBUFR) .eq. 0 ) - CONTINUE - END DO - CALL WRITSA( (-1)*TMPBUFR, MXSIZED4, MBAY, LMBAY) - else - cycle - endif - else - read(INBUFR,iostat=ios) BUFR -C print *,'Error reading message from input BUFR file.', -C & ' iostat = ',ios - if ( ios .le. 0 ) then - exit - endif - nrec = nrec + 1 - endif -C -C Extract BUFR edition number - ied = iupbs01(MBAY,'BEN') -C Calculate length of BUFR message - if (ied.le.1) then - call getlens(MBAY,5,len0,len1,len2,len3,len4,len5) - ILEN = len0+len1+len2+len3+len4+len5 - else - ILEN = iupbs01(MBAY,'LENM') - endif -C Check ending 7777 to see if we have a complete BUFR message - ctemp=BUFR(ILEN-3)//BUFR(ILEN-2)//BUFR(ILEN-1)//BUFR(ILEN) - if ( ctemp.ne.'7777') then - print *,' INVALID BUFR MESSAGE FOUND...SKIPPING ' - exit - endif -C -C MAKE WMO HEADER -C - iday=ITIME(3) - hour=ITIME(5) - CALL MAKWMO (BULHED,iday,hour,KWBX,WMOHDR) -C - NBUL = NBUL + 1 -C - IF (SEPARATE) THEN -C -C ADD Flag Field Separator AND WMO HEADERS -C TO BUFR MESSAGE. WRITE BUFR MESSAGE IN FILE -C - call mkfldsep(csep,iopt,insize,ilen+lenhead,lenout) - call wryte(outbufr,lenout,csep) - call wryte(outbufr,lenhead,WMOHDR) - call wryte(outbufr,ilen,bufr) - ELSE -C -C APPEND NEW BUFR MESSAGE TO filebuf ARRAY -C - if ((itot+ilen).lt.(MAXFILESIZE-101)) then - filebuf(itot+1:itot+ilen)=BUFR(1:ilen) - itot=itot+ilen - else - print *,' Internal Buffer of ',MAXFILESIZE,' bytes is ', - & 'full. Increase MAXFILESIZE in NAMELIST.' - exit - endif - ENDIF -C - enddo foreachbufrmessage -C - IF (.not.SEPARATE) THEN -C -C ADD Flag Field Separator AND WMO HEADERS -C TO BUFR MESSAGE. WRITE BUFR MESSAGE IN FILE -C - call mkfldsep(csep,iopt,insize,itot+lenhead,lenout) - call wryte(outbufr,lenout,csep) - call wryte(outbufr,lenhead,WMOHDR) - call wryte(outbufr,itot,filebuf) - deallocate(filebuf) - ENDIF -C -C* CLOSING SECTION -C - IF (NBUL .EQ. 0 ) THEN - WRITE (6,FMT='('' SOMETHING WRONG WITH INPUT BUFR FILE...'', - & ''NOTHING WAS PROCESSED'')') - CALL W3TAGE('TOCSBUFR') - call errexit(30) - ELSE - CALL BACLOSE (OUTBUFR,iret) - WRITE (6,FMT='(//,'' ******** RECAP OF THIS EXECUTION '', - & ''********'',/,5X,''READ '',I6,'' BUFR MESSAGES'', - & /,5X,''WROTE '',I6,'' BULLETINS OUT FOR TRANSMISSION'', - & //)') NREC, NBUL - ENDIF -C - CALL W3TAGE('TOCSBUFR') - STOP - END diff --git a/sorc/vint.fd/CMakeLists.txt b/sorc/vint.fd/CMakeLists.txt deleted file mode 100644 index 21bf6901c8..0000000000 --- a/sorc/vint.fd/CMakeLists.txt +++ /dev/null @@ -1,19 +0,0 @@ -list(APPEND fortran_src - vint.f -) - -if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -i4 -r8") -elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8") -endif() - -set(exe_name vint.x) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - bacio::bacio_4 - w3nco::w3nco_d - g2::g2_d) - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/sorc/vint.fd/makefile b/sorc/vint.fd/makefile deleted file mode 100755 index 06647d1fc6..0000000000 --- a/sorc/vint.fd/makefile +++ /dev/null @@ -1,27 +0,0 @@ -SHELL= /bin/sh -ISIZE = 4 -RSIZE = 8 -COMP= ifort -##INC = /contrib/nceplibs/nwprod/lib/incmod/g2_d -##LIBS= -L/contrib/nceplibs/nwprod/lib -lw3emc_d -lw3nco_d -lg2_d -lbacio_4 -ljasper -lpng -lz -LDFLAGS= -# FFLAGS= -O3 -I $(INC) -i$(ISIZE) -r$(RSIZE) -# DEBUG= -check all -debug all -traceback -FFLAGS= -O2 -g -traceback -I $(INC) -i$(ISIZE) -r$(RSIZE) - -vint: vint.f - @echo " " - @echo " Compiling the interpolation program....." - $(COMP) $(FFLAGS) $(LDFLAGS) vint.f $(LIBS) -o vint.x - @echo " " - -.PHONY: clean - -CMD = vint.x - -clean: - -rm -f *.o *.mod - -install: - mv $(CMD) ../../exec/$(CMD) - diff --git a/sorc/vint.fd/vint.f b/sorc/vint.fd/vint.f deleted file mode 100755 index e4d6db807c..0000000000 --- a/sorc/vint.fd/vint.f +++ /dev/null @@ -1,1239 +0,0 @@ - program vint -c -c ABSTRACT: This program interpolates from various pressure levels -c onto regularly-spaced, 50-mb vertical levels. The intent is that -c we can use data with relatively coarse vertical resolution to -c get data on the necessary 50-mb intervals that we need for Bob -c Hart's cyclone phase space. For each model, we will need to read -c in a control file that contains the levels that we are -c interpolating from. -c -c Written by Tim Marchok - - USE params - USE grib_mod - - implicit none - - type(gribfield) :: holdgfld - integer, parameter :: lugb=11,lulv=16,lugi=31,lout=51,maxlev=200 - integer kpds(200),kgds(200) - integer nlevsin,iriret,iogret,kf,iggret,igdret,iidret,ixo,k,n - integer iha,iho,iva,irfa,iodret,ifcsthour,iia,iparm,nlevsout - integer gribver,g2_jpdtn - integer ilevs(maxlev) - real, allocatable :: xinpdat(:,:),xoutdat(:,:),xoutlevs_p(:) - logical(1), allocatable :: valid_pt(:),readflag(:) - - namelist/timein/ifcsthour,iparm,gribver,g2_jpdtn -c - read (5,NML=timein,END=201) - 201 continue - print *,' ' - print *,'*----------------------------------------------------*' - print *,' ' - print *,' +++ Top of vint +++' - print *,' ' - print *,'After namelist read, input forecast hour = ',ifcsthour - print *,' input grib parm = ',iparm - print *,' GRIB version= ',gribver - print *,' GRIB2 JPDTN= g2_jpdtn= ' - & ,g2_jpdtn - - if (iparm == 7 .or. iparm == 156) then - nlevsout = 13 ! dealing with height - else - nlevsout = 5 ! dealing with temperature - endif - - allocate (xoutlevs_p(nlevsout),stat=ixo) - if (ixo /= 0) then - print *,' ' - print *,'!!! ERROR in vint allocating the xoutlevs_p array.' - print *,'!!! ixo= ',ixo - print *,' ' - goto 899 - endif - - do k = 1,nlevsout - xoutlevs_p(k) = 300. + float((k-1)*50) - enddo - - ilevs = -999 - call read_input_levels (lulv,maxlev,nlevsin,ilevs,iriret) - - if (iriret /= 0) then - print *,' ' - print *,'!!! ERROR in vint. ' - print *,'!!! RETURN CODE FROM read_input_levels /= 0' - print *,'!!! RETURN CODE = iriret = ',iriret - print *,'!!! EXITING....' - print *,' ' - goto 899 - endif - - call open_grib_files (lugb,lugi,lout,gribver,iogret) - - if (iogret /= 0) then - print '(/,a45,i4,/)','!!! ERROR: in vint open_grib_files, rc= ' - & ,iogret - goto 899 - endif - - call getgridinfo (lugb,lugi,kf,kpds,kgds,holdgfld,ifcsthour,iparm - & ,gribver,g2_jpdtn,iggret) - - allocate (xinpdat(kf,nlevsin),stat=iha) - allocate (xoutdat(kf,nlevsout),stat=iho) - allocate (valid_pt(kf),stat=iva) - allocate (readflag(nlevsin),stat=irfa) - if (iha /= 0 .or. iho /= 0 .or. iva /= 0 .or. irfa /= 0) then - print *,' ' - print *,'!!! ERROR in vint.' - print *,'!!! ERROR allocating the xinpdat, readflag, or the' - print *,'!!! valid_pt array, iha= ',iha,' iva= ',iva - print *,'!!! irfa= ',irfa,' iho= ',iho - print *,' ' - goto 899 - endif - - print *,'hold check, holdgfld%ipdtlen = ',holdgfld%ipdtlen - do n = 1,holdgfld%ipdtlen - print *,'hold check, n= ',n,' holdgfld%ipdtmpl= ' - & ,holdgfld%ipdtmpl(n) - enddo - - call getdata (lugb,lugi,kf,valid_pt,nlevsin,ilevs,maxlev - & ,readflag,xinpdat,ifcsthour,iparm,gribver,g2_jpdtn - & ,igdret) - - call interp_data (kf,valid_pt,nlevsin,ilevs,maxlev,readflag - & ,xinpdat,xoutdat,xoutlevs_p,nlevsout,iidret) - - call output_data (lout,kf,kpds,kgds,holdgfld,xoutdat,valid_pt - & ,xoutlevs_p,nlevsout,gribver,iodret) - - deallocate (xinpdat) - deallocate (xoutdat) - deallocate (valid_pt) - deallocate (readflag) - deallocate (xoutlevs_p) - - 899 continue -c - stop - end -c -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine read_input_levels (lulv,maxlev,nlevsin,ilevs,iriret) -c -c ABSTRACT: This subroutine reads in a text file that contains -c the number of input pressure levels for a given model. The -c format of the file goes like this, from upper levels to -c lower, for example: -c -c 1 200 -c 2 400 -c 3 500 -c 4 700 -c 5 850 -c 6 925 -c 7 1000 -c -c - implicit none - - integer lulv,nlevsin,maxlev,iriret,inplev,ict,lvix - integer ilevs(maxlev) -c - iriret=0 - ict = 0 - do while (.true.) - - print *,'Top of while loop in vint read_input_levels' - - read (lulv,85,end=130) lvix,inplev - - if (inplev > 0 .and. inplev <= 1000) then - ict = ict + 1 - ilevs(ict) = inplev - else - print *,' ' - print *,'!!! ERROR: Input level not between 0 and 1000' - print *,'!!! in vint. inplev= ',inplev - print *,'!!! STOPPING EXECUTION' - STOP 91 - endif - - print *,'vint readloop, ict= ',ict,' inplev= ',inplev - - enddo - - 85 format (i4,1x,i4) - 130 continue - - nlevsin = ict - - print *,' ' - print *,'Total number of vint levels read in = ',nlevsin -c - return - end - -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine getgridinfo (lugb,lugi,kf,kpds,kgds,holdgfld,ifcsthour - & ,iparm,gribver,g2_jpdtn,iggret) -c -c ABSTRACT: The purpose of this subroutine is just to get the max -c values of i and j and the dx and dy grid spacing intervals for the -c grid to be used in the rest of the program. So just read the -c grib file to get the lon and lat data. Also, get the info for -c the data grid's boundaries. This boundary information will be -c used later in the tracking algorithm, and is accessed via Module -c grid_bounds. -c -C INPUT: -C lugb The Fortran unit number for the GRIB data file -C lugi The Fortran unit number for the GRIB index file -c ifcsthour input forecast hour to search for -c iparm input grib parm to search for -c gribver integer (1 or 2) to indicate if using GRIB1 / GRIB2 -c g2_jpdtn If GRIB2 data being read, this is the value for JPDTN -c that is input to getgb2. -C -C OUTPUT: -c kf Number of gridpoints on the grid -c kpds pds array for a GRIB1 record -c kgds gds array for a GRIB1 record -c holdgfld info for a GRIB2 record -c -C iggret The return code from this subroutine -c - USE params - USE grib_mod - - implicit none -c - type(gribfield) :: gfld,prevfld,holdgfld - integer,dimension(200) :: jids,jpdt,jgdt - logical(1), allocatable :: lb(:) - integer, parameter :: jf=4000000 - integer jpds(200),jgds(200) - integer kpds(200),kgds(200) - integer :: listsec1(13) - integer ila,ifa,iret,ifcsthour,imax,jmax,jskp,jdisc - integer lugb,lugi,kf,j,k,iggret,iparm,gribver,g2_jpdtn - integer jpdtn,jgdtn,npoints,icount,ipack,krec - integer :: listsec0(2)=(/0,2/) - integer :: igds(5)=(/0,0,0,0,0/),previgds(5) - integer :: idrstmpl(200) - integer :: currlen=1000000 - logical :: unpack=.true. - logical :: open_grb=.false. - real, allocatable :: f(:) - real dx,dy -c - iggret = 0 - - allocate (lb(jf),stat=ila) - allocate (f(jf),stat=ifa) - if (ila /= 0 .or. ifa /= 0) then - print *,' ' - print *,'!!! ERROR in vint.' - print *,'!!! ERROR in getgridinfo allocating either lb or f' - print *,'!!! ila = ',ila,' ifa= ',ifa - iggret = 97 - return - endif - - if (gribver == 2) then - - ! Search for a record from a GRIB2 file - - ! - ! --- Initialize Variables --- - ! - - gfld%idsect => NULL() - gfld%local => NULL() - gfld%list_opt => NULL() - gfld%igdtmpl => NULL() - gfld%ipdtmpl => NULL() - gfld%coord_list => NULL() - gfld%idrtmpl => NULL() - gfld%bmap => NULL() - gfld%fld => NULL() - - jdisc=0 ! meteorological products - jids=-9999 - jpdtn=g2_jpdtn ! 0 = analysis or forecast; 1 = ens fcst - jgdtn=0 ! lat/lon grid - jgdt=-9999 - jpdt=-9999 - - npoints=0 - icount=0 - jskp=0 - -c Search for Temperature or GP Height by production template.... - - JPDT(1:15)=(/-9999,-9999,-9999,-9999,-9999,-9999,-9999,-9999 - & ,-9999,-9999,-9999,-9999,-9999,-9999,-9999/) - - if (iparm == 7) then ! GP Height - jpdt(1) = 3 ! Param category from Table 4.1 - jpdt(2) = 5 ! Param number from Table 4.2-0-3 - elseif (iparm == 11) then ! Temperature - jpdt(1) = 0 ! Param category from Table 4.1 - jpdt(2) = 0 ! Param category from Table 4.2 - endif - - jpdt(9) = ifcsthour - - call getgb2(lugb,lugi,jskp,jdisc,jids,jpdtn,jpdt,jgdtn,jgdt - & ,unpack,krec,gfld,iret) - if ( iret.ne.0) then - print *,' ' - print *,' ERROR: getgb2 error in getgridinfo = ',iret - endif - -c Determine packing information from GRIB2 file -c The default packing is 40 JPEG 2000 - - ipack = 40 - - print *,' gfld%idrtnum = ', gfld%idrtnum - - ! Set DRT info ( packing info ) - if ( gfld%idrtnum.eq.0 ) then ! Simple packing - ipack = 0 - elseif ( gfld%idrtnum.eq.2 ) then ! Complex packing - ipack = 2 - elseif ( gfld%idrtnum.eq.3 ) then ! Complex & spatial packing - ipack = 31 - elseif ( gfld%idrtnum.eq.40.or.gfld%idrtnum.eq.15 ) then - ! JPEG 2000 packing - ipack = 40 - elseif ( gfld%idrtnum.eq.41 ) then ! PNG packing - ipack = 41 - endif - - print *,'After check of idrtnum, ipack= ',ipack - - print *,'Number of gridpts= gfld%ngrdpts= ',gfld%ngrdpts - print *,'Number of elements= gfld%igdtlen= ',gfld%igdtlen - print *,'PDT num= gfld%ipdtnum= ',gfld%ipdtnum - print *,'GDT num= gfld%igdtnum= ',gfld%igdtnum - - imax = gfld%igdtmpl(8) - print *,'at A' - jmax = gfld%igdtmpl(9) - print *,'at B' - dx = float(gfld%igdtmpl(17))/1.e6 - print *,'at C' - dy = float(gfld%igdtmpl(17))/1.e6 - print *,'at D' - kf = gfld%ngrdpts - print *,'at E' - - holdgfld = gfld - - else - - ! Search for a record from a GRIB1 file - - jpds = -1 - jgds = -1 - - j=0 - - jpds(5) = iparm ! Get a record for the input parm selected - jpds(6) = 100 ! Get a record on a standard pressure level - jpds(14) = ifcsthour - - call getgb(lugb,lugi,jf,j,jpds,jgds, - & kf,k,kpds,kgds,lb,f,iret) - - if (iret.ne.0) then - print *,' ' - print *,'!!! ERROR in vint getgridinfo calling getgb' - print *,'!!! Return code from getgb = iret = ',iret - iggret = iret - return - else - iggret=0 - imax = kgds(2) - jmax = kgds(3) - dx = float(kgds(9))/1000. - dy = float(kgds(10))/1000. - endif - - endif - - print *,' ' - print *,'In vint getgridinfo, grid dimensions follow:' - print *,'imax= ',imax,' jmax= ',jmax - print *,' dx= ',dx,' dy= ',dy - print *,'number of gridpoints = ',kf - - deallocate (lb); deallocate(f) - - return - end - -c--------------------------------------------------------------------- -c -c--------------------------------------------------------------------- - subroutine getdata (lugb,lugi,kf,valid_pt,nlevsin,ilevs,maxlev - & ,readflag,xinpdat,ifcsthour,iparm,gribver,g2_jpdtn - & ,igdret) -c -c ABSTRACT: This subroutine reads the input GRIB file for the -c tracked parameters. - - USE params - USE grib_mod - - implicit none -c - type(gribfield) :: gfld,prevfld - CHARACTER(len=8) :: pabbrev - integer,dimension(200) :: jids,jpdt,jgdt - logical(1) valid_pt(kf),lb(kf),readflag(nlevsin) - integer, parameter :: jf=4000000 - integer ilevs(maxlev) - integer jpds(200),jgds(200),kpds(200),kgds(200) - integer lugb,lugi,kf,nlevsin,maxlev,igdret,jskp,jdisc - integer i,j,k,ict,np,lev,ifcsthour,iret,iparm,gribver,g2_jpdtn - integer jpdtn,jgdtn,npoints,icount,ipack,krec - integer pdt_4p0_vert_level,pdt_4p0_vtime,mm - integer :: listsec0(2)=(/0,2/) - integer :: listsec1(13) - integer :: igds(5)=(/0,0,0,0,0/),previgds(5) - integer :: idrstmpl(200) - integer :: currlen=1000000 - logical :: unpack=.true. - logical :: open_grb=.false. - real f(kf),xinpdat(kf,nlevsin),xtemp(kf) - real dmin,dmax,firstval,lastval -c - igdret=0 - ict = 0 - - level_loop: do lev = 1,nlevsin - - print *,' ' - print *,'In vint getdata read loop, lev= ',lev,' level= ' - & ,ilevs(lev) - - if (gribver == 2) then - - ! - ! --- Initialize Variables --- - ! - - gfld%idsect => NULL() - gfld%local => NULL() - gfld%list_opt => NULL() - gfld%igdtmpl => NULL() - gfld%ipdtmpl => NULL() - gfld%coord_list => NULL() - gfld%idrtmpl => NULL() - gfld%bmap => NULL() - gfld%fld => NULL() - - jdisc=0 ! meteorological products - jids=-9999 - jpdtn=g2_jpdtn ! 0 = analysis or forecast; 1 = ens fcst - jgdtn=0 ! lat/lon grid - jgdt=-9999 - jpdt=-9999 - - npoints=0 - icount=0 - jskp=0 - -c Search for input parameter by production template 4.0. This -c vint program is used primarily for temperature, but still we -c will leave that as a variable and not-hard wire it in case we -c choose to average something else in the future. - - ! We are looking for Temperature or GP Height here. This - ! block of code, or even the smaller subset block of code that - ! contains the JPDT(1) and JPDT(2) assignments, can of course - ! be modified if this program is to be used for interpolating - ! other variables.... - - ! Set defaults for JPDT, then override in array - ! assignments below... - - JPDT(1:15)=(/-9999,-9999,-9999,-9999,-9999,-9999,-9999,-9999 - & ,-9999,-9999,-9999,-9999,-9999,-9999,-9999/) - - print *,' ' - print *,'In getdata vint, iparm= ',iparm - - if (iparm == 7) then ! GP Height - jpdt(1) = 3 ! Param category from Table 4.1 - jpdt(2) = 5 ! Param number from Table 4.2-0-3 - elseif (iparm == 11) then ! Temperature - jpdt(1) = 0 ! Param category from Table 4.1 - jpdt(2) = 0 ! Param category from Table 4.2 - endif - - JPDT(9) = ifcsthour - JPDT(10) = 100 ! Isobaric surface requested (Table 4.5) - JPDT(12) = ilevs(lev) * 100 ! value of specific level - - print *,'before getgb2 call, value of unpack = ',unpack - - do mm = 1,15 - print *,'VINT getdata mm= ',mm,' JPDT(mm)= ',JPDT(mm) - enddo - - call getgb2(lugb,lugi,jskp,jdisc,jids,jpdtn,jpdt,jgdtn,jgdt - & ,unpack,krec,gfld,iret) - - print *,'iret from getgb2 in getdata = ',iret - - print *,'after getgb2 call, value of unpacked = ' - & ,gfld%unpacked - - print *,'after getgb2 call, gfld%ndpts = ',gfld%ndpts - print *,'after getgb2 call, gfld%ibmap = ',gfld%ibmap - - if ( iret == 0) then - -c Determine packing information from GRIB2 file -c The default packing is 40 JPEG 2000 - - ipack = 40 - - print *,' gfld%idrtnum = ', gfld%idrtnum - - ! Set DRT info ( packing info ) - if ( gfld%idrtnum.eq.0 ) then ! Simple packing - ipack = 0 - elseif ( gfld%idrtnum.eq.2 ) then ! Complex packing - ipack = 2 - elseif ( gfld%idrtnum.eq.3 ) then ! Complex & spatial - & ! packing - ipack = 31 - elseif ( gfld%idrtnum.eq.40.or.gfld%idrtnum.eq.15 ) then - ! JPEG 2000 packing - ipack = 40 - elseif ( gfld%idrtnum.eq.41 ) then ! PNG packing - ipack = 41 - endif - - print *,'After check of idrtnum, ipack= ',ipack - - print *,'Number of gridpts= gfld%ngrdpts= ',gfld%ngrdpts - print *,'Number of elements= gfld%igdtlen= ',gfld%igdtlen - print *,'GDT num= gfld%igdtnum= ',gfld%igdtnum - - kf = gfld%ndpts ! Number of gridpoints returned from read - - do np = 1,kf - xinpdat(np,lev) = gfld%fld(np) - xtemp(np) = gfld%fld(np) - if (gfld%ibmap == 0) then - valid_pt(np) = gfld%bmap(np) - else - valid_pt(np) = .true. - endif - enddo - - readflag(lev) = .TRUE. -c call bitmapchk(kf,gfld%bmap,gfld%fld,dmin,dmax) - call bitmapchk(kf,valid_pt,xtemp,dmin,dmax) - - if (ict == 0) then -c do np = 1,kf -c valid_pt(np) = gfld%bmap(np) -c enddo - ict = ict + 1 - endif - - firstval=gfld%fld(1) - lastval=gfld%fld(kf) - - print *,' ' - print *,' SECTION 0: discipl= ',gfld%discipline - & ,' gribver= ',gfld%version - print *,' ' - print *,' SECTION 1: ' - - do j = 1,gfld%idsectlen - print *,' sect1, j= ',j,' gfld%idsect(j)= ' - & ,gfld%idsect(j) - enddo - - if ( associated(gfld%local).AND.gfld%locallen.gt.0) then - print *,' ' - print *,' SECTION 2: ',gfld%locallen,' bytes' - else - print *,' ' - print *,' SECTION 2 DOES NOT EXIST IN THIS RECORD' - endif - - print *,' ' - print *,' SECTION 3: griddef= ',gfld%griddef - print *,' ngrdpts= ',gfld%ngrdpts - print *,' numoct_opt= ',gfld%numoct_opt - print *,' interp_opt= ',gfld%interp_opt - print *,' igdtnum= ',gfld%igdtnum - print *,' igdtlen= ',gfld%igdtlen - - print *,' ' - print '(a17,i3,a2)',' GRID TEMPLATE 3.',gfld%igdtnum,': ' - do j=1,gfld%igdtlen - print *,' j= ',j,' gfld%igdtmpl(j)= ',gfld%igdtmpl(j) - enddo - - print *,' ' - print *,' PDT num (gfld%ipdtnum) = ',gfld%ipdtnum - print *,' ' - print '(a20,i3,a2)',' PRODUCT TEMPLATE 4.',gfld%ipdtnum,': ' - do j=1,gfld%ipdtlen - print *,' sect 4 j= ',j,' gfld%ipdtmpl(j)= ' - & ,gfld%ipdtmpl(j) - enddo - -c Print out values for data representation type - - print *,' ' - print '(a21,i3,a2)',' DATA REP TEMPLATE 5.',gfld%idrtnum - & ,': ' - do j=1,gfld%idrtlen - print *,' sect 5 j= ',j,' gfld%idrtmpl(j)= ' - & ,gfld%idrtmpl(j) - enddo - -c Get parameter abbrev for record that was retrieved - - pdt_4p0_vtime = gfld%ipdtmpl(9) - pdt_4p0_vert_level = gfld%ipdtmpl(12) - - pabbrev=param_get_abbrev(gfld%discipline,gfld%ipdtmpl(1) - & ,gfld%ipdtmpl(2)) - - print *,' ' - write (6,131) - 131 format (' rec# param level byy bmm bdd bhh ' - & ,'fhr npts firstval lastval minval ' - & ,' maxval') - print '(i5,3x,a8,2x,6i5,2x,i8,4g12.4)' - & ,krec,pabbrev,pdt_4p0_vert_level/100,gfld%idsect(6) - & ,gfld%idsect(7),gfld%idsect(8),gfld%idsect(9) - & ,pdt_4p0_vtime,gfld%ndpts,firstval,lastval,dmin,dmax - - do np = 1,kf - xinpdat(np,lev) = gfld%fld(np) - enddo - - else - - print *,' ' - print *,'!!! ERROR: GRIB2 VINT READ IN GETDATA FAILED FOR ' - & ,'LEVEL LEV= ',LEV - print *,' ' - - readflag(lev) = .FALSE. - - do np = 1,kf - xinpdat(np,lev) = -99999.0 - enddo - - endif - - else - - ! Reading a GRIB1 file.... - - jpds = -1 - jgds = -1 - j=0 - - jpds(5) = iparm ! grib parameter id to read in - jpds(6) = 100 ! level id to indicate a pressure level - jpds(7) = ilevs(lev) ! actual level of the layer - jpds(14) = ifcsthour ! lead time to search for - - call getgb (lugb,lugi,jf,j,jpds,jgds, - & kf,k,kpds,kgds,lb,f,iret) - - print *,' ' - print *,'After vint getgb call, j= ',j,' k= ',k,' level= ' - & ,ilevs(lev),' iret= ',iret - - if (iret == 0) then - - readflag(lev) = .TRUE. - call bitmapchk(kf,lb,f,dmin,dmax) - - if (ict == 0) then - do np = 1,kf - valid_pt(np) = lb(np) - enddo - ict = ict + 1 - endif - - write (6,31) - 31 format (' rec# parm# levt lev byy bmm bdd bhh fhr ' - & ,'npts minval maxval') - print '(i4,2x,8i5,i8,2g12.4)', - & k,(kpds(i),i=5,11),kpds(14),kf,dmin,dmax - - do np = 1,kf - xinpdat(np,lev) = f(np) - enddo - - else - - print *,' ' - print *,'!!! ERROR: VINT READ FAILED FOR LEVEL LEV= ',LEV - print *,' ' - - readflag(lev) = .FALSE. - - do np = 1,kf - xinpdat(np,lev) = -99999.0 - enddo - - endif - - endif - - enddo level_loop -c - return - end -c -c----------------------------------------------------------------------- -c -c----------------------------------------------------------------------- - subroutine interp_data (kf,valid_pt,nlevsin,ilevs,maxlev,readflag - & ,xinpdat,xoutdat,xoutlevs_p,nlevsout,iidret) -c -c ABSTRACT: This routine interpolates data in between available -c pressure levels to get data resolution at the 50-mb -c resolution that we need for the cyclone phase space -c diagnostics. - - implicit none - - logical(1) valid_pt(kf),readflag(nlevsin) - integer ilevs(maxlev) - integer nlevsin,nlevsout,maxlev,kf,kout,kin,k,n,kup,klo - integer iidret - real xinpdat(kf,nlevsin),xoutdat(kf,nlevsout) - real xoutlevs_p(nlevsout),xoutlevs_lnp(nlevsout) - real xinlevs_p(nlevsin),xinlevs_lnp(nlevsin) - real pdiff,pdiffmin,xu,xo,xl,yu,yl -c - iidret=0 - print *,' ' - print *,'*----------------------------------------------*' - print *,' Listing of standard output levels follows....' - print *,'*----------------------------------------------*' - print *,' ' - - do k = 1,nlevsout - xoutlevs_lnp(k) = log(xoutlevs_p(k)) - write (6,81) k,xoutlevs_p(k),xoutlevs_lnp(k) - enddo - 81 format (1x,'k= ',i3,' p= ',f6.1,' ln(p)= ',f9.6) - - do k = 1,nlevsin - xinlevs_p(k) = float(ilevs(k)) - xinlevs_lnp(k) = log(xinlevs_p(k)) - enddo - -c ----------------------------------------------------------------- -c We want to loop through for all the *output* levels that we need. -c We may have some input levels that match perfectly, often at -c least the standard levels like 500, 700, 850. For these levels, -c just take the data directly from the input file. For other -c output levels that fall between the input levels, we need to -c find the nearest upper and lower levels. - - output_loop: do kout = 1,nlevsout - - print *,' ' - print *,'+------------------------------------------------+' - print *,'Top of vint output_loop, kout= ',kout,' pressure= ' - & ,xoutlevs_p(kout) - - ! Loop through all of the input levels and find the level - ! that is closest to the output level from the *upper* side. - ! And again, in this upper loop, if we hit a level that - ! exactly matches a needed output level, just copy that data - ! and then cycle back to the top of output_loop. - - kup = -999 - klo = -999 - - pdiffmin = 9999.0 - - inp_loop_up: do kin = 1,nlevsin - if (xinlevs_p(kin) == xoutlevs_p(kout)) then - print *,' ' - print *,'+++ Exact level found. kout= ',kout - print *,'+++ level= ',xoutlevs_p(kout) - print *,'+++ Data copied. No interpolation needed.' - if (readflag(kin)) then - do n = 1,kf - xoutdat(n,kout) = xinpdat(n,kin) - enddo - cycle output_loop - else - print *,' ' - print *,'!!! ERROR: readflag is FALSE in interp_data for' - print *,'!!! level kin= ',kin,', which is a level that ' - print *,'!!! exactly matches a required output level, and' - print *,'!!! the user has identified as being an input ' - print *,'!!! level with valid data for this model. We ' - print *,'!!! will get the data from a different level.' - endif - else - pdiff = xoutlevs_p(kout) - xinlevs_p(kin) - if (pdiff > 0.) then ! We have a level higher than outlev - if (pdiff < pdiffmin) then - pdiffmin = pdiff - kup = kin - endif - endif - endif - enddo inp_loop_up - - pdiffmin = 9999.0 - - inp_loop_lo: do kin = 1,nlevsin - pdiff = xinlevs_p(kin) - xoutlevs_p(kout) - if (pdiff > 0.) then ! We have a level lower than outlev - if (pdiff < pdiffmin) then - pdiffmin = pdiff - klo = kin - endif - endif - enddo inp_loop_lo - - if (kup == -999 .or. klo == -999) then - print *,' ' - print *,'!!! ERROR: While interpolating, could not find ' - print *,'!!! either an upper or lower input level to use' - print *,'!!! for interpolating *from*.' - print *,'!!! kup= ',kup,' klo= ',klo - print *,' ' - print *,'!!! STOPPING....' - stop 91 - endif - - if (.not. readflag(kup) .or. .not. readflag(klo)) then - print *,' ' - print *,'!!! ERROR: In interp_data, either the upper or the' - print *,'!!! lower input level closest to the target output' - print *,'!!! level did not have valid data read in.' - print *,'!!! ' - write (6,91) ' upper level k= ',kup,xinlevs_p(kup) - & ,xinlevs_lnp(kup) - write (6,101) xoutlevs_p(kout),xoutlevs_lnp(kout) - write (6,91) ' lower level k= ',klo,xinlevs_p(klo) - & ,xinlevs_lnp(klo) - print *,'!!! readflag upper = ',readflag(kup) - print *,'!!! readflag lower = ',readflag(klo) - print *,'!!! EXITING....' - stop 92 - endif - - print *,' ' - write (6,91) ' upper level k= ',kup,xinlevs_p(kup) - & ,xinlevs_lnp(kup) - write (6,101) xoutlevs_p(kout),xoutlevs_lnp(kout) - write (6,91) ' lower level k= ',klo,xinlevs_p(klo) - & ,xinlevs_lnp(klo) - - 91 format (1x,a17,1x,i3,' pressure= ',f6.1,' ln(p)= ',f9.6) - 101 format (13x,'Target output pressure= ',f6.1,' ln(p)= ',f9.6) - - !-------------------------------------------------------------- - ! Now perform the linear interpolation. Here is the notation - ! used in the interpolation: - ! - ! xu = ln of pressure at upper level - ! xo = ln of pressure at output level - ! xl = ln of pressure at lower level - ! yu = data value at upper level - ! yl = data value at lower level - !-------------------------------------------------------------- - - xu = xinlevs_lnp(kup) - xo = xoutlevs_lnp(kout) - xl = xinlevs_lnp(klo) - - do n = 1,kf - yu = xinpdat(n,kup) - yl = xinpdat(n,klo) - xoutdat(n,kout) = ((yl * (xo - xu)) - (yu * (xo - xl))) - & / (xl - xu) - enddo - - enddo output_loop -c - return - end -c -c---------------------------------------------------------------------- -c -c---------------------------------------------------------------------- - subroutine output_data (lout,kf,kpds,kgds,holdgfld,xoutdat - & ,valid_pt,xoutlevs_p,nlevsout,gribver,iodret) -c -c ABSTRACT: This routine writes out the output data on the -c specified output pressure levels. - - USE params - USE grib_mod - - implicit none - - CHARACTER(len=1),pointer,dimension(:) :: cgrib - type(gribfield) :: holdgfld - logical(1) valid_pt(kf),bmap(kf) - integer lout,kf,lugb,lugi,iodret,nlevsout,igoret,ipret,lev - integer gribver,ierr,ipack,lengrib,npoints,newlen,idrsnum - integer numcoord,ica,n,j - integer :: idrstmpl(200) - integer :: currlen=1000000 - integer :: listsec0(2)=(/0,2/) - integer :: igds(5)=(/0,0,0,0,0/),previgds(5) - integer kpds(200),kgds(200) - integer(4), parameter::idefnum=1 - integer(4) ideflist(idefnum),ibmap - real coordlist - real xoutdat(kf,nlevsout),xoutlevs_p(nlevsout) -c - iodret=0 - call baopenw (lout,"fort.51",igoret) - print *,'baopenw: igoret= ',igoret - - if (igoret /= 0) then - print *,' ' - print *,'!!! ERROR in vint in sub output_data opening' - print *,'!!! **OUTPUT** grib file. baopenw return codes:' - print *,'!!! grib file 1 return code = igoret = ',igoret - STOP 95 - return - endif - - levloop: do lev = 1,nlevsout - - if (gribver == 2) then - - ! Write data out as a GRIB2 message.... - - allocate(cgrib(currlen),stat=ica) - if (ica /= 0) then - print *,' ' - print *,'ERROR in output_data allocating cgrib' - print *,'ica= ',ica - iodret=95 - return - endif - - ! Ensure that cgrib array is large enough - - if (holdgfld%ifldnum == 1 ) then ! start new GRIB2 message - npoints=holdgfld%ngrdpts - else - npoints=npoints+holdgfld%ngrdpts - endif - newlen=npoints*4 - if ( newlen.gt.currlen ) then -ccc if (allocated(cgrib)) deallocate(cgrib) - if (associated(cgrib)) deallocate(cgrib) - allocate(cgrib(newlen),stat=ierr) -c call realloc (cgrib,currlen,newlen,ierr) - if (ierr == 0) then - print *,' ' - print *,'re-allocate for large grib msg: ' - print *,' currlen= ',currlen - print *,' newlen= ',newlen - currlen=newlen - else - print *,'ERROR returned from 2nd allocate cgrib = ',ierr - stop 95 - endif - endif - - ! Create new GRIB Message - listsec0(1)=holdgfld%discipline - listsec0(2)=holdgfld%version - - print *,'output, holdgfld%idsectlen= ',holdgfld%idsectlen - do j = 1,holdgfld%idsectlen - print *,' sect1, j= ',j,' holdgfld%idsect(j)= ' - & ,holdgfld%idsect(j) - enddo - - call gribcreate(cgrib,currlen,listsec0,holdgfld%idsect,ierr) - if (ierr.ne.0) then - write(6,*) ' ERROR creating new GRIB2 field (gribcreate)= ' - & ,ierr - stop 95 - endif - - previgds=igds - igds(1)=holdgfld%griddef - igds(2)=holdgfld%ngrdpts - igds(3)=holdgfld%numoct_opt - igds(4)=holdgfld%interp_opt - igds(5)=holdgfld%igdtnum - - if (igds(3) == 0) then - ideflist = 0 - endif - - call addgrid (cgrib,currlen,igds,holdgfld%igdtmpl - & ,holdgfld%igdtlen,ideflist,idefnum,ierr) - - if (ierr.ne.0) then - write(6,*) ' ERROR from addgrid adding GRIB2 grid = ',ierr - stop 95 - endif - - holdgfld%ipdtmpl(12) = int(xoutlevs_p(lev)) * 100 - - ipack = 40 - idrsnum = ipack - idrstmpl = 0 - - idrstmpl(2)= holdgfld%idrtmpl(2) - idrstmpl(3)= holdgfld%idrtmpl(3) - idrstmpl(6)= 0 - idrstmpl(7)= 255 - - numcoord=0 - coordlist=0.0 ! Only needed for hybrid vertical coordinate, - ! not here, so set it to 0.0 - - ! 0 - A bit map applies to this product and is specified in - ! this section - ! 255 - A bit map does not apply to this product - ibmap=255 ! Bitmap indicator (see Code Table 6.0) - - print *,' ' - print *,'output, holdgfld%ipdtlen= ',holdgfld%ipdtlen - do n = 1,holdgfld%ipdtlen - print *,'output, n= ',n,' holdgfld%ipdtmpl= ' - & ,holdgfld%ipdtmpl(n) - enddo - - print *,'output, kf= ',kf -c do n = 1,kf -c print *,'output, n= ',n,' xoutdat(n)= ',xoutdat(n) -c enddo - - call addfield (cgrib,currlen,holdgfld%ipdtnum,holdgfld%ipdtmpl - & ,holdgfld%ipdtlen,coordlist - & ,numcoord - & ,idrsnum,idrstmpl,200 - & ,xoutdat(1,lev),kf,ibmap,bmap,ierr) - - if (ierr /= 0) then - write(6,*) ' ERROR from addfield adding GRIB2 data = ',ierr - stop 95 - endif - -! Finalize GRIB message after all grids -! and fields have been added. It adds the End Section ( "7777" ) - - call gribend(cgrib,currlen,lengrib,ierr) - call wryte(lout,lengrib,cgrib) - - if (ierr == 0) then - print *,' ' - print *,'+++ GRIB2 write successful. ' - print *,' Len of message = currlen= ',currlen - print *,' Len of entire GRIB2 message = lengrib= ' - & ,lengrib - else - print *,' ERROR from gribend writing GRIB2 msg = ',ierr - stop 95 - endif - - else - - ! Write data out as a GRIB1 message.... - - kpds(7) = int(xoutlevs_p(lev)) - - print *,'In vint, just before call to putgb, kf= ',kf - call putgb (lout,kf,kpds,kgds,valid_pt,xoutdat(1,lev),ipret) - print *,'In vint, just after call to putgb, kf= ',kf - if (ipret == 0) then - print *,' ' - print *,'+++ IPRET = 0 after call to putgb in vint' - print *,' ' - else - print *,' ' - print *,'!!!!!! ERROR in vint.' - print *,'!!!!!! ERROR: IPRET NE 0 AFTER CALL TO PUTGB !!!' - print *,'!!!!!! Level index= ',lev - print *,'!!!!!! pressure= ',xoutlevs_p(lev) - print *,' ' - endif - - write(*,980) kpds(1),kpds(2) - write(*,981) kpds(3),kpds(4) - write(*,982) kpds(5),kpds(6) - write(*,983) kpds(7),kpds(8) - write(*,984) kpds(9),kpds(10) - write(*,985) kpds(11),kpds(12) - write(*,986) kpds(13),kpds(14) - write(*,987) kpds(15),kpds(16) - write(*,988) kpds(17),kpds(18) - write(*,989) kpds(19),kpds(20) - write(*,990) kpds(21),kpds(22) - write(*,991) kpds(23),kpds(24) - write(*,992) kpds(25) - write(*,880) kgds(1),kgds(2) - write(*,881) kgds(3),kgds(4) - write(*,882) kgds(5),kgds(6) - write(*,883) kgds(7),kgds(8) - write(*,884) kgds(9),kgds(10) - write(*,885) kgds(11),kgds(12) - write(*,886) kgds(13),kgds(14) - write(*,887) kgds(15),kgds(16) - write(*,888) kgds(17),kgds(18) - write(*,889) kgds(19),kgds(20) - write(*,890) kgds(21),kgds(22) - - 980 format(' kpds(1) = ',i7,' kpds(2) = ',i7) - 981 format(' kpds(3) = ',i7,' kpds(4) = ',i7) - 982 format(' kpds(5) = ',i7,' kpds(6) = ',i7) - 983 format(' kpds(7) = ',i7,' kpds(8) = ',i7) - 984 format(' kpds(9) = ',i7,' kpds(10) = ',i7) - 985 format(' kpds(11) = ',i7,' kpds(12) = ',i7) - 986 format(' kpds(13) = ',i7,' kpds(14) = ',i7) - 987 format(' kpds(15) = ',i7,' kpds(16) = ',i7) - 988 format(' kpds(17) = ',i7,' kpds(18) = ',i7) - 989 format(' kpds(19) = ',i7,' kpds(20) = ',i7) - 990 format(' kpds(21) = ',i7,' kpds(22) = ',i7) - 991 format(' kpds(23) = ',i7,' kpds(24) = ',i7) - 992 format(' kpds(25) = ',i7) - 880 format(' kgds(1) = ',i7,' kgds(2) = ',i7) - 881 format(' kgds(3) = ',i7,' kgds(4) = ',i7) - 882 format(' kgds(5) = ',i7,' kgds(6) = ',i7) - 883 format(' kgds(7) = ',i7,' kgds(8) = ',i7) - 884 format(' kgds(9) = ',i7,' kgds(10) = ',i7) - 885 format(' kgds(11) = ',i7,' kgds(12) = ',i7) - 886 format(' kgds(13) = ',i7,' kgds(14) = ',i7) - 887 format(' kgds(15) = ',i7,' kgds(16) = ',i7) - 888 format(' kgds(17) = ',i7,' kgds(18) = ',i7) - 889 format(' kgds(19) = ',i7,' kgds(20) = ',i7) - 890 format(' kgds(20) = ',i7,' kgds(22) = ',i7) - - endif - - enddo levloop -c - return - end -c -c----------------------------------------------------------------------- -c -c----------------------------------------------------------------------- - subroutine open_grib_files (lugb,lugi,lout,gribver,iret) - -C ABSTRACT: This subroutine must be called before any attempt is -C made to read from the input GRIB files. The GRIB and index files -C are opened with a call to baopenr. This call to baopenr was not -C needed in the cray version of this program (the files could be -C opened with a simple Cray assign statement), but the GRIB-reading -C utilities on the SP do require calls to this subroutine (it has -C something to do with the GRIB I/O being done in C on the SP, and -C the C I/O package needs an explicit open statement). -C -C INPUT: -C lugb The Fortran unit number for the GRIB data file -C lugi The Fortran unit number for the GRIB index file -C lout The Fortran unit number for the output grib file -c gribver integer (1 or 2) to indicate if using GRIB1 / GRIB2 -C -C OUTPUT: -C iret The return code from this subroutine - - implicit none - - character fnameg*7,fnamei*7,fnameo*7 - integer iret,gribver,lugb,lugi,lout,igoret,iioret,iooret - - iret=0 - fnameg(1:5) = "fort." - fnamei(1:5) = "fort." - fnameo(1:5) = "fort." - write(fnameg(6:7),'(I2)') lugb - write(fnamei(6:7),'(I2)') lugi - write(fnameo(6:7),'(I2)') lout - call baopenr (lugb,fnameg,igoret) - call baopenr (lugi,fnamei,iioret) - call baopenw (lout,fnameo,iooret) - - print *,' ' - print *,'vint: baopen: igoret= ',igoret,' iioret= ',iioret - & ,' iooret= ',iooret - - if (igoret /= 0 .or. iioret /= 0 .or. iooret /= 0) then - print *,' ' - print *,'!!! ERROR in vint.' - print *,'!!! ERROR in sub open_grib_files opening grib file' - print *,'!!! or grib index file. baopen return codes:' - print *,'!!! grib file return code = igoret = ',igoret - print *,'!!! index file return code = iioret = ',iioret - print *,'!!! output file return code = iooret = ',iooret - iret = 93 - return - endif - - return - end -c -c------------------------------------------------------------------- -c -c------------------------------------------------------------------- - subroutine bitmapchk (n,ld,d,dmin,dmax) -c -c This subroutine checks the bitmap for non-existent data values. -c Since the data from the regional models have been interpolated -c from either a polar stereographic or lambert conformal grid -c onto a lat/lon grid, there will be some gridpoints around the -c edges of this lat/lon grid that have no data; these grid -c points have been bitmapped out by Mark Iredell's interpolater. -c To provide another means of checking for invalid data points -c later in the program, set these bitmapped data values to a -c value of -999.0. The min and max of this array are also -c returned if a user wants to check for reasonable values. -c - logical(1) ld - dimension ld(n),d(n) -c - dmin=1.E15 - dmax=-1.E15 -c - do i=1,n - if (ld(i)) then - dmin=min(dmin,d(i)) - dmax=max(dmax,d(i)) - else - d(i) = -999.0 - endif - enddo -c - return - end diff --git a/util/modulefiles/gfs_util.hera b/util/modulefiles/gfs_util.hera deleted file mode 100644 index ac8a7d941c..0000000000 --- a/util/modulefiles/gfs_util.hera +++ /dev/null @@ -1,28 +0,0 @@ -#%Module##################################################### -## Module file for GFS util -############################################################# -# -# Loading required system modules -# - -module use /scratch2/NCEPDEV/nwprod/hpc-stack/libs/hpc-stack/modulefiles/stack -module load hpc/1.1.0 -module load hpc-intel/18.0.5.274 -module load hpc-impi/2018.0.4 - -module load bacio/2.4.1 -module load w3emc/2.7.3 -module load w3nco/2.4.1 -module load ip/3.3.3 -module load sp/2.3.3 -module load bufr/11.4.0 - -module load jasper/2.0.22 -module load png/1.6.35 -module load zlib/1.2.11 - -module load ncl/6.5.0 -module load gempak/7.4.2 - -export GEMINC=/apps/gempak/7.4.2/gempak/include -export GEMOLB=/apps/gempak/7.4.2/os/linux64/lib diff --git a/util/modulefiles/gfs_util.wcoss_dell_p3 b/util/modulefiles/gfs_util.wcoss_dell_p3 deleted file mode 100755 index bde874a371..0000000000 --- a/util/modulefiles/gfs_util.wcoss_dell_p3 +++ /dev/null @@ -1,22 +0,0 @@ -#%Module##################################################### -## Module file for GFS util -############################################################# -# -# Loading required system modules -# - module load ips/18.0.1.163 - module load impi/18.0.1 - module load NCL/6.4.0 - -# Loading GEMPAK module - module use -a /gpfs/dell1/nco/ops/nwprod/modulefiles/ - module load gempak/7.3.3 - -# Loading Intel-Compiled NCEP Libraries - module load bacio/2.0.3 - module load w3emc/2.4.0 - module load w3nco/2.2.0 - module load ip/3.0.2 - module load sp/2.0.3 - module load g2/3.2.0 - module load bufr/11.3.0 diff --git a/util/sorc/compile_gfs_util_wcoss.sh b/util/sorc/compile_gfs_util_wcoss.sh deleted file mode 100755 index 26e065a221..0000000000 --- a/util/sorc/compile_gfs_util_wcoss.sh +++ /dev/null @@ -1,57 +0,0 @@ -#!/bin/sh - -###################################################################### -# -# Build executable GFS utility for GFS V16.0.0 -# -###################################################################### - -LMOD_EXACT_MATCH=no -source ../../sorc/machine-setup.sh > /dev/null 2>&1 -cwd=`pwd` - -if [ "$target" = "wcoss_dell_p3" ] || [ "$target" = "wcoss_cray" ] || [ "$target" = "hera" ] ; then - echo " " - echo " You are on WCOSS: $target " - echo " " -elif [ "$target" = "wcoss" ] ; then - echo " " - echo " " - echo " You are on WCOSS: $target " - echo " You do not need to build GFS utilities for GFS V16.0.0 " - echo " " - echo " " - exit -else - echo " " - echo " Your machine is $target is not recognized as a WCOSS machine." - echo " The script $0 can not continue. Aborting!" - echo " " - exit -fi -echo " " - -# Load required modules -source ../modulefiles/gfs_util.${target} -module list - -dirlist="overgridid rdbfmsua webtitle mkgfsawps" -set -x - -for dir in $dirlist -do - cd ${dir}.fd - echo "PWD: $PWD" - set +x - echo " " - echo " ### ${dir} ### " - echo " " - set -x - ./compile_${dir}_wcoss.sh - set +x - echo " " - echo " ######################################### " - echo " " - cd .. - echo "BACK TO: $PWD" -done diff --git a/util/sorc/mkgfsawps.fd/compile_mkgfsawps_wcoss.sh b/util/sorc/mkgfsawps.fd/compile_mkgfsawps_wcoss.sh deleted file mode 100755 index 7051909c60..0000000000 --- a/util/sorc/mkgfsawps.fd/compile_mkgfsawps_wcoss.sh +++ /dev/null @@ -1,36 +0,0 @@ -#!/bin/sh -LMOD_EXACT_MATCH=no -source ../../../sorc/machine-setup.sh > /dev/null 2>&1 -cwd=`pwd` - -if [ "$target" = "wcoss_dell_p3" ] || [ "$target" = "wcoss_cray" ] || [ "$target" = "hera" ] ; then - echo " " - echo " You are on WCOSS: $target " - echo " " -elif [ "$target" = "wcoss" ] ; then - echo " " - echo " " - echo " You are on WCOSS: $target " - echo " You do not need to build GFS utilities for GFS V15.0.0 " - echo " " - echo " " - exit -else - echo " " - echo " Your machine is $target is not recognized as a WCOSS machine." - echo " The script $0 can not continue. Aborting!" - echo " " - exit -fi -echo " " - -# Load required modules -source ../../modulefiles/gfs_util.${target} -module list - -set -x - -mkdir -p ../../exec -make -f makefile.$target -make -f makefile.$target clean -mv mkgfsawps ../../exec diff --git a/util/sorc/mkgfsawps.fd/makefile b/util/sorc/mkgfsawps.fd/makefile deleted file mode 100755 index 86f3c417b1..0000000000 --- a/util/sorc/mkgfsawps.fd/makefile +++ /dev/null @@ -1,53 +0,0 @@ -SHELL=/bin/sh -# -SRCS= mkgfsawps.f - -OBJS= mkgfsawps.o - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# PROFLIB Library needed for profiling -# -FC = ifort - -LDFLAGS = -IOMP5_LIB=/usrx/local/prod/intel/2018UP01/lib/intel64/libiomp5.a - -LIBS = -Xlinker --start-group ${W3NCO_LIBd} ${W3NCO_LIBd} ${IP_LIBd} ${SP_LIBd} ${BACIO_LIB4} ${IOMP5_LIB} - -CMD = mkgfsawps -PROFLIB = -lprof - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# WARNING: SIMULTANEOUSLY PROFILING AND FLOWTRACING IS NOT RECOMMENDED -FFLAGS = -O3 -g -convert big_endian -r8 -i4 -assume noold_ldout_format - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) -o $(LDFLAGS) $(@) $(OBJS) $(LIBS) - rm -f $(OBJS) - -# Make the profiled version of the command and call it a.out.prof -# -$(CMD).prof: $(OBJS) - $(FC) -o $(LDFLAGS) $(@) $(OBJS) $(LIBS) - -rm -f $(OBJS) - -clean: - -rm -f $(OBJS) - -clobber: clean - -rm -f $(CMD) $(CMD).prof - -void: clobber - -rm -f $(SRCS) makefile diff --git a/util/sorc/mkgfsawps.fd/makefile.hera b/util/sorc/mkgfsawps.fd/makefile.hera deleted file mode 100755 index 99052691e7..0000000000 --- a/util/sorc/mkgfsawps.fd/makefile.hera +++ /dev/null @@ -1,53 +0,0 @@ -SHELL=/bin/sh -# -SRCS= mkgfsawps.f - -OBJS= mkgfsawps.o - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# PROFLIB Library needed for profiling -# -FC = ifort - -LDFLAGS = -# IOMP5_LIB=/usrx/local/prod/intel/2018UP01/lib/intel64/libiomp5.a - -LIBS = -qopenmp -Xlinker --start-group ${W3NCO_LIBd} ${W3NCO_LIBd} ${IP_LIBd} ${SP_LIBd} ${BACIO_LIB4} ${IOMP5_LIB} - -CMD = mkgfsawps -PROFLIB = -lprof - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# WARNING: SIMULTANEOUSLY PROFILING AND FLOWTRACING IS NOT RECOMMENDED -FFLAGS = -O3 -g -convert big_endian -r8 -i4 -assume noold_ldout_format - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) -o $(LDFLAGS) $(@) $(OBJS) $(LIBS) - rm -f $(OBJS) - -# Make the profiled version of the command and call it a.out.prof -# -$(CMD).prof: $(OBJS) - $(FC) -o $(LDFLAGS) $(@) $(OBJS) $(LIBS) - -rm -f $(OBJS) - -clean: - -rm -f $(OBJS) - -clobber: clean - -rm -f $(CMD) $(CMD).prof - -void: clobber - -rm -f $(SRCS) makefile diff --git a/util/sorc/mkgfsawps.fd/makefile.wcoss_cray b/util/sorc/mkgfsawps.fd/makefile.wcoss_cray deleted file mode 100755 index b1bd05f7e9..0000000000 --- a/util/sorc/mkgfsawps.fd/makefile.wcoss_cray +++ /dev/null @@ -1,56 +0,0 @@ -SHELL=/bin/sh -# -SRCS= mkgfsawps.f - -OBJS= mkgfsawps.o - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# PROFLIB Library needed for profiling -# -FC = ifort - -LDFLAGS = -IOMP5_LIB=/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libiomp5.a - -LIBS = -Xlinker --start-group ${W3NCO_LIBd} ${W3NCO_LIBd} ${IP_LIBd} ${SP_LIBd} ${BACIO_LIB4} ${IOMP5_LIB} - -CMD = mkgfsawps -PROFLIB = -lprof - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# WARNING: SIMULTANEOUSLY PROFILING AND FLOWTRACING IS NOT RECOMMENDED -FFLAGS = -O3 -g -convert big_endian -r8 -i4 -assume noold_ldout_format - -#FFLAGS = -F -#FFLAGS = -Wf"-ez" - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) -o $(LDFLAGS) $(@) $(OBJS) $(LIBS) - rm -f $(OBJS) - -# Make the profiled version of the command and call it a.out.prof -# -$(CMD).prof: $(OBJS) - $(FC) -o $(LDFLAGS) $(@) $(OBJS) $(LIBS) - -rm -f $(OBJS) - -clean: - -rm -f $(OBJS) - -clobber: clean - -rm -f $(CMD) $(CMD).prof - -void: clobber - -rm -f $(SRCS) makefile diff --git a/util/sorc/mkgfsawps.fd/makefile.wcoss_dell_p3 b/util/sorc/mkgfsawps.fd/makefile.wcoss_dell_p3 deleted file mode 100755 index 86f3c417b1..0000000000 --- a/util/sorc/mkgfsawps.fd/makefile.wcoss_dell_p3 +++ /dev/null @@ -1,53 +0,0 @@ -SHELL=/bin/sh -# -SRCS= mkgfsawps.f - -OBJS= mkgfsawps.o - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# PROFLIB Library needed for profiling -# -FC = ifort - -LDFLAGS = -IOMP5_LIB=/usrx/local/prod/intel/2018UP01/lib/intel64/libiomp5.a - -LIBS = -Xlinker --start-group ${W3NCO_LIBd} ${W3NCO_LIBd} ${IP_LIBd} ${SP_LIBd} ${BACIO_LIB4} ${IOMP5_LIB} - -CMD = mkgfsawps -PROFLIB = -lprof - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# WARNING: SIMULTANEOUSLY PROFILING AND FLOWTRACING IS NOT RECOMMENDED -FFLAGS = -O3 -g -convert big_endian -r8 -i4 -assume noold_ldout_format - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) -o $(LDFLAGS) $(@) $(OBJS) $(LIBS) - rm -f $(OBJS) - -# Make the profiled version of the command and call it a.out.prof -# -$(CMD).prof: $(OBJS) - $(FC) -o $(LDFLAGS) $(@) $(OBJS) $(LIBS) - -rm -f $(OBJS) - -clean: - -rm -f $(OBJS) - -clobber: clean - -rm -f $(CMD) $(CMD).prof - -void: clobber - -rm -f $(SRCS) makefile diff --git a/util/sorc/mkgfsawps.fd/mkgfsawps.f b/util/sorc/mkgfsawps.fd/mkgfsawps.f deleted file mode 100755 index 4e4e57db3c..0000000000 --- a/util/sorc/mkgfsawps.fd/mkgfsawps.f +++ /dev/null @@ -1,511 +0,0 @@ - PROGRAM MKGFSAWPS -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C . . . . -C MAIN PROGRAM: MKGFSAWPS -C PRGMMR: VUONG ORG: NP11 DATE: 2004-04-21 -C -C ABSTRACT: PROGRAM READS GRIB FILE FROM SPECTRAL MODEL WITH 0.5 DEGREE -C (GRID 4) OR 1 DEGREE (GRID 3) OR 2.5 DEGREE (GRID 2) RECORDS. -C UNPACKS THEM, AND CAN MAKE AWIPS GRIB GRIDS 201,202, 203, -C 204, 211, 213 and 225. THEN, ADD A TOC FLAG FIELD SEPARATOR -C BLOCK AND WMO HEADER IN FRONT OF EACH GRIB FIELD, AND WRITES -C THEM OUT TO A NEW FILE. THE OUTPUT FILE IS IN THE FORMAT -C REQUIRED FOR TOC'S FTP INPUT SERVICE, WHICH CAN BE USED TO -C DISSEMINATE THE GRIB BULLETINS. -C -C PROGRAM HISTORY LOG: -C 2004-04-21 VUONG -C 2010-05-27 VUONG INCREASED SIZE OF ARRAYS -C -C USAGE: -C INPUT FILES: -C 5 - STANDARD FORTRAN INPUT FILE. -C 11 - GRIB FILE FROM SPECTRAL MODEL WITH GRID 2 OR 3. -C 31 - CRAY GRIB INDEX FILE FOR FILE 11 -C PARM - PASS IN 4 CHARACTERS 'KWBX' WITH PARM FIELD -C -C OUTPUT FILES: (INCLUDING SCRATCH FILES) -C 6 - STANDARD FORTRAN PRINT FILE -C 51 - AWIPS GRIB GRID TYPE 201,202,203,211,213 and 225 RECORDS -C MADE FROM GRIB GRID 2, 3 OR 4 RECORDS. -C -C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES) -C UNIQUE: - MAKWMO -C LIBRARY: -C W3LIB - W3AS00 IW3PDS W3FP11 W3UTCDAT -C W3FI63 W3FI72 W3FI83 W3TAGB GETGB GETGBP -C BACIO - BAREAD BAOPENR BAOPENW BACLOSE -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN -C 10 - ERROR OPENING INPUT GRIB DATA FILE -C 18 - ERROR READING CONTROL CARD FILE -C 19 - ERROR READING CONTROL CARD FILE -C 20 - ERROR OPENING OUTPUT GRIB FILE -C 30 - BULLETINS ARE MISSING -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C - PARAMETER (MXSIZE=2000000,MXSIZ3=MXSIZE*3) - PARAMETER (LUGI=31,LUGB=11,LUGO=51) - PARAMETER (LENHEAD=21) -C - REAL FLDI(MXSIZE) - REAL FLDV(MXSIZE) - REAL FLDO(MXSIZE),FLDVO(MXSIZE) - REAL RLAT(MXSIZE),RLON(MXSIZE) - REAL CROT(MXSIZE),SROT(MXSIZE) -C - INTEGER D(20) - INTEGER IFLD(MXSIZE) - INTEGER IBDSFL(12) - INTEGER IBMAP(MXSIZE) - INTEGER IDAWIP(200) - INTEGER JGDS(100) - INTEGER MPDS(25) - INTEGER,DIMENSION(8):: ITIME=(/0,0,0,-500,0,0,0,0/) - INTEGER KGDS(200),KGDSO(200) - INTEGER KPDS(25) - INTEGER MAPNUM(20) - INTEGER NBITS(20) - INTEGER NPARM - INTEGER NBUL - INTEGER PUNUM - INTEGER IPOPT(20) - INTEGER,DIMENSION(28):: HEXPDS -C - CHARACTER * 6 BULHED(20) - CHARACTER * 100 CPARM - CHARACTER * 17 DESC - CHARACTER * 3 EOML - CHARACTER * 1 GRIB(MXSIZ3) - CHARACTER * 1 KBUF(MXSIZ3) - CHARACTER * 4 KWBX - CHARACTER * 2 NGBFLG - CHARACTER * 1 PDS(28),GDS(400) - CHARACTER * 1 PDSL(28) - CHARACTER * 1 PDSAWIP(28) - CHARACTER * 132 TITLE - CHARACTER * 1 WMOHDR(21) - CHARACTER * 1 WFLAG - CHARACTER * 6 ENVVAR - CHARACTER * 80 FIlEB,FILEI,FILEO - CHARACTER * 1 CSEP(80) -C - LOGICAL IW3PDS - LOGICAL*1 KBMS(MXSIZE),KBMSO(MXSIZE) -C - SAVE -C - DATA IBDSFL/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ - DATA IP/0/,IPOPT/1,19*0/ - DATA HEXPDS /28*0/ - DATA KM/1/ -C - CALL W3TAGB('MKGFSAWIPS',2004,0112,0112,'NP11') -C -C READ GRIB DATA AND INDEX FILE NAMES FROM THE FORT -C ENVIRONMENT VARIABLES, AND OPEN THE FILES. -C - ENVVAR='FORT ' - WRITE(ENVVAR(5:6),FMT='(I2)') LUGB - CALL GETENV(ENVVAR,FILEB) - WRITE(ENVVAR(5:6),FMT='(I2)') LUGI - CALL GETENV(ENVVAR,FILEI) - - CALL BAOPENR(LUGB,FILEB,IRET1) - IF ( IRET1 .NE. 0 ) THEN - WRITE(6,FMT='(" ERROR OPENING GRIB FILE: ",A80)') FILEB - WRITE(6,FMT='(" BAOPENR ERROR = ",I5)') IRET1 - STOP 10 - ENDIF - - CALL BAOPENR(LUGI,FILEI,IRET2) - IF ( IRET2 .NE. 0 ) THEN - WRITE(6,FMT='(" ERROR OPENING GRIB FILE: ",A80)') FILEB - WRITE(6,FMT='(" BAOPENR ERROR = ",I5)') IRET2 - STOP 10 - ENDIF -C -C READ OUTPUT GRIB BULLETIN FILE NAME FROM FORT -C ENVIRONMENT VARIABLE, AND OPEN FILE. -C - ENVVAR='FORT ' - WRITE(ENVVAR(5:6),FMT='(I2)') LUGO - CALL GETENV(ENVVAR,FILEO) - CALL BAOPENW(LUGO,FILEO,IRET3) - IF ( IRET3 .NE. 0 ) THEN - WRITE(6,FMT='(" ERROR OPENING OUTPUT GRIB FILE: ",A80)') FILEB - WRITE(6,FMT='(" BAOPENW ERROR = ",I5)') IRET3 - STOP 20 - ENDIF -C -C GET PARM FIELD WITH UP TO 100 CHARACTERS -C - CPARM = ' ' - KWBX = 'KWBC' - CALL W3AS00(NPARM,CPARM,IER) - IF (IER.EQ.0) THEN - IF (NPARM.EQ.0.OR.CPARM(1:4).EQ.' ') THEN - PRINT *,'THERE IS A PARM FIELD BUT IT IS EMPTY' - PRINT *,'OR BLANK, I WILL USE THE DEFAULT KWBC' - ELSE - KWBX(1:4) = CPARM(1:4) - END IF - ELSE IF (IER.EQ.2.OR.IER.EQ.3) THEN - PRINT *,'W3AS00 ERROR = ',IER - PRINT *,'THERE IS NO PARM FIELD, I USED DEFAULT KWBC' - ELSE - PRINT *,'W3AS00 ERROR = ',IER - END IF - PRINT *,'NPARM = ',NPARM - PRINT *,'CPARM = ',CPARM(1:4) - PRINT *,'KWBX = ',KWBX(1:4) -C - IRET = 0 - IOPT = 2 - INSIZE = 19 - NBUL = 0 - NGBSUM = 0 -C - CALL W3UTCDAT (ITIME) -C -C LOOP TO READ UNPACKED GRIB DATA -C 28 BYTE PDS AND 65160 FLOATING POINT NUMBERS -C - NREC = 0 - DO 699 IREAD = 1,1000 - READ (*,66,END=800) (HEXPDS(J),J=1,12), - & (HEXPDS(J),J=17,20), PUNUM, NGBFLG, DESC - 66 FORMAT(3(2X,4Z2),3X,4Z2,6X,I3,1X,A2,1X,A17) -C -C CHARACTERS ON CONTROL CARD NOT 0-9, A-F, OR a-f -C ALL RECORD EXCEPT V-GRD ARE READ INTO ARRAY C -C -C EXIT LOOP, IF NO MORE BULLETINS IN INPUT CARDS -C - PDS=CHAR(HEXPDS) - IF (MOVA2I(PDS(1)) .EQ. 255) EXIT - NREC = NREC + 1 - WRITE (6,FMT='(''**************************************'', - & ''************************************************'')') - PRINT *,'START NEW RECORD NO. = ',NREC - WRITE (6,FMT='('' INPUT PDS, PUNUM, NGBFLG'', - & '' & DESC...DESIRED GRIB MAPS LISTED ON FOLLOWING '', - & ''LINES...'',/,4X,3(2X,4Z2.2),3X,4Z2.2,6X,I3,1X,A2, - & 1X,A17)') (HEXPDS(J),J=1,12), - & (HEXPDS(J),J=17,20), PUNUM, NGBFLG, DESC -C -C READ IN GRIDS TO INTERPOLATE TO -C - NGB = 0 - DO J = 1,20 - READ (*,END=710,FMT='(4X,I3,2X,I2,2X,A6,1X,I3,24X,A3)') - & MAPNUM(J),NBITS(J), BULHED(J), D(J), EOML - WRITE (6,FMT='(4X,I3,2X,I2,2X,A6,1X,I3,24X,A3)') - & MAPNUM(J),NBITS(J), BULHED(J), D(J), EOML - NGB = J - IF (EOML .EQ. 'EOM') EXIT - ENDDO -C - NGBSUM = NGBSUM + NGB - JREW = 0 - MPDS = -1 - JGDS = -1 - MPDS(3) = MOVA2I(PDS(7)) - MPDS(5) = MOVA2I(PDS(9)) - WFLAG = ' ' - IF (MPDS(5).EQ.33) THEN - WFLAG = 'U' - ELSE IF (MPDS(5).EQ.34) THEN - WFLAG = 'V' - END IF - MPDS(6) = MOVA2I(PDS(10)) - MPDS(7) = MOVA2I(PDS(11)) * 256 + MOVA2I(PDS(12)) - IF (MPDS(5).EQ.61.OR.MPDS(5).EQ.62.OR. - & MPDS(5).EQ.63) THEN - MPDS(14) = MOVA2I(PDS(19)) - MPDS(15) = MOVA2I(PDS(20)) - END IF -C -C PRINT *,'CHECK POINT BEFORE GETGB' -C IF YOU GET U-GRD, ALSO READ V-GRD INTO ARRAY FLDV -C ALL RECORD EXCEPT V-GRD ARE READ INTO ARRAY FLDI -C IF YOU GET V-GRD, READ INTO ARRAY FLDV, READ U-GRD INTO FLDI -C - IF (WFLAG.EQ.'V') MPDS(5) = 33 - CALL GETGB(LUGB,LUGI,MXSIZE,JREW,MPDS,JGDS, - & MI,KREW,KPDS,KGDS,KBMS,FLDI,IRET) - CALL GETGBP(LUGB,LUGI,MXSIZ3,KREW-1,MPDS,JGDS, - & KBYTES,KREW,KPDS,KGDS,GRIB,IRET) - IF (IRET.NE.0) THEN - IF (IRET.LT.96) PRINT *,'GETGB-W3FI63: ERROR = ',IRET - IF (IRET.EQ.96) PRINT *,'GETGB: ERROR READING INDEX FILE' - IF (IRET.EQ.97) PRINT *,'GETGB: ERROR READING GRIB FILE' - IF (IRET.EQ.98) THEN - PRINT *,'GETGB ERROR: NUM. OF DATA POINTS GREATER THAN JF' - END IF - IF (IRET.EQ.99) PRINT *,'GETGB ERROR: REQUEST NOT FOUND' - IF (IRET.GT.99) PRINT *,'GETGB ERROR = ',IRET - GO TO 699 - END IF - PDSL(1:28)=GRIB(9:36) - IBI=MOD(KPDS(4)/64,2) - IF (WFLAG.EQ.'U') THEN - CALL W3FP11 (GRIB,PDSL,TITLE,IER) -C -C COMPARE RECORD (GRIB) TO CONTROL CARD (PDS), THEY SHOULD MATCH -C - KEY = 2 - IF (.NOT.IW3PDS(PDSL,PDS,KEY)) THEN - PRINT 2900, IREAD, (MOVA2I(PDSL(J)),J=1,28), - * (MOVA2I(PDS(J)),J=1,28) - GO TO 699 - END IF - END IF -C -C READ V-GRD INTO ARRAY FLDV -C - IF (WFLAG.EQ.'U'.OR.WFLAG.EQ.'V') THEN - MPDS(5) = 34 - CALL GETGB(LUGB,LUGI,MXSIZE,JREW,MPDS,JGDS, - & MI,KREW,KPDS,KGDS,KBMS,FLDV,JRET) - CALL GETGBP(LUGB,LUGI,MXSIZ3,KREW-1,MPDS,JGDS, - & KBYTES,KREW,KPDS,KGDS,GRIB,JRET) - IF (JRET.NE.0) THEN - IF (JRET.LT.96) PRINT *,'GETGB-W3FI63: ERROR = ',JRET - IF (JRET.EQ.96) PRINT *,'GETGB: ERROR READING INDEX FILE' - IF (JRET.EQ.97) PRINT *,'GETGB: ERROR READING GRIB FILE' - IF (JRET.EQ.98) THEN - PRINT *,'GETGB ERROR: NUM. OF DATA POINTS GREATER THAN JF' - END IF - IF (JRET.EQ.99) PRINT *,'GETGB ERROR: REQUEST NOT FOUND' - IF (JRET.GT.99) PRINT *,'GETGB ERROR = ',JRET - GO TO 699 - END IF - IF (WFLAG.EQ.'V') THEN - CALL W3FP11 (GRIB,PDSL,TITLE,IER) - END IF - END IF - PRINT *,'RECORD NO. OF GRIB RECORD IN INPUT FILE = ',KREW -C -C COMPARE RECORD (GRIB) TO CONTROL CARD (PDS), THEY SHOULD MATCH -C - KEY = 2 - IF (WFLAG.EQ.' '.OR.WFLAG.EQ.'V') THEN - PDSL(1:28)=GRIB(9:36) - IF (.NOT.IW3PDS(PDSL,PDS,KEY)) THEN - PRINT 2900, IREAD, (MOVA2I(PDSL(J)),J=1,28), - * (MOVA2I(PDS(J)),J=1,28) -2900 FORMAT ( 1X,I4,' (PDS) IN RECORD DOES NOT MATCH (PDS) IN ', - & 'CONTROL CARD ',/,7(1X,4Z2.2), /,7(1X,4Z2.2)) - GO TO 699 - END IF - END IF -C - PRINT 2, (MOVA2I(PDSL(J)),J=1,28) - 2 FORMAT (' PDS = ',7(4Z2.2,1X)) -C - IF (WFLAG.EQ.' ') THEN - CALL W3FP11 (GRIB,PDSL,TITLE,IER) - END IF - IF (IER.NE.0) PRINT *,'W3FP11 ERROR = ',IER - PRINT *,TITLE(1:86) -C -C MASK OUT ZERO PRECIP GRIDPOINTS BEFORE INTERPOLATION -C - IF (MPDS(5).EQ.61.OR.MPDS(5).EQ.62.OR. - & MPDS(5).EQ.63) THEN - DO J=1,MI - IF ( FLDI(J).EQ.0.0 ) THEN - KBMS(J)=.FALSE. - IBI=1 - ENDIF - ENDDO - END IF -C -C PROCESS EACH GRID -C - DO 690 I = 1,NGB - - CALL MAKGDS(MAPNUM(I),KGDSO,GDS,LENGDS,IRET) - IF ( IRET.NE.0) THEN - PRINT *,' GRID ',MAPNUM(I),' NOT VALID.' - CYCLE - ENDIF - - IF (WFLAG.EQ.' ') THEN - CALL IPOLATES(IP,IPOPT,KGDS,KGDSO,MI,MXSIZE,KM,IBI,KBMS,FLDI, - * IGPTS,RLAT,RLON,IBO,KBMSO,FLDO,IRET) - ELSE - CALL IPOLATEV(IP,IPOPT,KGDS,KGDSO,MI,MXSIZE,KM,IBI,KBMS, - * FLDI,FLDV,IGPTS,RLAT,RLON,CROT,SROT, - * IBO,KBMSO,FLDO,FLDVO,IRET) - ENDIF - - IF (IRET.NE.0) THEN - PRINT *,' INTERPOLATION TO GRID ',MAPNUM(I),' FAILED.' - CYCLE - ENDIF - - IF (WFLAG.EQ.'V') THEN - FLDO=FLDVO - ENDIF -C -C CALL W3FI69 TO UNPACK PDS INTO 25 WORD INTEGER ARRAY -C - CALL W3FI69(PDSL,IDAWIP) -C -C CHANGE MODEL NUMBER AND GRID TYPE -C - IDAWIP(5) = MAPNUM(I) - IF (WFLAG.EQ.'U') IDAWIP(8) = 33 - IF (WFLAG.EQ.'V') IDAWIP(8) = 34 -C -C ZERO PRECIP GRIDPOINTS WHERE MASK WAS APPLIED BEFORE INTERPOLATION -C - IF (IDAWIP(8).EQ.61.OR.IDAWIP(8).EQ.62.OR. - & IDAWIP(8).EQ.63) THEN - IF (IBO.EQ.1) THEN - DO J=1,IGPTS - IF ( .NOT.KBMSO(J) ) THEN - KBMSO(J)=.TRUE. - FLDO(J)=0.0 - ENDIF - ENDDO - END IF - END IF -C -C TEST RELATIVE HUMIDITY FOR GT THAN 100.0 AND LT 0.0 -C IF SO, RESET TO 0.0 AND 100.0 -C - IF (IDAWIP(8).EQ.52) THEN - DO J = 1,IGPTS - IF (FLDO(J).GT.100.0) FLDO(J) = 100.0 - IF (FLDO(J).LT.0.0) FLDO(J) = 0.0 - END DO - END IF -C -C SET ALL NEGATIVE ACUM PCP VALUES TO 0 -C - IF (IDAWIP(8).EQ.61.OR.IDAWIP(8).EQ.62.OR. - & IDAWIP(8).EQ.63) THEN - DO J = 1,IGPTS - IF (FLDO(J).LT.0.0) FLDO(J) = 0.0 - END DO - END IF -C -C COPY OUTPUT BITMAP FROM LOGICAL TO INTEGER ARRAY FOR W3FI72 -C - IF (IBO.EQ.1) THEN - DO J=1,IGPTS - IF (KBMSO(J)) THEN - IBMAP(J)=1 - ELSE - IBMAP(J)=0 - ENDIF - ENDDO - ELSE - IBMAP=1 - ENDIF -C -C IF D VALUE EQUAL ZERO, USE D VALUE IN 1 DEGREE INPUT RECORDS, -C ELSE USE THE D VALUE -C - IF (D(I).NE.0) THEN - IDAWIP(25) = D(I) - END IF -C -C PRINT *,'W3FT69 = ',IDAWIP -C PRINT *,'CHECK POINT AFTER W3FI69' -C - IBITL = NBITS(I) - ITYPE = 0 - IGRID = MAPNUM(I) - IPFLAG = 0 - IGFLAG = 0 - IBFLAG = 0 - ICOMP = 0 - IBLEN = IGPTS - JERR = 0 -C -C GRIB AWIPS GRID 37-44 -C -C PRINT *,'CHECK POINT BEFORE W3FI72' - CALL W3FI72(ITYPE,FLDO,IFLD,IBITL, - & IPFLAG,IDAWIP,PDSAWIP, - & IGFLAG,IGRID,KGDSO,ICOMP, - & IBFLAG,IBMAP,IBLEN, - & IBDSFL, - & NPTS,KBUF,ITOT,JERR) -C PRINT *,'CHECK POINT AFTER W3FI72' - IF (JERR.NE.0) PRINT *,' W3FI72 ERROR = ',JERR - PRINT *,'NPTS, ITOT = ',NPTS,ITOT - PRINT 2, (MOVA2I(PDSAWIP(J)),J=1,28) -C -C PRINT *,'SIZE OF GRIB FIELD = ',ITOT -C -C MAKE FLAG FIELD SEPARATOR BLOCK -C - CALL MKFLDSEP(CSEP,IOPT,INSIZE,ITOT+LENHEAD,LENOUT) -C -C MAKE WMO HEADER -C - CALL MAKWMO (BULHED(I),KPDS(10),KPDS(11),KWBX,WMOHDR) -C -C WRITE OUT SEPARATOR BLOCK, ABBREVIATED WMO HEADING, -C - CALL WRYTE(LUGO,LENOUT,CSEP) - CALL WRYTE(LUGO,LENHEAD,WMOHDR) - CALL WRYTE(LUGO,ITOT,KBUF) - NBUL = NBUL + 1 - 690 CONTINUE -C - 699 CONTINUE -C-------------------------------------------------------------- -C -C CLOSING SECTION -C - 800 CONTINUE - IF (NBUL .EQ. 0 .AND. NUMFLD .EQ. 0) THEN - WRITE (6,FMT='('' SOMETHING WRONG WITH DATA CARDS...'', - & ''NOTHING WAS PROCESSED'')') - CALL W3TAGE('MKGFSAWPS') - STOP 19 - ELSE - CALL BACLOSE (LUGB,IRET) - CALL BACLOSE (LUGI,IRET) - CALL BACLOSE (LUGO,IRET) - WRITE (6,FMT='(//,'' ******** RECAP OF THIS EXECUTION '', - & ''********'',/,5X,''READ '',I6,'' INDIVIDUAL IDS'', - & /,5X,''WROTE '',I6,'' BULLETINS OUT FOR TRANSMISSION'', - & //)') NREC, NBUL -C -C TEST TO SEE IF ANY BULLETINS MISSING -C - MBUL = 0 - MBUL = NGBSUM - NBUL - IF (MBUL.NE.0) THEN - PRINT *,'BULLETINS MISSING = ',MBUL - CALL W3TAGE('MKGFSAWPS') - STOP 30 - END IF -C - CALL W3TAGE('MKGFSAWPS') - STOP - ENDIF -C -C ERROR MESSAGES -C - 710 CONTINUE - WRITE (6,FMT='('' ?*?*? CHECK DATA CARDS... READ IN '', - & ''GRIB PDS AND WAS EXPECTING GRIB MAP CARDS TO FOLLOW.'',/, - & '' MAKE SURE NGBFLG = ZZ OR SUPPLY '', - & ''SOME GRIB MAP DEFINITIONS!'')') - CALL W3TAGE('MKGFSAWPS') - STOP 18 -C - END diff --git a/util/sorc/overgridid.fd/compile_overgridid_wcoss.sh b/util/sorc/overgridid.fd/compile_overgridid_wcoss.sh deleted file mode 100755 index ccce82b0e5..0000000000 --- a/util/sorc/overgridid.fd/compile_overgridid_wcoss.sh +++ /dev/null @@ -1,43 +0,0 @@ -#!/bin/sh - -###################################################################### -# -# Build executable : GFS utilities -# -###################################################################### - -LMOD_EXACT_MATCH=no -source ../../../sorc/machine-setup.sh > /dev/null 2>&1 -cwd=`pwd` - -if [ "$target" = "wcoss_dell_p3" ] || [ "$target" = "wcoss_cray" ] || [ "$target" = "hera" ] ; then - echo " " - echo " You are on $target " - echo " " -elif [ "$target" = "wcoss" ] ; then - echo " " - echo " " - echo " You are on WCOSS: $target " - echo " You do not need to build GFS utilities for GFS V15.0.0 " - echo " " - echo " " - exit -else - echo " " - echo " Your machine is $target is not recognized as a WCOSS machine." - echo " The script $0 can not continue. Aborting!" - echo " " - exit -fi -echo " " - -# Load required modules -source ../../modulefiles/gfs_util.${target} -module list - -set -x - -mkdir -p ../../exec -make -mv overgridid ../../exec -make clean diff --git a/util/sorc/overgridid.fd/makefile b/util/sorc/overgridid.fd/makefile deleted file mode 100755 index 7141872bc1..0000000000 --- a/util/sorc/overgridid.fd/makefile +++ /dev/null @@ -1,8 +0,0 @@ -LIBS = ${W3NCO_LIB4} ${BACIO_LIB4} -OBJS= overgridid.o -overgridid: overgridid.f - ifort -o overgridid overgridid.f $(LIBS) -clean: - -rm -f $(OBJS) - - diff --git a/util/sorc/overgridid.fd/overgridid.f b/util/sorc/overgridid.fd/overgridid.f deleted file mode 100755 index 29b0080bf6..0000000000 --- a/util/sorc/overgridid.fd/overgridid.f +++ /dev/null @@ -1,59 +0,0 @@ - program overgridid -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C -C MAIN PROGRAM: OVERGRIDID REPLACE iGRID ID IN A GRIB FILE -C PRGMMR: VUONG ORG: NP23 DATE: 2014-05-21 -C -C ABSTRACT: THIS PROGRAM READS AN ENTIRE GRIB FILE FROM UNIT 11 -C AND WRITES IT BACK OUT TO UNIT 51, REPLACING THE INTERNAL -C GRID ID WITH THE GRID ID READ IN VIA UNIT 5. -C -C PROGRAM HISTORY LOG: -C 1998-01-01 IREDELL -C 1998-06-17 FARLEY MODIFIED OVERDATE ROUTINE -C 1999-05-24 Gilbert - added calls to BAOPEN. -C 2014-05-21 Vuong - Modified to change grid id in a grib file -C -C INPUT FILES: -C UNIT 5 2-DIGIT MODEL ID (in base 10) -C UNIT 11 INPUT GRIB FILE = "fort.11" -C -C OUTPUT FILES: -C UNIT 51 OUTPUT GRIB FILE = "fort.51" -C -C SUBPROGRAMS CALLED: -C SKGB - Find next GRIB field -C BAREAD - Read GRIB field -C WRYTE - Read GRIB field -C -C REMARKS: -C ANY NON-GRIB INFORMATION IN THE INPUT GRIB FILE WILL BE LOST. -C AN OUTPUT LINE WILL BE WRITTEN FOR EACH GRIB MESSAGE COPIED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - parameter(msk1=32000,msk2=4000,mgrib=10000000) - character cgrib(mgrib) -C - read *,id ! grid id, ie 03 for 1.0 deg grib - call baopenr(11,"fort.11",iret1) - call baopenw(51,"fort.51",iret2) -C - n=0 - iseek=0 - call skgb(11,iseek,msk1,lskip,lgrib) - dowhile(lgrib.gt.0.and.lgrib.le.mgrib) - call baread(11,lskip,lgrib,ngrib,cgrib) - if(ngrib.ne.lgrib) call exit(2) - n=n+1 - id0=mova2i(cgrib(8+7)) - cgrib(8+7)=char(id) - call wryte(51,lgrib,cgrib) - print '("msg",i6,4x,"len",i8,4x,"was",i4.2,4x,"now",i4.2)', - & n,lgrib,id0,id - iseek=lskip+lgrib - call skgb(11,iseek,msk2,lskip,lgrib) - enddo - end diff --git a/util/sorc/overgridid.fd/sample.script b/util/sorc/overgridid.fd/sample.script deleted file mode 100755 index fdfd931600..0000000000 --- a/util/sorc/overgridid.fd/sample.script +++ /dev/null @@ -1,13 +0,0 @@ -# THIS SCRIPT READ A FORECAST FILE (UNIT 11), MODIFIES PDS OCTET(8) -# TO CORRECT THE GRIB GRID ID AND RE-WRITES THE FILE TO UNIT 51. - -# STANDARD INPUT IS A 3-DIGIT INTEGER, FOR EXAMPLE 255 (User define grid) - -ln -s master.grbf06 fort.11 - -overgridid << EOF -255 -EOF - -mv fort.51 master.grbf06.new -rm fort.11 diff --git a/util/sorc/rdbfmsua.fd/MAPFILE b/util/sorc/rdbfmsua.fd/MAPFILE deleted file mode 100755 index 19e0decd71..0000000000 --- a/util/sorc/rdbfmsua.fd/MAPFILE +++ /dev/null @@ -1,4045 +0,0 @@ -Archive member included because of file (symbol) - -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flclos.o) - rdbfmsua.o (fl_clos_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flflun.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flclos.o) (fl_flun_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltbop.o) - rdbfmsua.o (fl_tbop_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltdat.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltbop.o) (fl_tdat_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltinq.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltbop.o) (fl_tinq_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stldsp.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltdat.o) (st_ldsp_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlstr.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltinq.o) (st_lstr_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmbl.o) - rdbfmsua.o (st_rmbl_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmst.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltinq.o) (st_rmst_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbrstn.o) - rdbfmsua.o (tb_rstn_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flbksp.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltdat.o) (fl_bksp_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flinqr.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltinq.o) (fl_inqr_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flpath.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltinq.o) (fl_path_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flsopn.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltbop.o) (fl_sopn_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssenvr.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flinqr.o) (ss_envr_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssgsym.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssenvr.o) (ss_gsym_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlcuc.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssenvr.o) (st_lcuc_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stuclc.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flinqr.o) (st_uclc_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbastn.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbrstn.o) (tb_astn_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flglun.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flsopn.o) (fl_glun_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libbridge.a(dcbsrh.o) - rdbfmsua.o (dc_bsrh_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ireadns.o) - rdbfmsua.o (ireadns_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) - rdbfmsua.o (openbf_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapn.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) (posapn_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapx.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) (posapx_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgw.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapn.o) (rdmsgw_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readdx.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) (readdx_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readns.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ireadns.o) (readns_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readns.o) (readsb_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(status.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) (status_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) - rdbfmsua.o (ufbint_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) (ufbrw_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upb.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) (upb_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdlen.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) (wrdlen_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) (writdx_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wtstat.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) (wtstat_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(adn30.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) (adn30_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) (bfrini_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort2.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) (bort2_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort_exit.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort2.o) (bort_exit_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) (bort_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(conwin.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) (conwin_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cpbfdx.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readdx.o) (cpbfdx_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(drstpl.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) (drstpl_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxinit.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) (dxinit_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxmini.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) (dxmini_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getwin.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) (getwin_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ibfms.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) (ibfms_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ichkstr.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) (ichkstr_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ifxy.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) (ifxy_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invcon.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(conwin.o) (invcon_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invwin.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) (invwin_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ipkm.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) (ipkm_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(irev.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upb.o) (irev_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupm.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdlen.o) (iupm_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lmsg.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgw.o) (lmsg_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrpc.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getwin.o) (lstrpc_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrps.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) (lstrps_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) (msgwrt_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(newwin.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) (newwin_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nmwrd.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lmsg.o) (nmwrd_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nxtwin.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) (nxtwin_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ovrbs1.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) (ovrbs1_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(padmsg.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) (padmsg_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkb.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) (pkb_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkbs1.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) (pkbs1_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkc.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) (pkc_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pktdd.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxinit.o) (pktdd_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs01.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) (pkvs01_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs1.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) (pkvs1_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readdx.o) (rdbfdx_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdcmps.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) (rdcmps_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdtree.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) (rdtree_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdusdx.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readdx.o) (rdusdx_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readmg.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readns.o) (readmg_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(seqsdx.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdusdx.o) (seqsdx_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(stndrd.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) (stndrd_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(string.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) (string_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strnum.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(seqsdx.o) (strnum_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strsuc.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strnum.o) (strsuc_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(trybump.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) (trybump_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upbb.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdtree.o) (upbb_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upc.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdcmps.o) (upc_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(usrtpl.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(conwin.o) (usrtpl_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(capit.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) (capit_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrna.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ichkstr.o) (chrtrna_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrn.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) (chrtrn_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cktaba.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readmg.o) (cktaba_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cnved4.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) (cnved4_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(digit.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) (digit_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(elemdx.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdusdx.o) (elemdx_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getlens.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) (getlens_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(gets1loc.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkbs1.o) (gets1loc_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(i4dy.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cktaba.o) (i4dy_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(idn30.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) (idn30_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(igetdate.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cktaba.o) (igetdate_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(istdesc.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(stndrd.o) (istdesc_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupb.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) (iupb_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupbs01.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) (iupbs01_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstchr.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(elemdx.o) (jstchr_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstnum.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(elemdx.o) (jstnum_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstjpb.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(trybump.o) (lstjpb_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(makestab.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) (makestab_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(mvb.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(stndrd.o) (mvb_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemock.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdusdx.o) (nemock_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtab.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(seqsdx.o) (nemtab_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbax.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cktaba.o) (nemtbax_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenuaa.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) (nenuaa_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenubd.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) (nenubd_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numbck.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdusdx.o) (numbck_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtab.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(seqsdx.o) (numtab_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbt.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cktaba.o) (openbt_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parstr.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(seqsdx.o) (parstr_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parusr.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(string.o) (parusr_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parutg.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parusr.o) (parutg_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rcstpl.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdtree.o) (rcstpl_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgb.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readmg.o) (rdmsgb_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(restd.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(stndrd.o) (restd_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rsvfvm.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(seqsdx.o) (rsvfvm_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strcln.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(makestab.o) (strcln_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabsub.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(makestab.o) (tabsub_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(uptdd.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(restd.o) (uptdd_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdesc.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(restd.o) (wrdesc_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cadn30.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(restd.o) (cadn30_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chekstab.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(makestab.o) (chekstab_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(inctab.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabsub.o) (inctab_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbb.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(restd.o) (nemtbb_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbd.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabsub.o) (nemtbd_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtbd.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(restd.o) (numtbd_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabent.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabsub.o) (tabent_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(valx.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbb.o) (valx_) -/gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rjust.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(valx.o) (rjust_) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/for_main.o (for_rtl_finish_) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) (for_check_env_name) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) - rdbfmsua.o (for_open) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_preconnected_units_init.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) (for__preconnected_units_create) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_reentrancy.o) - rdbfmsua.o (for_set_reentrancy) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_secnds.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) (for_since_epoch_t) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_stop.o) - rdbfmsua.o (for_stop_core) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_vm.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) (for__set_signal_ops_during_vm) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wint_fmt.o) - rdbfmsua.o (for_write_int_fmt) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_fmt.o) - rdbfmsua.o (for_write_seq_fmt) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_lis.o) - rdbfmsua.o (for_write_seq_lis) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_preconnected_units_init.o) (for__aio_lub_table) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) (for__reopen_file) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio_wrap.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) (for__aio_pthread_self) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_int.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) (cvt_text_to_integer) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_f.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) (cvt_vax_f_to_ieee_single) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_d.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) (cvt_vax_d_to_ieee_double) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_g.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) (cvt_vax_g_to_ieee_double) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cray.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) (cvt_cray_to_ieee_double) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_short.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) (cvt_ibm_short_to_ieee_single) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_long.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) (cvt_ibm_long_to_ieee_double) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_double.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) (cvt_ieee_double_to_cray) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_single.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) (cvt_ieee_single_to_ibm_short) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) (for__close_default) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close_proc.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) (for__close_proc) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_default_io_sizes_env_init.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) (for__default_io_sizes_env_init) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_desc_item.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wint_fmt.o) (for__desc_ret_item) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_diags_intel.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) (for__io_return) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_exit.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_reentrancy.o) (for_exit) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_exit_handler.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) (for__exit_handler) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_comp.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wint_fmt.o) (for__format_compiler) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wint_fmt.o) (for__format_value) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_get.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) (for__get_s) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_intrp_fmt.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wint_fmt.o) (for__interp_fmt) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_ldir_wfs.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_lis.o) (for__wfs_table) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_lub_mgt.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) (for__acquire_lun) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_need_lf.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) (for__add_to_lf_table) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_put.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_stop.o) (for__put_su) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close_proc.o) (for__finish_ufseq_write) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(tbk_traceback.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_diags_intel.o) (tbk_stack_trace) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt__globals.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_double.o) (vax_c) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_int_to_text.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) (cvt_integer_to_text) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_data_to_text.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) (cvt_data_to_text) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_log_to_text.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) (cvt_boolean_to_text_ex) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_data.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) (cvt_text_to_data) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_log.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) (cvt_text_to_boolean) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_t.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) (cvt_ieee_t_to_text_ex) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_s.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) (cvt_ieee_s_to_text_ex) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_x.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) (cvt_ieee_x_to_text_ex) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_s.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_s.o) (cvtas_a_to_s) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_t.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_t.o) (cvtas_a_to_t) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_s_to_a.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_s.o) (cvtas_s_to_a) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_t_to_a.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_t.o) (cvtas_t_to_a) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_s.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_s.o) (cvtas__nan_s) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_t.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_t.o) (cvtas__nan_t) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_x.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_x.o) (cvtas_a_to_x) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_x_to_a.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_x.o) (cvtas_x_to_a) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_x.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_x.o) (cvtas__nan_x) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_globals.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_t.o) (cvtas_pten_word) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_53.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_s.o) (cvtas_pten_t) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_64.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_t.o) (cvtas_pten_64) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_128.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_s_to_a.o) (cvtas_pten_128) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(fetestexcept.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_stop.o) (fetestexcept) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_stub.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parusr.o) (lroundf) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_stub.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(trybump.o) (lround) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_ct.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_stub.o) (lround.L) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_ct.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_stub.o) (lroundf.L) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_gen.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_stub.o) (lroundf.A) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_gen.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_stub.o) (lround.A) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(libm_error.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_ct.o) (__libm_error_support) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherrf.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(libm_error.o) (matherrf) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherrl.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(libm_error.o) (matherrl) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherr.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(libm_error.o) (matherr) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ints2q.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_secnds.o) (__jtoq) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(qcomp.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_secnds.o) (__neq) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fp2q.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_secnds.o) (__dtoq) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(q2fp.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_secnds.o) (__qtof) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_display.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(tbk_traceback.o) (tbk_string_stack_signal_impl) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_backtrace.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_display.o) (tbk_getPC) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(cpu_feature_disp.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_stub.o) (__intel_cpu_features_init_x) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemcpy.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) (_intel_fast_memcpy) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemmove.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) (_intel_fast_memmove) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemset.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) (_intel_fast_memset) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(new_proc_init.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/for_main.o (__intel_new_feature_proc_init) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_addsubq.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_secnds.o) (__addq) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_divq.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_secnds.o) (__divq) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strcpy.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) (__intel_sse2_strcpy) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncpy.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) (__intel_sse2_strncpy) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strlen.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) (__intel_sse2_strlen) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strchr.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) (__intel_sse2_strchr) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncmp.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_diags_intel.o) (__intel_sse2_strncmp) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strcat.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) (__intel_sse2_strcat) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncat.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) (__intel_sse2_strncat) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_memcpy_pp.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemcpy.o) (__intel_new_memcpy) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_memset_pp.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemset.o) (__intel_new_memset) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memcpy.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemcpy.o) (__intel_ssse3_memcpy) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memcpy.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemcpy.o) (__intel_ssse3_rep_memcpy) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memmove.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemmove.o) (__intel_ssse3_memmove) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memmove.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemmove.o) (__intel_ssse3_rep_memmove) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(irc_msg_support.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_backtrace.o) (__libirc_get_msg) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_mem_ops.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_memset_pp.o) (__libirc_largest_cache_size) -/opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(proc_init_utils.o) - /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(new_proc_init.o) (__intel_proc_init_ftzdazule) -/usr/lib64/libc_nonshared.a(elf-init.oS) - /usr/lib/../lib64/crt1.o (__libc_csu_fini) -/opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdcmps.o) (__powidf2) - -Allocating common symbols -Common symbol size file - -utgprm_ 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parutg.o) -maxcmp_ 0x18 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) -msgstd_ 0x1 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) -thread_count_mutex 0x28 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) -reptab_ 0x64 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) -stbfr_ 0x100 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) -hrdwrd_ 0x2c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgw.o) -bitbuf_ 0x192dd8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) -usrbit_ 0x27100 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdtree.o) -stcach_ 0x4844c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(string.o) -bufrmg_ 0xc354 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) -msgcmp_ 0x1 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) -nulbfr_ 0x80 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) -threads_in_flight_mutex - 0x28 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) -usrint_ 0x753080 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) -acmode_ 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) -s01cm_ 0x7c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) -gmbdta_ 0x1c4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flflun.o) -for__pthread_mutex_unlock_ptr - 0x8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) -for__a_argv 0x8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) -for__pthread_mutex_init_ptr - 0x8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) -charac_ 0x804 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdlen.o) -stords_ 0x1f40 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(string.o) -bufrsr_ 0xc3f8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) -tabccc_ 0x10 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabsub.o) -unptyp_ 0x80 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) -msgfmt_ 0x80 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) -dateln_ 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) -sect01_ 0x7c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) -message_catalog 0x8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_diags_intel.o) -tables_ 0x13d628 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readns.o) -mrgcom_ 0x10 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) -padesc_ 0x14 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) -usrtmp_ 0x16e3600 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rcstpl.o) -dxtab_ 0x300 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) -for__pthread_mutex_lock_ptr - 0x8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) -tababd_ 0xbbe58c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) -usrstr_ 0xd0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) -msgcwd_ 0x280 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) -for__l_argc 0x4 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) -quiet_ 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) -for__aio_lub_table 0x400 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) - -Discarded input sections - - .note.GNU-stack - 0x0000000000000000 0x0 /usr/lib/../lib64/crt1.o - .note.GNU-stack - 0x0000000000000000 0x0 /usr/lib/../lib64/crti.o - .note.GNU-stack - 0x0000000000000000 0x0 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtbegin.o - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/for_main.o - .note.GNU-stack - 0x0000000000000000 0x0 rdbfmsua.o - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flclos.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flflun.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltbop.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltdat.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltinq.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stldsp.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlstr.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmbl.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmst.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbrstn.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flbksp.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flinqr.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flpath.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flsopn.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssenvr.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssgsym.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlcuc.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stuclc.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbastn.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flglun.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libbridge.a(dcbsrh.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ireadns.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapn.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapx.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgw.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readdx.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readns.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(status.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upb.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdlen.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wtstat.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(adn30.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort2.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort_exit.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(conwin.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cpbfdx.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(drstpl.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxinit.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxmini.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getwin.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ibfms.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ichkstr.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ifxy.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invcon.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invwin.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ipkm.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(irev.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupm.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lmsg.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrpc.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrps.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(newwin.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nmwrd.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nxtwin.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ovrbs1.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(padmsg.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkb.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkbs1.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkc.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pktdd.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs01.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs1.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdcmps.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdtree.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdusdx.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readmg.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(seqsdx.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(stndrd.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(string.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strnum.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strsuc.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(trybump.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upbb.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upc.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(usrtpl.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(capit.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrna.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrn.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cktaba.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cnved4.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(digit.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(elemdx.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getlens.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(gets1loc.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(i4dy.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(idn30.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(igetdate.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(istdesc.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupb.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupbs01.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstchr.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstnum.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstjpb.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(makestab.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(mvb.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemock.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtab.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbax.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenuaa.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenubd.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numbck.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtab.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbt.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parstr.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parusr.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parutg.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rcstpl.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgb.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(restd.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rsvfvm.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strcln.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabsub.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(uptdd.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdesc.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cadn30.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chekstab.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(inctab.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbb.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbd.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtbd.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabent.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(valx.o) - .note.GNU-stack - 0x0000000000000000 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rjust.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_preconnected_units_init.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_reentrancy.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_secnds.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_stop.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_vm.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wint_fmt.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_fmt.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_lis.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio_wrap.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_int.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_f.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_d.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_g.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cray.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_short.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_long.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_double.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_single.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close_proc.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_default_io_sizes_env_init.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_desc_item.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_diags_intel.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_exit.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_exit_handler.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_comp.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_get.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_intrp_fmt.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_ldir_wfs.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_lub_mgt.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_need_lf.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_put.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(tbk_traceback.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt__globals.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_int_to_text.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_data_to_text.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_log_to_text.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_data.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_log.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_t.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_s.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_x.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_s.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_t.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_s_to_a.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_t_to_a.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_s.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_t.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_x.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_x_to_a.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_x.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_globals.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_53.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_64.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_128.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(fetestexcept.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_stub.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_stub.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_ct.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_ct.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_gen.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_gen.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(libm_error.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherrf.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherrl.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherr.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ints2q.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(qcomp.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fp2q.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(q2fp.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_display.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_backtrace.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(cpu_feature_disp.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemcpy.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemmove.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemset.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(new_proc_init.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_addsubq.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_divq.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strcpy.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncpy.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strlen.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strchr.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncmp.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strcat.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncat.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_memcpy_pp.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_memset_pp.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memcpy.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memcpy.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memmove.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memmove.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(irc_msg_support.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_mem_ops.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(proc_init_utils.o) - .note.GNU-stack - 0x0000000000000000 0x0 /usr/lib64/libc_nonshared.a(elf-init.oS) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - .note.GNU-stack - 0x0000000000000000 0x0 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtend.o - .note.GNU-stack - 0x0000000000000000 0x0 /usr/lib/../lib64/crtn.o - -Memory Configuration - -Name Origin Length Attributes -*default* 0x0000000000000000 0xffffffffffffffff - -Linker script and memory map - -LOAD /usr/lib/../lib64/crt1.o -LOAD /usr/lib/../lib64/crti.o -LOAD /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtbegin.o -LOAD /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/for_main.o -LOAD rdbfmsua.o -LOAD /gpfs/hps/emc/global/noscrub/Boi.Vuong/lib_sorc/decod_ut/v1.0.0/intel/libdecod_ut_v1.0.0.a -LOAD /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a -LOAD /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libappl.a -LOAD /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libsyslib.a -LOAD /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libcgemlib.a -LOAD /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libbridge.a -LOAD /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a -LOAD /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/../../../../lib64/libgfortran.so -LOAD /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifport.a -LOAD /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a -LOAD /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a -LOAD /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libsvml.a -LOAD /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libm.a -LOAD /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libipgo.a -LOAD /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a -LOAD /usr/lib/../lib64/libpthread.so -START GROUP -LOAD /lib64/libpthread.so.0 -LOAD /usr/lib64/libpthread_nonshared.a -END GROUP -LOAD /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libsvml.a -LOAD /usr/lib/../lib64/libc.so -START GROUP -LOAD /lib64/libc.so.6 -LOAD /usr/lib64/libc_nonshared.a -LOAD /lib64/ld-linux-x86-64.so.2 -END GROUP -LOAD /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a -LOAD /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/../../../../lib64/libgcc_s.so -LOAD /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc_s.a -LOAD /usr/lib/../lib64/libdl.so -LOAD /usr/lib/../lib64/libc.so -START GROUP -LOAD /lib64/libc.so.6 -LOAD /usr/lib64/libc_nonshared.a -LOAD /lib64/ld-linux-x86-64.so.2 -END GROUP -LOAD /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtend.o -LOAD /usr/lib/../lib64/crtn.o - 0x0000000000400000 PROVIDE (__executable_start, 0x400000) - 0x0000000000400238 . = (0x400000 + SIZEOF_HEADERS) - -.interp 0x0000000000400238 0x1c - *(.interp) - .interp 0x0000000000400238 0x1c /usr/lib/../lib64/crt1.o - -.note.ABI-tag 0x0000000000400254 0x20 - .note.ABI-tag 0x0000000000400254 0x20 /usr/lib/../lib64/crt1.o - -.note.SuSE 0x0000000000400274 0x18 - .note.SuSE 0x0000000000400274 0x18 /usr/lib/../lib64/crt1.o - -.note.gnu.build-id - 0x000000000040028c 0x24 - *(.note.gnu.build-id) - .note.gnu.build-id - 0x000000000040028c 0x24 /usr/lib/../lib64/crt1.o - -.hash 0x00000000004002b0 0x494 - *(.hash) - .hash 0x00000000004002b0 0x494 /usr/lib/../lib64/crt1.o - -.gnu.hash 0x0000000000400748 0x170 - *(.gnu.hash) - .gnu.hash 0x0000000000400748 0x170 /usr/lib/../lib64/crt1.o - -.dynsym 0x00000000004008b8 0xf00 - *(.dynsym) - .dynsym 0x00000000004008b8 0xf00 /usr/lib/../lib64/crt1.o - -.dynstr 0x00000000004017b8 0x87d - *(.dynstr) - .dynstr 0x00000000004017b8 0x87d /usr/lib/../lib64/crt1.o - -.gnu.version 0x0000000000402036 0x140 - *(.gnu.version) - .gnu.version 0x0000000000402036 0x140 /usr/lib/../lib64/crt1.o - -.gnu.version_d 0x0000000000402178 0x0 - *(.gnu.version_d) - .gnu.version_d - 0x0000000000000000 0x0 /usr/lib/../lib64/crt1.o - -.gnu.version_r 0x0000000000402178 0xd0 - *(.gnu.version_r) - .gnu.version_r - 0x0000000000402178 0xd0 /usr/lib/../lib64/crt1.o - -.rela.dyn 0x0000000000402248 0x438 - *(.rela.init) - *(.rela.text .rela.text.* .rela.gnu.linkonce.t.*) - .rela.text 0x0000000000000000 0x0 /usr/lib/../lib64/crt1.o - .rela.text.ssse3 - 0x0000000000000000 0x0 /usr/lib/../lib64/crt1.o - *(.rela.fini) - *(.rela.rodata .rela.rodata.* .rela.gnu.linkonce.r.*) - .rela.rodata 0x0000000000000000 0x0 /usr/lib/../lib64/crt1.o - *(.rela.data .rela.data.* .rela.gnu.linkonce.d.*) - .rela.data 0x0000000000000000 0x0 /usr/lib/../lib64/crt1.o - *(.rela.tdata .rela.tdata.* .rela.gnu.linkonce.td.*) - *(.rela.tbss .rela.tbss.* .rela.gnu.linkonce.tb.*) - *(.rela.ctors) - *(.rela.dtors) - *(.rela.got) - .rela.got 0x0000000000402248 0x3f0 /usr/lib/../lib64/crt1.o - *(.rela.bss .rela.bss.* .rela.gnu.linkonce.b.*) - .rela.bss 0x0000000000402638 0x48 /usr/lib/../lib64/crt1.o - *(.rela.ldata .rela.ldata.* .rela.gnu.linkonce.l.*) - *(.rela.lbss .rela.lbss.* .rela.gnu.linkonce.lb.*) - *(.rela.lrodata .rela.lrodata.* .rela.gnu.linkonce.lr.*) - *(.rela.ifunc) - -.rela.plt 0x0000000000402680 0xa80 - *(.rela.plt) - .rela.plt 0x0000000000402680 0xa80 /usr/lib/../lib64/crt1.o - 0x0000000000403100 PROVIDE (__rela_iplt_start, .) - *(.rela.iplt) - .rela.iplt 0x0000000000000000 0x0 /usr/lib/../lib64/crt1.o - 0x0000000000403100 PROVIDE (__rela_iplt_end, .) - -.init 0x0000000000403100 0x18 - *(SORT(.init)) - .init 0x0000000000403100 0x9 /usr/lib/../lib64/crti.o - 0x0000000000403100 _init - .init 0x0000000000403109 0x5 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtbegin.o - .init 0x000000000040310e 0x5 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtend.o - .init 0x0000000000403113 0x5 /usr/lib/../lib64/crtn.o - -.plt 0x0000000000403120 0x710 - *(.plt) - .plt 0x0000000000403120 0x710 /usr/lib/../lib64/crt1.o - 0x0000000000403130 fileno@@GLIBC_2.2.5 - 0x0000000000403140 printf@@GLIBC_2.2.5 - 0x0000000000403150 _gfortran_transfer_character_write@@GFORTRAN_1.4 - 0x0000000000403160 _Unwind_GetRegionStart@@GCC_3.0 - 0x0000000000403170 memset@@GLIBC_2.2.5 - 0x0000000000403180 ftell@@GLIBC_2.2.5 - 0x0000000000403190 snprintf@@GLIBC_2.2.5 - 0x00000000004031a0 _gfortran_st_open@@GFORTRAN_1.0 - 0x00000000004031b0 posix_memalign@@GLIBC_2.2.5 - 0x00000000004031c0 _gfortran_st_write_done@@GFORTRAN_1.0 - 0x00000000004031d0 close@@GLIBC_2.2.5 - 0x00000000004031e0 abort@@GLIBC_2.2.5 - 0x00000000004031f0 ttyname@@GLIBC_2.2.5 - 0x0000000000403200 memchr@@GLIBC_2.2.5 - 0x0000000000403210 strncat@@GLIBC_2.2.5 - 0x0000000000403220 getrusage@@GLIBC_2.2.5 - 0x0000000000403230 isatty@@GLIBC_2.2.5 - 0x0000000000403240 puts@@GLIBC_2.2.5 - 0x0000000000403250 uname@@GLIBC_2.2.5 - 0x0000000000403260 fseek@@GLIBC_2.2.5 - 0x0000000000403270 exit@@GLIBC_2.2.5 - 0x0000000000403280 gettimeofday@@GLIBC_2.2.5 - 0x0000000000403290 _gfortran_st_inquire@@GFORTRAN_1.0 - 0x00000000004032a0 read@@GLIBC_2.2.5 - 0x00000000004032b0 malloc@@GLIBC_2.2.5 - 0x00000000004032c0 fopen@@GLIBC_2.2.5 - 0x00000000004032d0 __libc_start_main@@GLIBC_2.2.5 - 0x00000000004032e0 system@@GLIBC_2.2.5 - 0x00000000004032f0 unlink@@GLIBC_2.2.5 - 0x0000000000403300 siglongjmp@@GLIBC_2.2.5 - 0x0000000000403310 catgets@@GLIBC_2.2.5 - 0x0000000000403320 sysconf@@GLIBC_2.2.5 - 0x0000000000403330 getpid@@GLIBC_2.2.5 - 0x0000000000403340 catclose@@GLIBC_2.2.5 - 0x0000000000403350 fgets@@GLIBC_2.2.5 - 0x0000000000403360 __fxstat64@@GLIBC_2.2.5 - 0x0000000000403370 freopen64@@GLIBC_2.2.5 - 0x0000000000403380 free@@GLIBC_2.2.5 - 0x0000000000403390 strlen@@GLIBC_2.2.5 - 0x00000000004033a0 _gfortran_st_read_done@@GFORTRAN_1.0 - 0x00000000004033b0 vsprintf@@GLIBC_2.2.5 - 0x00000000004033c0 opendir@@GLIBC_2.2.5 - 0x00000000004033d0 __xpg_basename@@GLIBC_2.2.5 - 0x00000000004033e0 mkstemp64@@GLIBC_2.2.5 - 0x00000000004033f0 __ctype_b_loc@@GLIBC_2.3 - 0x0000000000403400 _gfortran_concat_string@@GFORTRAN_1.0 - 0x0000000000403410 sprintf@@GLIBC_2.2.5 - 0x0000000000403420 strrchr@@GLIBC_2.2.5 - 0x0000000000403430 _Unwind_GetIP@@GCC_3.0 - 0x0000000000403440 atol@@GLIBC_2.2.5 - 0x0000000000403450 _Unwind_Backtrace@@GCC_3.3 - 0x0000000000403460 sscanf@@GLIBC_2.2.5 - 0x0000000000403470 _gfortran_transfer_integer@@GFORTRAN_1.0 - 0x0000000000403480 _gfortran_st_close@@GFORTRAN_1.0 - 0x0000000000403490 _gfortran_st_backspace@@GFORTRAN_1.0 - 0x00000000004034a0 kill@@GLIBC_2.2.5 - 0x00000000004034b0 strerror@@GLIBC_2.2.5 - 0x00000000004034c0 open64@@GLIBC_2.2.5 - 0x00000000004034d0 strstr@@GLIBC_2.2.5 - 0x00000000004034e0 sigprocmask@@GLIBC_2.2.5 - 0x00000000004034f0 _gfortran_transfer_array_write@@GFORTRAN_1.4 - 0x0000000000403500 sigaction@@GLIBC_2.2.5 - 0x0000000000403510 strcat@@GLIBC_2.2.5 - 0x0000000000403520 fputs@@GLIBC_2.2.5 - 0x0000000000403530 _Unwind_ForcedUnwind@@GCC_3.0 - 0x0000000000403540 ftruncate64@@GLIBC_2.2.5 - 0x0000000000403550 readlink@@GLIBC_2.2.5 - 0x0000000000403560 _gfortran_transfer_character@@GFORTRAN_1.0 - 0x0000000000403570 memcpy@@GLIBC_2.2.5 - 0x0000000000403580 raise@@GLIBC_2.2.5 - 0x0000000000403590 signal@@GLIBC_2.2.5 - 0x00000000004035a0 _gfortran_getenv@@GFORTRAN_1.0 - 0x00000000004035b0 memmove@@GLIBC_2.2.5 - 0x00000000004035c0 strchr@@GLIBC_2.2.5 - 0x00000000004035d0 vsnprintf@@GLIBC_2.2.5 - 0x00000000004035e0 fread@@GLIBC_2.2.5 - 0x00000000004035f0 setenv@@GLIBC_2.2.5 - 0x0000000000403600 catopen@@GLIBC_2.2.5 - 0x0000000000403610 getenv@@GLIBC_2.2.5 - 0x0000000000403620 _gfortran_transfer_integer_write@@GFORTRAN_1.4 - 0x0000000000403630 _gfortran_st_write@@GFORTRAN_1.0 - 0x0000000000403640 __errno_location@@GLIBC_2.2.5 - 0x0000000000403650 strcmp@@GLIBC_2.2.5 - 0x0000000000403660 getcwd@@GLIBC_2.2.5 - 0x0000000000403670 strcpy@@GLIBC_2.2.5 - 0x0000000000403680 nanosleep@@GLIBC_2.2.5 - 0x0000000000403690 _gfortran_string_index@@GFORTRAN_1.0 - 0x00000000004036a0 dladdr@@GLIBC_2.2.5 - 0x00000000004036b0 __ctype_tolower_loc@@GLIBC_2.3 - 0x00000000004036c0 memcmp@@GLIBC_2.2.5 - 0x00000000004036d0 _gfortran_st_rewind@@GFORTRAN_1.0 - 0x00000000004036e0 _gfortran_st_read@@GFORTRAN_1.0 - 0x00000000004036f0 feof@@GLIBC_2.2.5 - 0x0000000000403700 fclose@@GLIBC_2.2.5 - 0x0000000000403710 strncpy@@GLIBC_2.2.5 - 0x0000000000403720 __xstat64@@GLIBC_2.2.5 - 0x0000000000403730 lseek64@@GLIBC_2.2.5 - 0x0000000000403740 dlsym@@GLIBC_2.2.5 - 0x0000000000403750 closedir@@GLIBC_2.2.5 - 0x0000000000403760 access@@GLIBC_2.2.5 - 0x0000000000403770 sigemptyset@@GLIBC_2.2.5 - 0x0000000000403780 _gfortran_transfer_real@@GFORTRAN_1.0 - 0x0000000000403790 fopen64@@GLIBC_2.2.5 - 0x00000000004037a0 _gfortran_compare_string@@GFORTRAN_1.0 - 0x00000000004037b0 realloc@@GLIBC_2.2.5 - 0x00000000004037c0 perror@@GLIBC_2.2.5 - 0x00000000004037d0 __sigsetjmp@@GLIBC_2.2.5 - 0x00000000004037e0 fprintf@@GLIBC_2.2.5 - 0x00000000004037f0 localtime@@GLIBC_2.2.5 - 0x0000000000403800 write@@GLIBC_2.2.5 - 0x0000000000403810 _gfortran_pow_i4_i4@@GFORTRAN_1.0 - 0x0000000000403820 fcntl@@GLIBC_2.2.5 - *(.iplt) - .iplt 0x0000000000000000 0x0 /usr/lib/../lib64/crt1.o - -.text 0x0000000000403830 0xb2738 - *(.text.unlikely .text.*_unlikely) - .text.unlikely - 0x0000000000403830 0x0 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtbegin.o - .text.unlikely - 0x0000000000403830 0x0 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - .text.unlikely - 0x0000000000403830 0x0 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtend.o - *(.text.exit .text.exit.*) - *(.text.startup .text.startup.*) - *(.text.hot .text.hot.*) - *(.text .stub .text.* .gnu.linkonce.t.*) - .text 0x0000000000403830 0x2c /usr/lib/../lib64/crt1.o - 0x0000000000403830 _start - .text 0x000000000040385c 0x17 /usr/lib/../lib64/crti.o - *fill* 0x0000000000403873 0xd - .text 0x0000000000403880 0x116 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtbegin.o - *fill* 0x0000000000403996 0xa - .text 0x00000000004039a0 0x40 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/for_main.o - 0x00000000004039a0 main - .text 0x00000000004039e0 0x1920 rdbfmsua.o - 0x00000000004039e0 MAIN__ - .text 0x0000000000405300 0x82 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flclos.o) - 0x0000000000405300 fl_clos_ - *fill* 0x0000000000405382 0x2 - .text 0x0000000000405384 0x4d /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flflun.o) - 0x0000000000405384 fl_flun_ - *fill* 0x00000000004053d1 0x3 - .text 0x00000000004053d4 0x13e /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltbop.o) - 0x00000000004053d4 fl_tbop_ - *fill* 0x0000000000405512 0x2 - .text 0x0000000000405514 0x155 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltdat.o) - 0x0000000000405514 fl_tdat_ - *fill* 0x0000000000405669 0x3 - .text 0x000000000040566c 0xd4a /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltinq.o) - 0x000000000040566c fl_tinq_ - *fill* 0x00000000004063b6 0x2 - .text 0x00000000004063b8 0x332 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stldsp.o) - 0x00000000004063b8 st_ldsp_ - *fill* 0x00000000004066ea 0x2 - .text 0x00000000004066ec 0x9b /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlstr.o) - 0x00000000004066ec st_lstr_ - *fill* 0x0000000000406787 0x1 - .text 0x0000000000406788 0x28e /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmbl.o) - 0x0000000000406788 st_rmbl_ - *fill* 0x0000000000406a16 0x2 - .text 0x0000000000406a18 0x576 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmst.o) - 0x0000000000406a18 st_rmst_ - *fill* 0x0000000000406f8e 0x2 - .text 0x0000000000406f90 0x560 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbrstn.o) - 0x0000000000406f90 tb_rstn_ - .text 0x00000000004074f0 0x6a /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flbksp.o) - 0x00000000004074f0 fl_bksp_ - *fill* 0x000000000040755a 0x2 - .text 0x000000000040755c 0x5c5 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flinqr.o) - 0x000000000040755c fl_inqr_ - *fill* 0x0000000000407b21 0x3 - .text 0x0000000000407b24 0x31c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flpath.o) - 0x0000000000407b24 fl_path_ - .text 0x0000000000407e40 0x230 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flsopn.o) - 0x0000000000407e40 fl_sopn_ - .text 0x0000000000408070 0x78f /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssenvr.o) - 0x0000000000408070 ss_envr_ - *fill* 0x00000000004087ff 0x1 - .text 0x0000000000408800 0x13b /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssgsym.o) - 0x0000000000408800 ss_gsym_ - *fill* 0x000000000040893b 0x1 - .text 0x000000000040893c 0x146 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlcuc.o) - 0x000000000040893c st_lcuc_ - *fill* 0x0000000000408a82 0x2 - .text 0x0000000000408a84 0x146 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stuclc.o) - 0x0000000000408a84 st_uclc_ - *fill* 0x0000000000408bca 0x2 - .text 0x0000000000408bcc 0xb03 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbastn.o) - 0x0000000000408bcc tb_astn_ - *fill* 0x00000000004096cf 0x1 - .text 0x00000000004096d0 0x89 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flglun.o) - 0x00000000004096d0 fl_glun_ - *fill* 0x0000000000409759 0x3 - .text 0x000000000040975c 0x181 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libbridge.a(dcbsrh.o) - 0x000000000040975c dc_bsrh_ - *fill* 0x00000000004098dd 0x3 - .text 0x00000000004098e0 0x45 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ireadns.o) - 0x00000000004098e0 ireadns_ - *fill* 0x0000000000409925 0x3 - .text 0x0000000000409928 0xe23 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) - 0x0000000000409928 openbf_ - *fill* 0x000000000040a74b 0x1 - .text 0x000000000040a74c 0x10c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapn.o) - 0x000000000040a74c posapn_ - .text 0x000000000040a858 0x135 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapx.o) - 0x000000000040a858 posapx_ - *fill* 0x000000000040a98d 0x3 - .text 0x000000000040a990 0x1ff /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgw.o) - 0x000000000040a990 rdmsgw_ - *fill* 0x000000000040ab8f 0x1 - .text 0x000000000040ab90 0x3e9 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readdx.o) - 0x000000000040ab90 readdx_ - *fill* 0x000000000040af79 0x3 - .text 0x000000000040af7c 0x12a /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readns.o) - 0x000000000040af7c readns_ - *fill* 0x000000000040b0a6 0x2 - .text 0x000000000040b0a8 0x390 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) - 0x000000000040b0a8 readsb_ - .text 0x000000000040b438 0x223 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(status.o) - 0x000000000040b438 status_ - *fill* 0x000000000040b65b 0x1 - .text 0x000000000040b65c 0xfd2 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) - 0x000000000040b65c ufbint_ - *fill* 0x000000000040c62e 0x2 - .text 0x000000000040c630 0xab2 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) - 0x000000000040c630 ufbrw_ - *fill* 0x000000000040d0e2 0x2 - .text 0x000000000040d0e4 0x1b4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upb.o) - 0x000000000040d0e4 upb_ - .text 0x000000000040d298 0x1276 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdlen.o) - 0x000000000040d298 wrdlen_ - *fill* 0x000000000040e50e 0x2 - .text 0x000000000040e510 0xa79 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) - 0x000000000040e510 writdx_ - *fill* 0x000000000040ef89 0x3 - .text 0x000000000040ef8c 0x4ff /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wtstat.o) - 0x000000000040ef8c wtstat_ - *fill* 0x000000000040f48b 0x1 - .text 0x000000000040f48c 0x484 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(adn30.o) - 0x000000000040f48c adn30_ - .text 0x000000000040f910 0x638 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) - 0x000000000040f910 bfrini_ - .text 0x000000000040ff48 0x26d /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort2.o) - 0x000000000040ff48 bort2_ - *fill* 0x00000000004101b5 0x3 - .text 0x00000000004101b8 0xe /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort_exit.o) - 0x00000000004101b8 bort_exit_ - *fill* 0x00000000004101c6 0x2 - .text 0x00000000004101c8 0x1e8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort.o) - 0x00000000004101c8 bort_ - .text 0x00000000004103b0 0x1f6 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(conwin.o) - 0x00000000004103b0 conwin_ - *fill* 0x00000000004105a6 0x2 - .text 0x00000000004105a8 0x48b /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cpbfdx.o) - 0x00000000004105a8 cpbfdx_ - *fill* 0x0000000000410a33 0x1 - .text 0x0000000000410a34 0x159 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(drstpl.o) - 0x0000000000410a34 drstpl_ - *fill* 0x0000000000410b8d 0x3 - .text 0x0000000000410b90 0xa44 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxinit.o) - 0x0000000000410b90 dxinit_ - .text 0x00000000004115d4 0x83e /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxmini.o) - 0x00000000004115d4 dxmini_ - *fill* 0x0000000000411e12 0x2 - .text 0x0000000000411e14 0x318 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getwin.o) - 0x0000000000411e14 getwin_ - .text 0x000000000041212c 0x67 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ibfms.o) - 0x000000000041212c ibfms_ - *fill* 0x0000000000412193 0x1 - .text 0x0000000000412194 0xec /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ichkstr.o) - 0x0000000000412194 ichkstr_ - .text 0x0000000000412280 0x107 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ifxy.o) - 0x0000000000412280 ifxy_ - *fill* 0x0000000000412387 0x1 - .text 0x0000000000412388 0x509 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invcon.o) - 0x0000000000412388 invcon_ - *fill* 0x0000000000412891 0x3 - .text 0x0000000000412894 0x279 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invwin.o) - 0x0000000000412894 invwin_ - *fill* 0x0000000000412b0d 0x3 - .text 0x0000000000412b10 0x1cf /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ipkm.o) - 0x0000000000412b10 ipkm_ - *fill* 0x0000000000412cdf 0x1 - .text 0x0000000000412ce0 0x6e /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(irev.o) - 0x0000000000412ce0 irev_ - *fill* 0x0000000000412d4e 0x2 - .text 0x0000000000412d50 0x196 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupm.o) - 0x0000000000412d50 iupm_ - *fill* 0x0000000000412ee6 0x2 - .text 0x0000000000412ee8 0x40 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lmsg.o) - 0x0000000000412ee8 lmsg_ - .text 0x0000000000412f28 0x362 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrpc.o) - 0x0000000000412f28 lstrpc_ - *fill* 0x000000000041328a 0x2 - .text 0x000000000041328c 0x362 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrps.o) - 0x000000000041328c lstrps_ - *fill* 0x00000000004135ee 0x2 - .text 0x00000000004135f0 0x995 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) - 0x00000000004135f0 msgwrt_ - *fill* 0x0000000000413f85 0x3 - .text 0x0000000000413f88 0x226 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(newwin.o) - 0x0000000000413f88 newwin_ - *fill* 0x00000000004141ae 0x2 - .text 0x00000000004141b0 0x63 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nmwrd.o) - 0x00000000004141b0 nmwrd_ - *fill* 0x0000000000414213 0x1 - .text 0x0000000000414214 0x2ae /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nxtwin.o) - 0x0000000000414214 nxtwin_ - *fill* 0x00000000004144c2 0x2 - .text 0x00000000004144c4 0x331 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ovrbs1.o) - 0x00000000004144c4 ovrbs1_ - *fill* 0x00000000004147f5 0x3 - .text 0x00000000004147f8 0xd6 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(padmsg.o) - 0x00000000004147f8 padmsg_ - *fill* 0x00000000004148ce 0x2 - .text 0x00000000004148d0 0x349 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkb.o) - 0x00000000004148d0 pkb_ - *fill* 0x0000000000414c19 0x3 - .text 0x0000000000414c1c 0x44f /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkbs1.o) - 0x0000000000414c1c pkbs1_ - *fill* 0x000000000041506b 0x1 - .text 0x000000000041506c 0x3d9 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkc.o) - 0x000000000041506c pkc_ - *fill* 0x0000000000415445 0x3 - .text 0x0000000000415448 0x4d3 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pktdd.o) - 0x0000000000415448 pktdd_ - *fill* 0x000000000041591b 0x1 - .text 0x000000000041591c 0x2a8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs01.o) - 0x000000000041591c pkvs01_ - .text 0x0000000000415bc4 0x39d /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs1.o) - 0x0000000000415bc4 pkvs1_ - *fill* 0x0000000000415f61 0x3 - .text 0x0000000000415f64 0x14fe /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) - 0x0000000000415f64 rdbfdx_ - *fill* 0x0000000000417462 0x2 - .text 0x0000000000417464 0x519 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdcmps.o) - 0x0000000000417464 rdcmps_ - *fill* 0x000000000041797d 0x3 - .text 0x0000000000417980 0x40d /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdtree.o) - 0x0000000000417980 rdtree_ - *fill* 0x0000000000417d8d 0x3 - .text 0x0000000000417d90 0x1989 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdusdx.o) - 0x0000000000417d90 rdusdx_ - *fill* 0x0000000000419719 0x3 - .text 0x000000000041971c 0x27f /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readmg.o) - 0x000000000041971c readmg_ - *fill* 0x000000000041999b 0x1 - .text 0x000000000041999c 0x1da9 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(seqsdx.o) - 0x000000000041999c seqsdx_ - *fill* 0x000000000041b745 0x3 - .text 0x000000000041b748 0x984 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(stndrd.o) - 0x000000000041b748 stndrd_ - .text 0x000000000041c0cc 0x7af /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(string.o) - 0x000000000041c0cc string_ - *fill* 0x000000000041c87b 0x1 - .text 0x000000000041c87c 0x36b /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strnum.o) - 0x000000000041c87c strnum_ - *fill* 0x000000000041cbe7 0x1 - .text 0x000000000041cbe8 0x39b /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strsuc.o) - 0x000000000041cbe8 strsuc_ - *fill* 0x000000000041cf83 0x1 - .text 0x000000000041cf84 0x2ef /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(trybump.o) - 0x000000000041cf84 trybump_ - *fill* 0x000000000041d273 0x1 - .text 0x000000000041d274 0x1a0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upbb.o) - 0x000000000041d274 upbb_ - .text 0x000000000041d414 0x11c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upc.o) - 0x000000000041d414 upc_ - .text 0x000000000041d530 0x1abd /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(usrtpl.o) - 0x000000000041d530 usrtpl_ - *fill* 0x000000000041efed 0x3 - .text 0x000000000041eff0 0xa6 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(capit.o) - 0x000000000041eff0 capit_ - *fill* 0x000000000041f096 0x2 - .text 0x000000000041f098 0x110 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrna.o) - 0x000000000041f098 chrtrna_ - .text 0x000000000041f1a8 0x99 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrn.o) - 0x000000000041f1a8 chrtrn_ - *fill* 0x000000000041f241 0x3 - .text 0x000000000041f244 0xfe6 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cktaba.o) - 0x000000000041f244 cktaba_ - *fill* 0x000000000042022a 0x2 - .text 0x000000000042022c 0x69d /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cnved4.o) - 0x000000000042022c cnved4_ - *fill* 0x00000000004208c9 0x3 - .text 0x00000000004208cc 0x6f /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(digit.o) - 0x00000000004208cc digit_ - *fill* 0x000000000042093b 0x1 - .text 0x000000000042093c 0xadb /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(elemdx.o) - 0x000000000042093c elemdx_ - *fill* 0x0000000000421417 0x1 - .text 0x0000000000421418 0x1e4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getlens.o) - 0x0000000000421418 getlens_ - .text 0x00000000004215fc 0x57a /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(gets1loc.o) - 0x00000000004215fc gets1loc_ - *fill* 0x0000000000421b76 0x2 - .text 0x0000000000421b78 0x6b /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(i4dy.o) - 0x0000000000421b78 i4dy_ - *fill* 0x0000000000421be3 0x1 - .text 0x0000000000421be4 0x3f3 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(idn30.o) - 0x0000000000421be4 idn30_ - *fill* 0x0000000000421fd7 0x1 - .text 0x0000000000421fd8 0x110 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(igetdate.o) - 0x0000000000421fd8 igetdate_ - .text 0x00000000004220e8 0x14a /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(istdesc.o) - 0x00000000004220e8 istdesc_ - *fill* 0x0000000000422232 0x2 - .text 0x0000000000422234 0x4b /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupb.o) - 0x0000000000422234 iupb_ - *fill* 0x000000000042227f 0x1 - .text 0x0000000000422280 0x26e /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupbs01.o) - 0x0000000000422280 iupbs01_ - *fill* 0x00000000004224ee 0x2 - .text 0x00000000004224f0 0xff /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstchr.o) - 0x00000000004224f0 jstchr_ - *fill* 0x00000000004225ef 0x1 - .text 0x00000000004225f0 0x51d /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstnum.o) - 0x00000000004225f0 jstnum_ - *fill* 0x0000000000422b0d 0x3 - .text 0x0000000000422b10 0x38b /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstjpb.o) - 0x0000000000422b10 lstjpb_ - *fill* 0x0000000000422e9b 0x1 - .text 0x0000000000422e9c 0x14fe /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(makestab.o) - 0x0000000000422e9c makestab_ - *fill* 0x000000000042439a 0x2 - .text 0x000000000042439c 0x20c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(mvb.o) - 0x000000000042439c mvb_ - .text 0x00000000004245a8 0xf2 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemock.o) - 0x00000000004245a8 nemock_ - *fill* 0x000000000042469a 0x2 - .text 0x000000000042469c 0x496 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtab.o) - 0x000000000042469c nemtab_ - *fill* 0x0000000000424b32 0x2 - .text 0x0000000000424b34 0x396 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbax.o) - 0x0000000000424b34 nemtbax_ - *fill* 0x0000000000424eca 0x2 - .text 0x0000000000424ecc 0x28a /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenuaa.o) - 0x0000000000424ecc nenuaa_ - *fill* 0x0000000000425156 0x2 - .text 0x0000000000425158 0x4d2 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenubd.o) - 0x0000000000425158 nenubd_ - *fill* 0x000000000042562a 0x2 - .text 0x000000000042562c 0x17b /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numbck.o) - 0x000000000042562c numbck_ - *fill* 0x00000000004257a7 0x1 - .text 0x00000000004257a8 0x637 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtab.o) - 0x00000000004257a8 numtab_ - *fill* 0x0000000000425ddf 0x1 - .text 0x0000000000425de0 0x217 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbt.o) - 0x0000000000425de0 openbt_ - *fill* 0x0000000000425ff7 0x1 - .text 0x0000000000425ff8 0x739 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parstr.o) - 0x0000000000425ff8 parstr_ - *fill* 0x0000000000426731 0x3 - .text 0x0000000000426734 0x1044 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parusr.o) - 0x0000000000426734 parusr_ - .text 0x0000000000427778 0x8d9 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parutg.o) - 0x0000000000427778 parutg_ - *fill* 0x0000000000428051 0x3 - .text 0x0000000000428054 0x8cf /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rcstpl.o) - 0x0000000000428054 rcstpl_ - *fill* 0x0000000000428923 0x1 - .text 0x0000000000428924 0x1ed /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgb.o) - 0x0000000000428924 rdmsgb_ - *fill* 0x0000000000428b11 0x3 - .text 0x0000000000428b14 0x4e2 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(restd.o) - 0x0000000000428b14 restd_ - *fill* 0x0000000000428ff6 0x2 - .text 0x0000000000428ff8 0x7c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rsvfvm.o) - 0x0000000000428ff8 rsvfvm_ - .text 0x0000000000429074 0x25 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strcln.o) - 0x0000000000429074 strcln_ - *fill* 0x0000000000429099 0x3 - .text 0x000000000042909c 0xe9b /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabsub.o) - 0x000000000042909c tabsub_ - *fill* 0x0000000000429f37 0x1 - .text 0x0000000000429f38 0x227 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(uptdd.o) - 0x0000000000429f38 uptdd_ - *fill* 0x000000000042a15f 0x1 - .text 0x000000000042a160 0xa8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdesc.o) - 0x000000000042a160 wrdesc_ - .text 0x000000000042a208 0x9f /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cadn30.o) - 0x000000000042a208 cadn30_ - *fill* 0x000000000042a2a7 0x1 - .text 0x000000000042a2a8 0x368 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chekstab.o) - 0x000000000042a2a8 chekstab_ - .text 0x000000000042a610 0x2dd /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(inctab.o) - 0x000000000042a610 inctab_ - *fill* 0x000000000042a8ed 0x3 - .text 0x000000000042a8f0 0x86c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbb.o) - 0x000000000042a8f0 nemtbb_ - .text 0x000000000042b15c 0xaf0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbd.o) - 0x000000000042b15c nemtbd_ - .text 0x000000000042bc4c 0x314 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtbd.o) - 0x000000000042bc4c numtbd_ - .text 0x000000000042bf60 0x886 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabent.o) - 0x000000000042bf60 tabent_ - *fill* 0x000000000042c7e6 0x2 - .text 0x000000000042c7e8 0x609 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(valx.o) - 0x000000000042c7e8 valx_ - *fill* 0x000000000042cdf1 0x3 - .text 0x000000000042cdf4 0xaf /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rjust.o) - 0x000000000042cdf4 rjust_ - *fill* 0x000000000042cea3 0xd - .text 0x000000000042ceb0 0x2a50 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) - 0x000000000042ceb0 for__process_start_time - 0x000000000042ced0 for__signal_handler - 0x000000000042de20 for_enable_underflow - 0x000000000042de40 for_get_fpe_ - 0x000000000042e020 for_set_fpe_ - 0x000000000042e3a0 for_fpe_service - 0x000000000042e750 for_get_fpe_counts_ - 0x000000000042e7a0 for_rtl_finish_ - 0x000000000042e7c0 dump_dfil_exception_info - 0x000000000042f6a0 for_rtl_init_ - .text 0x000000000042f900 0x1120 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) - 0x000000000042f900 for__adjust_buffer - 0x000000000042fb50 for__lower_bound_index - 0x000000000042fba0 for__cvt_foreign_read - 0x00000000004300f0 for__cvt_foreign_write - 0x00000000004308f0 for__cvt_foreign_check - 0x0000000000430970 for_check_env_name - .text 0x0000000000430a20 0x5ca0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) - 0x0000000000430a20 SetEndian - 0x0000000000430e20 CheckStreamRecortType - 0x0000000000431300 CheckEndian - 0x0000000000431760 for_open - 0x0000000000432a80 for__update_reopen_keywords - 0x0000000000433a50 for__set_foreign_bits - 0x0000000000434d70 for__open_key - 0x0000000000435020 for__open_args - 0x00000000004357e0 for__find_iomsg - 0x0000000000435880 for__set_terminator_option - 0x0000000000435d80 for__set_conversion_option - 0x0000000000436190 for__is_special_device - 0x0000000000436340 for__open_default - .text 0x00000000004366c0 0x240 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_preconnected_units_init.o) - 0x00000000004366c0 for__preconnected_units_create - .text 0x0000000000436900 0x280 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_reentrancy.o) - 0x0000000000436900 for_set_reentrancy - 0x0000000000436920 for__reentrancy_cleanup - 0x00000000004369b0 for__disable_asynch_deliv_private - 0x00000000004369d0 for__enable_asynch_deliv_private - 0x00000000004369f0 for__once_private - 0x0000000000436a40 for__reentrancy_init - .text 0x0000000000436b80 0x870 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_secnds.o) - 0x0000000000436b80 for_since_epoch - 0x0000000000436c20 for_since_epoch_t - 0x0000000000436cc0 for_since_epoch_x - 0x0000000000436dc0 for_secnds - 0x0000000000436ed0 for_secnds_t - 0x0000000000436fe0 for_secnds_x - 0x0000000000437240 for_cpusec - 0x00000000004372d0 for_cpusec_t - 0x0000000000437350 for_cpusec_x - .text 0x00000000004373f0 0x2b50 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_stop.o) - 0x00000000004373f0 for_abort - 0x0000000000437eb0 for_stop_core_impl - 0x0000000000438a60 for_stop_core - 0x0000000000439590 for_stop - .text 0x0000000000439f40 0x1070 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_vm.o) - 0x0000000000439f40 for__set_signal_ops_during_vm - 0x0000000000439f80 for__get_vm - 0x000000000043a0c0 for__realloc_vm - 0x000000000043a1b0 for__free_vm - 0x000000000043a230 for_allocate - 0x000000000043a5a0 for_alloc_allocatable - 0x000000000043a920 for_deallocate - 0x000000000043aab0 for_dealloc_allocatable - 0x000000000043ac60 for_check_mult_overflow - 0x000000000043ad80 for_check_mult_overflow64 - 0x000000000043af00 for__spec_align_alloc - 0x000000000043afa0 for__spec_align_free - .text 0x000000000043afb0 0x39f0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wint_fmt.o) - 0x000000000043afb0 for_write_int_fmt - 0x000000000043c120 for_write_int_fmt_xmit - .text 0x000000000043e9a0 0x4b60 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_fmt.o) - 0x000000000043e9a0 for_write_seq_fmt - 0x0000000000440750 for_write_seq_fmt_xmit - 0x0000000000443330 for__write_args - .text 0x0000000000443500 0x6b90 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_lis.o) - 0x0000000000443500 ensure_one_leading_blank_before_data - 0x0000000000443910 for_write_seq_lis - 0x00000000004454f0 for_write_seq_lis_xmit - .text 0x000000000044a090 0x4f30 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) - 0x000000000044a090 for__aio_acquire_lun_fname - 0x000000000044a360 for__aio_release - 0x000000000044a430 for__aio_acquire_lun - 0x000000000044aca0 for__aio_release_lun - 0x000000000044b2c0 for__aio_destroy - 0x000000000044b760 for_asynchronous - 0x000000000044c7a0 for_waitid - 0x000000000044d640 for_wait - 0x000000000044e390 for__aio_check_unit - 0x000000000044e5d0 for__aio_error_handling - 0x000000000044ee00 for__aio_init - .text 0x000000000044efc0 0x5350 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) - 0x000000000044efc0 fname_from_piped_fd - 0x000000000044f200 for__reopen_file - 0x000000000044f2f0 for__compute_filename - 0x0000000000451a80 for__open_proc - 0x0000000000454300 for__decl_exit_hand - .text 0x0000000000454310 0xb0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio_wrap.o) - 0x0000000000454310 for__aio_pthread_self - 0x0000000000454320 for__aio_pthread_create - 0x0000000000454340 for__aio_pthread_cancel - 0x0000000000454350 for__aio_pthread_detach - 0x0000000000454360 for__aio_pthread_mutex_lock - 0x0000000000454370 for__aio_pthread_mutex_unlock - 0x0000000000454380 for__aio_pthread_cond_wait - 0x0000000000454390 for__aio_pthread_cond_signal - 0x00000000004543a0 for__aio_pthread_mutex_init - 0x00000000004543b0 for__aio_pthread_exit - .text 0x00000000004543c0 0xad0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_int.o) - 0x00000000004543c0 cvt_text_to_integer - 0x00000000004546e0 cvt_text_to_unsigned - 0x0000000000454910 cvt_text_to_integer64 - 0x0000000000454c40 cvt_text_to_unsigned64 - .text 0x0000000000454e90 0xd20 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_f.o) - 0x0000000000454e90 cvt_vax_f_to_ieee_single_ - 0x00000000004552f0 CVT_VAX_F_TO_IEEE_SINGLE - 0x0000000000455750 cvt_vax_f_to_ieee_single - .text 0x0000000000455bb0 0xf80 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_d.o) - 0x0000000000455bb0 cvt_vax_d_to_ieee_double_ - 0x00000000004560e0 CVT_VAX_D_TO_IEEE_DOUBLE - 0x0000000000456610 cvt_vax_d_to_ieee_double - .text 0x0000000000456b30 0xf20 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_g.o) - 0x0000000000456b30 cvt_vax_g_to_ieee_double_ - 0x0000000000457030 CVT_VAX_G_TO_IEEE_DOUBLE - 0x0000000000457530 cvt_vax_g_to_ieee_double - .text 0x0000000000457a50 0x1f40 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cray.o) - 0x0000000000457a50 cvt_cray_to_ieee_single_ - 0x0000000000457f20 CVT_CRAY_TO_IEEE_SINGLE - 0x00000000004583f0 cvt_cray_to_ieee_single - 0x00000000004588e0 cvt_cray_to_ieee_double_ - 0x0000000000458e60 CVT_CRAY_TO_IEEE_DOUBLE - 0x00000000004593e0 cvt_cray_to_ieee_double - .text 0x0000000000459990 0xd80 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_short.o) - 0x0000000000459990 cvt_ibm_short_to_ieee_single_ - 0x0000000000459e10 CVT_IBM_SHORT_TO_IEEE_SINGLE - 0x000000000045a290 cvt_ibm_short_to_ieee_single - .text 0x000000000045a710 0x1070 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_long.o) - 0x000000000045a710 cvt_ibm_long_to_ieee_double_ - 0x000000000045ac70 CVT_IBM_LONG_TO_IEEE_DOUBLE - 0x000000000045b1d0 cvt_ibm_long_to_ieee_double - .text 0x000000000045b780 0x4080 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_double.o) - 0x000000000045b780 cvt_ieee_double_to_cray_ - 0x000000000045bc00 CVT_IEEE_DOUBLE_TO_CRAY - 0x000000000045c080 cvt_ieee_double_to_cray - 0x000000000045c500 cvt_ieee_double_to_ibm_long_ - 0x000000000045c9c0 CVT_IEEE_DOUBLE_TO_IBM_LONG - 0x000000000045ce80 cvt_ieee_double_to_ibm_long - 0x000000000045d360 cvt_ieee_double_to_vax_d_ - 0x000000000045d730 CVT_IEEE_DOUBLE_TO_VAX_D - 0x000000000045db00 cvt_ieee_double_to_vax_d - 0x000000000045df00 cvt_ieee_double_to_vax_g_ - 0x000000000045e2d0 CVT_IEEE_DOUBLE_TO_VAX_G - 0x000000000045e6a0 cvt_ieee_double_to_vax_g - 0x000000000045eaa0 cvt_ieee_double_to_vax_h_ - 0x000000000045ef10 CVT_IEEE_DOUBLE_TO_VAX_H - 0x000000000045f380 cvt_ieee_double_to_vax_h - .text 0x000000000045f800 0x1fe0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_single.o) - 0x000000000045f800 cvt_ieee_single_to_cray_ - 0x000000000045fba0 CVT_IEEE_SINGLE_TO_CRAY - 0x000000000045ff40 cvt_ieee_single_to_cray - 0x0000000000460300 cvt_ieee_single_to_ibm_short_ - 0x00000000004606f0 CVT_IEEE_SINGLE_TO_IBM_SHORT - 0x0000000000460ae0 cvt_ieee_single_to_ibm_short - 0x0000000000460ef0 cvt_ieee_single_to_vax_f_ - 0x00000000004611f0 CVT_IEEE_SINGLE_TO_VAX_F - 0x00000000004614f0 cvt_ieee_single_to_vax_f - .text 0x00000000004617e0 0x750 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close.o) - 0x00000000004617e0 for_close - 0x0000000000461ce0 for__close_args - 0x0000000000461e10 for__close_default - .text 0x0000000000461f30 0x6d0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close_proc.o) - 0x0000000000461f30 for__close_proc - .text 0x0000000000462600 0x220 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_default_io_sizes_env_init.o) - 0x0000000000462600 for__default_io_sizes_env_init - .text 0x0000000000462820 0xbd0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_desc_item.o) - 0x0000000000462820 for__desc_ret_item - 0x0000000000462b30 for__key_desc_ret_item - 0x0000000000462e60 for__desc_test_item - 0x0000000000463080 for__desc_zero_length_item - .text 0x00000000004633f0 0x4a50 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_diags_intel.o) - 0x00000000004633f0 for__this_image_number_or_zero - 0x0000000000463440 for__io_return - 0x0000000000464040 for__issue_diagnostic - 0x00000000004649e0 for__get_msg - 0x0000000000464ce0 for_emit_diagnostic - 0x0000000000464e50 for__message_catalog_close - 0x00000000004655b0 for_errmsg - 0x0000000000465770 for__rtc_uninit_use - 0x0000000000465790 for__rtc_uninit_use_src - 0x00000000004657b0 TRACEBACKQQ - 0x00000000004659f0 tracebackqq_ - 0x0000000000465c30 for_perror_ - 0x0000000000466e20 for_gerror_ - 0x0000000000467bc0 for__establish_user_error_handler - 0x0000000000467c00 for__continue_traceback_ - 0x0000000000467d20 for__continue_traceback - .text 0x0000000000467e40 0x20 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_exit.o) - 0x0000000000467e40 for_exit - .text 0x0000000000467e60 0x2f0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_exit_handler.o) - 0x0000000000467e60 for__fpe_exit_handler - 0x0000000000467f40 for__exit_handler - .text 0x0000000000468150 0x3320 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_comp.o) - 0x0000000000468150 for__format_compiler - .text 0x000000000046b470 0x1810 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) - 0x000000000046b470 for__format_value - 0x000000000046c1c0 for__cvt_value - .text 0x000000000046cc80 0x2490 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_get.o) - 0x000000000046cc80 for__get_s - 0x000000000046e050 for__read_input - 0x000000000046e170 for__get_d - 0x000000000046e520 for__get_su_fields - 0x000000000046ef30 for__get_more_fields - .text 0x000000000046f110 0xe80 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_intrp_fmt.o) - 0x000000000046f110 for__interp_fmt - .text 0x000000000046ff90 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_ldir_wfs.o) - .text 0x000000000046ff90 0x2540 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_lub_mgt.o) - 0x000000000046ff90 for__acquire_lun - 0x0000000000470e40 for__release_lun - 0x0000000000471160 for__create_lub - 0x0000000000471300 for__deallocate_lub - 0x0000000000471e30 for__get_next_lub - 0x00000000004722a0 for__get_free_newunit - 0x0000000000472470 for__release_newunit - .text 0x00000000004724d0 0x4e0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_need_lf.o) - 0x00000000004724d0 for__add_to_lf_table - 0x0000000000472930 for__rm_from_lf_table - .text 0x00000000004729b0 0x1ec0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_put.o) - 0x00000000004729b0 for__put_su - 0x0000000000473030 for__write_output - 0x0000000000473410 for__put_sf - 0x00000000004744d0 for__put_d - 0x0000000000474760 for__flush_readahead - .text 0x0000000000474870 0x6200 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq.o) - 0x0000000000474870 for_write_seq - 0x0000000000475f70 for_write_seq_xmit - 0x000000000047a610 for__finish_ufseq_write - .text 0x000000000047aa70 0x1360 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(tbk_traceback.o) - 0x000000000047bb70 tbk_stack_trace - .text 0x000000000047bdd0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt__globals.o) - .text 0x000000000047bdd0 0x7d0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_int_to_text.o) - 0x000000000047bdd0 cvt_integer_to_text - 0x000000000047bfc0 cvt_unsigned_to_text - 0x000000000047c1a0 cvt_integer64_to_text - 0x000000000047c3b0 cvt_unsigned64_to_text - .text 0x000000000047c5a0 0x780 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_data_to_text.o) - 0x000000000047c5a0 cvt_data_to_text - 0x000000000047c960 cvt_data64_to_text - .text 0x000000000047cd20 0x8d0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_log_to_text.o) - 0x000000000047cd20 cvt_boolean_to_text - 0x000000000047d020 cvt_boolean_to_text_ex - 0x000000000047d320 cvt_boolean64_to_text - .text 0x000000000047d5f0 0x570 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_data.o) - 0x000000000047d5f0 cvt_text_to_data - 0x000000000047d8d0 cvt_text_to_data64 - .text 0x000000000047db60 0x220 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_log.o) - 0x000000000047db60 cvt_text_to_boolean - 0x000000000047dc70 cvt_text_to_boolean64 - .text 0x000000000047dd80 0x2820 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_t.o) - 0x000000000047dd80 cvt_ieee_t_to_text_ex - 0x000000000047f0f0 cvt_ieee_t_to_text - 0x0000000000480410 cvt_text_to_ieee_t_ex - .text 0x00000000004805a0 0x2760 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_s.o) - 0x00000000004805a0 cvt_ieee_s_to_text_ex - 0x00000000004818b0 cvt_ieee_s_to_text - 0x0000000000482b70 cvt_text_to_ieee_s_ex - .text 0x0000000000482d00 0x1610 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_x.o) - 0x0000000000482d00 cvt_ieee_x_to_text - 0x0000000000482d50 cvt_ieee_x_to_text_ex - 0x0000000000484180 cvt_text_to_ieee_x_ex - .text 0x0000000000484310 0x1660 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_s.o) - 0x0000000000484310 cvtas_a_to_s - .text 0x0000000000485970 0x2bb0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_t.o) - 0x0000000000485970 cvtas_a_to_t - .text 0x0000000000488520 0x53f0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_s_to_a.o) - 0x0000000000488520 cvtas_s_to_a - .text 0x000000000048d910 0x5530 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_t_to_a.o) - 0x000000000048d910 cvtas_t_to_a - .text 0x0000000000492e40 0xd0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_s.o) - 0x0000000000492e40 cvtas__nan_s - .text 0x0000000000492f10 0xc0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_t.o) - 0x0000000000492f10 cvtas__nan_t - .text 0x0000000000492fd0 0x5270 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_x.o) - 0x0000000000492fd0 cvtas_a_to_x - .text 0x0000000000498240 0x5750 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_x_to_a.o) - 0x0000000000498240 cvtas_x_to_a - .text 0x000000000049d990 0xf0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_x.o) - 0x000000000049d990 cvtas__nan_x - .text 0x000000000049da80 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_globals.o) - .text 0x000000000049da80 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_53.o) - .text 0x000000000049da80 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_64.o) - .text 0x000000000049da80 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_128.o) - .text 0x000000000049da80 0x30 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(fetestexcept.o) - 0x000000000049da80 fetestexcept - .text 0x000000000049dab0 0x50 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_stub.o) - 0x000000000049dab0 lroundf - .text 0x000000000049db00 0x50 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_stub.o) - 0x000000000049db00 lround - .text 0x000000000049db50 0x170 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_ct.o) - 0x000000000049db50 lround.L - .text 0x000000000049dcc0 0x130 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_ct.o) - 0x000000000049dcc0 lroundf.L - .text 0x000000000049ddf0 0xe0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_gen.o) - 0x000000000049ddf0 lroundf.A - .text 0x000000000049ded0 0xf0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_gen.o) - 0x000000000049ded0 lround.A - .text 0x000000000049dfc0 0x7f0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(libm_error.o) - 0x000000000049e1d0 __libm_copy_value - 0x000000000049e320 __libm_error_support - 0x000000000049e720 __libm_setusermatherrl - 0x000000000049e750 __libm_setusermatherr - 0x000000000049e780 __libm_setusermatherrf - .text 0x000000000049e7b0 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherrf.o) - 0x000000000049e7b0 matherrf - .text 0x000000000049e7c0 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherrl.o) - 0x000000000049e7c0 matherrl - .text 0x000000000049e7d0 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherr.o) - 0x000000000049e7d0 matherr - .text 0x000000000049e7e0 0x1e0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ints2q.o) - 0x000000000049e7e0 __ktoq - 0x000000000049e870 __jtoq - 0x000000000049e920 __itoq - 0x000000000049e980 __utoq - .text 0x000000000049e9c0 0x560 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(qcomp.o) - 0x000000000049e9c0 __eqq - 0x000000000049ea40 __neq - 0x000000000049ead0 __leq - 0x000000000049ebb0 __ltq - 0x000000000049ec90 __geq - 0x000000000049ed70 __gtq - 0x000000000049ee50 __compareq - .text 0x000000000049ef20 0x1d0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fp2q.o) - 0x000000000049ef20 __dtoq - 0x000000000049eff0 __ltoq - 0x000000000049f060 __ftoq - .text 0x000000000049f0f0 0x7e0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(q2fp.o) - 0x000000000049f0f0 __qtod - 0x000000000049f3e0 __qtol - 0x000000000049f620 __qtof - .text 0x000000000049f8d0 0x650 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_display.o) - 0x000000000049f8d0 tbk_string_stack_signal - 0x000000000049f936 tbk_string_stack_signal_impl - .text 0x000000000049ff20 0x1640 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_backtrace.o) - 0x000000000049ff20 tbk_getPC - 0x000000000049ff30 tbk_getRetAddr - 0x000000000049ff40 tbk_getFramePtr - 0x000000000049ff50 tbk_getModuleName - 0x00000000004a0270 tbk_get_pc_info - 0x00000000004a0e30 tbk_geterrorstring - 0x00000000004a0fe0 tbk_trace_stack - 0x00000000004a1034 tbk_trace_stack_impl - .text 0x00000000004a1560 0x460 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(cpu_feature_disp.o) - 0x00000000004a1560 __intel_cpu_features_init_x - 0x00000000004a1580 __intel_cpu_features_init - .text 0x00000000004a19c0 0xc0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemcpy.o) - 0x00000000004a19c0 _intel_fast_memcpy.A - 0x00000000004a19d0 _intel_fast_memcpy.J - 0x00000000004a19e0 _intel_fast_memcpy.M - 0x00000000004a19f0 _intel_fast_memcpy.P - 0x00000000004a1a00 _intel_fast_memcpy - .text 0x00000000004a1a80 0x90 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemmove.o) - 0x00000000004a1a80 _intel_fast_memmove.A - 0x00000000004a1a90 _intel_fast_memmove.M - 0x00000000004a1aa0 _intel_fast_memmove.P - 0x00000000004a1ab0 _intel_fast_memmove - .text 0x00000000004a1b10 0x60 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemset.o) - 0x00000000004a1b10 _intel_fast_memset.A - 0x00000000004a1b20 _intel_fast_memset.J - 0x00000000004a1b30 _intel_fast_memset - .text 0x00000000004a1b70 0x360 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(new_proc_init.o) - 0x00000000004a1b70 __intel_new_feature_proc_init - .text 0x00000000004a1ed0 0x3190 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_addsubq.o) - 0x00000000004a31e0 __addq - 0x00000000004a3290 __subq - .text 0x00000000004a5060 0x1c00 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_divq.o) - 0x00000000004a5060 __divq.L - 0x00000000004a5e40 __divq.A - 0x00000000004a6c20 __divq - .text 0x00000000004a6c60 0x130 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strcpy.o) - 0x00000000004a6c60 __intel_sse2_strcpy - .text 0x00000000004a6d90 0x190 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncpy.o) - 0x00000000004a6d90 __intel_sse2_strncpy - .text 0x00000000004a6f20 0x30 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strlen.o) - 0x00000000004a6f20 __intel_sse2_strlen - .text 0x00000000004a6f50 0x40 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strchr.o) - 0x00000000004a6f50 __intel_sse2_strchr - .text 0x00000000004a6f90 0x2e0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncmp.o) - 0x00000000004a6f90 __intel_sse2_strncmp - .text 0x00000000004a7270 0x280 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strcat.o) - 0x00000000004a7270 __intel_sse2_strcat - .text 0x00000000004a74f0 0x330 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncat.o) - 0x00000000004a74f0 __intel_sse2_strncat - .text 0x00000000004a7820 0x17b0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_memcpy_pp.o) - 0x00000000004a7820 __intel_memcpy - 0x00000000004a7820 __intel_new_memcpy - .text 0x00000000004a8fd0 0x11e0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_memset_pp.o) - 0x00000000004a8fd0 __intel_memset - 0x00000000004a8fd0 __intel_new_memset - .text 0x00000000004aa1b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memcpy.o) - .text.ssse3 0x00000000004aa1b0 0x29c5 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memcpy.o) - 0x00000000004aa1b0 __intel_ssse3_memcpy - *fill* 0x00000000004acb75 0x3 - .text 0x00000000004acb78 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memcpy.o) - *fill* 0x00000000004acb78 0x8 - .text.ssse3 0x00000000004acb80 0x2ab6 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memcpy.o) - 0x00000000004acb80 __intel_ssse3_rep_memcpy - *fill* 0x00000000004af636 0x2 - .text 0x00000000004af638 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memmove.o) - *fill* 0x00000000004af638 0x8 - .text.ssse3 0x00000000004af640 0x2b76 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memmove.o) - 0x00000000004af640 __intel_ssse3_memmove - *fill* 0x00000000004b21b6 0x2 - .text 0x00000000004b21b8 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memmove.o) - *fill* 0x00000000004b21b8 0x8 - .text.ssse3 0x00000000004b21c0 0x2af6 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memmove.o) - 0x00000000004b21c0 __intel_ssse3_rep_memmove - *fill* 0x00000000004b4cb6 0xa - .text 0x00000000004b4cc0 0x4e0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(irc_msg_support.o) - 0x00000000004b4cc0 __libirc_get_msg - 0x00000000004b4ef0 __libirc_print - .text 0x00000000004b51a0 0xbe0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_mem_ops.o) - 0x00000000004b51a0 __cacheSize - .text 0x00000000004b5d80 0xb0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(proc_init_utils.o) - 0x00000000004b5d80 __intel_proc_init_ftzdazule - .text 0x00000000004b5e30 0x99 /usr/lib64/libc_nonshared.a(elf-init.oS) - 0x00000000004b5e30 __libc_csu_fini - 0x00000000004b5e40 __libc_csu_init - *fill* 0x00000000004b5ec9 0x7 - .text 0x00000000004b5ed0 0x51 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - 0x00000000004b5ed0 __powidf2 - *fill* 0x00000000004b5f21 0xf - .text 0x00000000004b5f30 0x36 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtend.o - *fill* 0x00000000004b5f66 0x2 - .text 0x00000000004b5f68 0x0 /usr/lib/../lib64/crtn.o - *(.gnu.warning) - -.fini 0x00000000004b5f68 0x16 - *(SORT(.fini)) - .fini 0x00000000004b5f68 0x10 /usr/lib/../lib64/crti.o - 0x00000000004b5f68 _fini - .fini 0x00000000004b5f78 0x5 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtbegin.o - .fini 0x00000000004b5f7d 0x1 /usr/lib/../lib64/crtn.o - 0x00000000004b5f7e PROVIDE (__etext, .) - 0x00000000004b5f7e PROVIDE (_etext, .) - 0x00000000004b5f7e PROVIDE (etext, .) - -.rodata 0x00000000004b5f80 0x1a5e8 - *(.rodata .rodata.* .gnu.linkonce.r.*) - .rodata.cst4 0x00000000004b5f80 0x4 /usr/lib/../lib64/crt1.o - 0x00000000004b5f80 _IO_stdin_used - *fill* 0x00000000004b5f84 0x4 - .rodata 0x00000000004b5f88 0x240 rdbfmsua.o - .rodata.str1.4 - 0x00000000004b61c8 0x1c2 rdbfmsua.o - 0x208 (size before relaxing) - *fill* 0x00000000004b638a 0x6 - .rodata 0x00000000004b6390 0x50 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flclos.o) - .rodata 0x00000000004b63e0 0x55 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltdat.o) - .rodata 0x00000000004b6435 0x21 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltinq.o) - .rodata 0x00000000004b6456 0x1 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stldsp.o) - *fill* 0x00000000004b6457 0x1 - .rodata 0x00000000004b6458 0xc /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbrstn.o) - *fill* 0x00000000004b6464 0x4 - .rodata 0x00000000004b6468 0x50 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flbksp.o) - .rodata 0x00000000004b64b8 0x58 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flinqr.o) - .rodata 0x00000000004b6510 0x1 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flpath.o) - *fill* 0x00000000004b6511 0x7 - .rodata 0x00000000004b6518 0x5d /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flsopn.o) - .rodata 0x00000000004b6575 0x3 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssenvr.o) - .rodata 0x00000000004b6578 0xc4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbastn.o) - *fill* 0x00000000004b663c 0x4 - .rodata 0x00000000004b6640 0x3a2 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) - *fill* 0x00000000004b69e2 0x6 - .rodata 0x00000000004b69e8 0x76 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapn.o) - *fill* 0x00000000004b6a5e 0x2 - .rodata 0x00000000004b6a60 0x3e /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapx.o) - *fill* 0x00000000004b6a9e 0x2 - .rodata 0x00000000004b6aa0 0x14 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgw.o) - *fill* 0x00000000004b6ab4 0x4 - .rodata 0x00000000004b6ab8 0x3bb /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readdx.o) - *fill* 0x00000000004b6e73 0x5 - .rodata 0x00000000004b6e78 0x97 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readns.o) - *fill* 0x00000000004b6f0f 0x1 - .rodata 0x00000000004b6f10 0xe8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) - .rodata 0x00000000004b6ff8 0x5c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(status.o) - *fill* 0x00000000004b7054 0x4 - .rodata 0x00000000004b7058 0x478 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) - .rodata 0x00000000004b74d0 0x7c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) - *fill* 0x00000000004b754c 0x4 - .rodata 0x00000000004b7550 0x331 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdlen.o) - *fill* 0x00000000004b7881 0x7 - .rodata 0x00000000004b7888 0xad /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) - *fill* 0x00000000004b7935 0x3 - .rodata 0x00000000004b7938 0x1fc /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wtstat.o) - *fill* 0x00000000004b7b34 0x4 - .rodata 0x00000000004b7b38 0xe4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(adn30.o) - .rodata 0x00000000004b7c1c 0x2c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) - .rodata 0x00000000004b7c48 0x41 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort2.o) - *fill* 0x00000000004b7c89 0x7 - .rodata 0x00000000004b7c90 0x41 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort.o) - *fill* 0x00000000004b7cd1 0x3 - .rodata 0x00000000004b7cd4 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cpbfdx.o) - .rodata 0x00000000004b7cd8 0xc /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(drstpl.o) - .rodata 0x00000000004b7ce4 0x8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxinit.o) - *fill* 0x00000000004b7cec 0x4 - .rodata 0x00000000004b7cf0 0xea /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxmini.o) - *fill* 0x00000000004b7dda 0x6 - .rodata 0x00000000004b7de0 0x57 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getwin.o) - *fill* 0x00000000004b7e37 0x9 - .rodata 0x00000000004b7e40 0x10 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ibfms.o) - .rodata 0x00000000004b7e50 0x11 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ifxy.o) - *fill* 0x00000000004b7e61 0x7 - .rodata 0x00000000004b7e68 0x82 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invcon.o) - *fill* 0x00000000004b7eea 0x6 - .rodata 0x00000000004b7ef0 0x82 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invwin.o) - *fill* 0x00000000004b7f72 0x6 - .rodata 0x00000000004b7f78 0x86 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ipkm.o) - *fill* 0x00000000004b7ffe 0x2 - .rodata 0x00000000004b8000 0x87 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupm.o) - *fill* 0x00000000004b8087 0x1 - .rodata 0x00000000004b8088 0xd0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrpc.o) - .rodata 0x00000000004b8158 0xd0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrps.o) - .rodata 0x00000000004b8228 0x144 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) - *fill* 0x00000000004b836c 0x4 - .rodata 0x00000000004b8370 0x82 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(newwin.o) - .rodata 0x00000000004b83f2 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nmwrd.o) - *fill* 0x00000000004b83f6 0x2 - .rodata 0x00000000004b83f8 0x82 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nxtwin.o) - *fill* 0x00000000004b847a 0x6 - .rodata 0x00000000004b8480 0xeb /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ovrbs1.o) - *fill* 0x00000000004b856b 0x5 - .rodata 0x00000000004b8570 0x6c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(padmsg.o) - *fill* 0x00000000004b85dc 0x4 - .rodata 0x00000000004b85e0 0xc5 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkbs1.o) - *fill* 0x00000000004b86a5 0x3 - .rodata 0x00000000004b86a8 0x8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkc.o) - .rodata 0x00000000004b86b0 0x11c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pktdd.o) - *fill* 0x00000000004b87cc 0x4 - .rodata 0x00000000004b87d0 0x80 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs01.o) - .rodata 0x00000000004b8850 0xfc /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs1.o) - *fill* 0x00000000004b894c 0x4 - .rodata 0x00000000004b8950 0x37b /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) - *fill* 0x00000000004b8ccb 0x1 - .rodata 0x00000000004b8ccc 0x8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdcmps.o) - *fill* 0x00000000004b8cd4 0x4 - .rodata 0x00000000004b8cd8 0x494 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdusdx.o) - *fill* 0x00000000004b916c 0x4 - .rodata 0x00000000004b9170 0xde /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readmg.o) - *fill* 0x00000000004b924e 0x2 - .rodata 0x00000000004b9250 0x662 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(seqsdx.o) - *fill* 0x00000000004b98b2 0x6 - .rodata 0x00000000004b98b8 0x24c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(stndrd.o) - *fill* 0x00000000004b9b04 0x4 - .rodata 0x00000000004b9b08 0xf2 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(string.o) - *fill* 0x00000000004b9bfa 0x6 - .rodata 0x00000000004b9c00 0x84 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strnum.o) - *fill* 0x00000000004b9c84 0x4 - .rodata 0x00000000004b9c88 0xb2 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strsuc.o) - *fill* 0x00000000004b9d3a 0x2 - .rodata 0x00000000004b9d3c 0x8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(trybump.o) - .rodata 0x00000000004b9d44 0x8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upc.o) - *fill* 0x00000000004b9d4c 0x4 - .rodata 0x00000000004b9d50 0x4f0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(usrtpl.o) - .rodata 0x00000000004ba240 0x8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrna.o) - .rodata 0x00000000004ba248 0x274 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cktaba.o) - *fill* 0x00000000004ba4bc 0x4 - .rodata 0x00000000004ba4c0 0xf5 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cnved4.o) - *fill* 0x00000000004ba5b5 0x3 - .rodata 0x00000000004ba5b8 0x14a /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(elemdx.o) - *fill* 0x00000000004ba702 0x2 - .rodata 0x00000000004ba704 0x10 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getlens.o) - .rodata 0x00000000004ba714 0x4a /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(gets1loc.o) - *fill* 0x00000000004ba75e 0x2 - .rodata 0x00000000004ba760 0x148 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(idn30.o) - .rodata 0x00000000004ba8a8 0x10 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(igetdate.o) - .rodata 0x00000000004ba8b8 0x18 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(istdesc.o) - .rodata 0x00000000004ba8d0 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupbs01.o) - .rodata 0x00000000004ba8f8 0x1 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstchr.o) - *fill* 0x00000000004ba8f9 0x7 - .rodata 0x00000000004ba900 0xfa /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstnum.o) - *fill* 0x00000000004ba9fa 0x6 - .rodata 0x00000000004baa00 0xd0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstjpb.o) - .rodata 0x00000000004baad0 0x170 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(makestab.o) - .rodata 0x00000000004bac40 0x78 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(mvb.o) - .rodata 0x00000000004bacb8 0x1f /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtab.o) - *fill* 0x00000000004bacd7 0x1 - .rodata 0x00000000004bacd8 0xb0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbax.o) - .rodata 0x00000000004bad88 0xbb /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenuaa.o) - *fill* 0x00000000004bae43 0x5 - .rodata 0x00000000004bae48 0x16b /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenubd.o) - .rodata 0x00000000004bafb3 0x13 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numbck.o) - *fill* 0x00000000004bafc6 0x2 - .rodata 0x00000000004bafc8 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtab.o) - *fill* 0x00000000004bafef 0x1 - .rodata 0x00000000004baff0 0xca /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbt.o) - *fill* 0x00000000004bb0ba 0x6 - .rodata 0x00000000004bb0c0 0x181 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parstr.o) - *fill* 0x00000000004bb241 0x7 - .rodata 0x00000000004bb248 0x363 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parusr.o) - *fill* 0x00000000004bb5ab 0x5 - .rodata 0x00000000004bb5b0 0x1e4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parutg.o) - *fill* 0x00000000004bb794 0x4 - .rodata 0x00000000004bb798 0xf0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rcstpl.o) - .rodata 0x00000000004bb888 0x18 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgb.o) - .rodata 0x00000000004bb8a0 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(restd.o) - *fill* 0x00000000004bb8c7 0x1 - .rodata 0x00000000004bb8c8 0x3f6 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabsub.o) - *fill* 0x00000000004bbcbe 0x2 - .rodata 0x00000000004bbcc0 0x68 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(uptdd.o) - .rodata 0x00000000004bbd28 0x47 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdesc.o) - *fill* 0x00000000004bbd6f 0x1 - .rodata 0x00000000004bbd70 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cadn30.o) - *fill* 0x00000000004bbd74 0x4 - .rodata 0x00000000004bbd78 0x10e /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chekstab.o) - *fill* 0x00000000004bbe86 0x2 - .rodata 0x00000000004bbe88 0x6e /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(inctab.o) - *fill* 0x00000000004bbef6 0xa - .rodata 0x00000000004bbf00 0x290 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbb.o) - .rodata 0x00000000004bc190 0x2b7 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbd.o) - .rodata 0x00000000004bc447 0x1 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtbd.o) - .rodata 0x00000000004bc448 0xb1 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabent.o) - *fill* 0x00000000004bc4f9 0x7 - .rodata 0x00000000004bc500 0x108 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(valx.o) - .rodata 0x00000000004bc608 0x8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rjust.o) - .rodata.str1.4 - 0x00000000004bc610 0xd0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) - .rodata 0x00000000004bc6e0 0x160 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) - .rodata.str1.32 - 0x00000000004bc840 0x1ecd /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) - 0x1ee0 (size before relaxing) - *fill* 0x00000000004be70d 0x13 - .rodata 0x00000000004be720 0x3c0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) - .rodata.str1.4 - 0x00000000004beae0 0x3 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) - 0x4 (size before relaxing) - *fill* 0x00000000004beae3 0x1 - .rodata.str1.4 - 0x00000000004beae4 0x3cd /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) - 0x3f0 (size before relaxing) - *fill* 0x00000000004beeb1 0xf - .rodata 0x00000000004beec0 0x1980 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) - .rodata.str1.4 - 0x00000000004c0840 0x7 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_preconnected_units_init.o) - 0x8 (size before relaxing) - *fill* 0x00000000004c0847 0x19 - .rodata 0x00000000004c0860 0x80 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_reentrancy.o) - .rodata 0x00000000004c08e0 0x70 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_secnds.o) - .rodata.str1.4 - 0x00000000004c0950 0xb /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_stop.o) - 0x14 (size before relaxing) - *fill* 0x00000000004c095b 0x5 - .rodata 0x00000000004c0960 0x200 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_stop.o) - .rodata.str1.4 - 0x00000000004c0b60 0x53 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wint_fmt.o) - 0x64 (size before relaxing) - *fill* 0x00000000004c0bb3 0xd - .rodata 0x00000000004c0bc0 0x220 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wint_fmt.o) - .rodata.str1.4 - 0x00000000004c0de0 0xf /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_fmt.o) - 0x24 (size before relaxing) - *fill* 0x00000000004c0def 0x1 - .rodata 0x00000000004c0df0 0x2e0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_fmt.o) - .rodata 0x00000000004c10d0 0x4b0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_lis.o) - .rodata.str1.4 - 0x00000000004c1580 0xf /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_lis.o) - 0x18 (size before relaxing) - *fill* 0x00000000004c158f 0x1 - .rodata.str1.4 - 0x00000000004c1590 0xf2 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) - 0x100 (size before relaxing) - *fill* 0x00000000004c1682 0x2 - .rodata.str1.4 - 0x00000000004c1684 0xb0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) - 0x104 (size before relaxing) - *fill* 0x00000000004c1734 0x4 - .rodata 0x00000000004c1738 0x310 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) - .rodata 0x00000000004c1a48 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_int.o) - .rodata 0x00000000004c1a58 0x198 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_f.o) - .rodata 0x00000000004c1bf0 0x198 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_d.o) - .rodata 0x00000000004c1d88 0x198 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_g.o) - .rodata 0x00000000004c1f20 0x330 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cray.o) - .rodata 0x00000000004c2250 0x198 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_short.o) - .rodata 0x00000000004c23e8 0x198 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_long.o) - .rodata 0x00000000004c2580 0x7f8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_double.o) - .rodata 0x00000000004c2d78 0x4c8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_single.o) - .rodata.str1.4 - 0x0000000000000000 0x8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close.o) - .rodata 0x00000000004c3240 0x48 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close_proc.o) - .rodata.str1.4 - 0x00000000004c3288 0x66 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close_proc.o) - 0x68 (size before relaxing) - *fill* 0x00000000004c32ee 0x2 - .rodata.str1.4 - 0x00000000004c32f0 0x43 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_default_io_sizes_env_init.o) - 0x44 (size before relaxing) - *fill* 0x00000000004c3333 0xd - .rodata 0x00000000004c3340 0x200 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_desc_item.o) - 0x00000000004c34a0 for__dsc_itm_table - .rodata.str1.4 - 0x00000000004c3540 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_desc_item.o) - .rodata.str1.4 - 0x00000000004c3550 0x3c41 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_diags_intel.o) - 0x3cc4 (size before relaxing) - *fill* 0x00000000004c7191 0x7 - .rodata 0x00000000004c7198 0x58 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_diags_intel.o) - *fill* 0x00000000004c71f0 0x10 - .rodata.str1.32 - 0x00000000004c7200 0x1644 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_diags_intel.o) - 0x1660 (size before relaxing) - .rodata.str1.4 - 0x00000000004c8844 0x13 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_exit_handler.o) - 0x14 (size before relaxing) - *fill* 0x00000000004c8857 0x9 - .rodata 0x00000000004c8860 0x3a0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_comp.o) - .rodata.str1.4 - 0x00000000004c8c00 0xf /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_comp.o) - 0x10 (size before relaxing) - *fill* 0x00000000004c8c0f 0x1 - .rodata 0x00000000004c8c10 0x1100 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) - .rodata 0x00000000004c9d10 0x48 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_get.o) - .rodata.str1.4 - 0x00000000004c9d58 0xa /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_get.o) - 0xc (size before relaxing) - *fill* 0x00000000004c9d62 0x1e - .rodata 0x00000000004c9d80 0xbe0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_intrp_fmt.o) - 0x00000000004ca300 for__oz_fmt_table - 0x00000000004ca360 for__b_fmt_table - 0x00000000004ca400 for__fedg_fmt_table - 0x00000000004ca4e0 for__coerce_data_types - 0x00000000004ca943 for__i_fmt_table - .rodata.str1.4 - 0x00000000004ca960 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_intrp_fmt.o) - *fill* 0x00000000004ca970 0x10 - .rodata 0x00000000004ca980 0x240 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_ldir_wfs.o) - 0x00000000004ca980 for__wfs_table - 0x00000000004caaa0 for__wfs_msf_table - .rodata 0x00000000004cabc0 0x2d0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_lub_mgt.o) - .rodata.str1.4 - 0x00000000004cae90 0xe /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_lub_mgt.o) - 0x10 (size before relaxing) - .rodata.str1.4 - 0x0000000000000000 0x8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_need_lf.o) - *fill* 0x00000000004cae9e 0x2 - .rodata 0x00000000004caea0 0x60 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_need_lf.o) - .rodata 0x00000000004caf00 0x210 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_put.o) - .rodata.str1.4 - 0x00000000004cb110 0xa /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_put.o) - 0xc (size before relaxing) - *fill* 0x00000000004cb11a 0x2 - .rodata.str1.4 - 0x00000000004cb11c 0xb /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq.o) - 0x14 (size before relaxing) - *fill* 0x00000000004cb127 0x1 - .rodata 0x00000000004cb128 0x248 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq.o) - .rodata.str1.4 - 0x00000000004cb370 0x1ef /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(tbk_traceback.o) - 0x1fc (size before relaxing) - *fill* 0x00000000004cb55f 0x1 - .rodata.str1.32 - 0x00000000004cb560 0xb93 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(tbk_traceback.o) - 0xba0 (size before relaxing) - *fill* 0x00000000004cc0f3 0xd - .rodata 0x00000000004cc100 0x1c0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt__globals.o) - 0x00000000004cc100 vax_c - 0x00000000004cc140 ieee_t - 0x00000000004cc1b0 ieee_s - 0x00000000004cc1e8 ibm_s - 0x00000000004cc204 ibm_l - 0x00000000004cc23c cray - 0x00000000004cc274 int_c - .rodata 0x00000000004cc2c0 0x20 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_int_to_text.o) - .rodata.str1.4 - 0x00000000004cc2e0 0x11 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_int_to_text.o) - 0x14 (size before relaxing) - .rodata.str1.4 - 0x0000000000000000 0x14 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_data_to_text.o) - *fill* 0x00000000004cc2f1 0xf - .rodata 0x00000000004cc300 0x20 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_data_to_text.o) - .rodata 0x00000000004cc320 0x30 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_log_to_text.o) - .rodata 0x00000000004cc350 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_t.o) - .rodata 0x00000000004cc360 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_s.o) - .rodata 0x00000000004cc370 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_x.o) - .rodata 0x00000000004cc380 0x150 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_s.o) - .rodata.str1.4 - 0x00000000004cc4d0 0xd /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_s.o) - 0x10 (size before relaxing) - *fill* 0x00000000004cc4dd 0x3 - .rodata 0x00000000004cc4e0 0x150 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_t.o) - .rodata.str1.4 - 0x0000000000000000 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_t.o) - .rodata.str1.4 - 0x00000000004cc630 0x20 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_s_to_a.o) - 0x30 (size before relaxing) - .rodata 0x00000000004cc650 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_s_to_a.o) - .rodata.str1.4 - 0x0000000000000000 0x30 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_t_to_a.o) - .rodata 0x00000000004cc660 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_t_to_a.o) - .rodata 0x00000000004cc670 0x138 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_x.o) - .rodata.str1.4 - 0x0000000000000000 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_x.o) - .rodata.str1.4 - 0x0000000000000000 0x30 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_x_to_a.o) - *fill* 0x00000000004cc7a8 0x8 - .rodata 0x00000000004cc7b0 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_x_to_a.o) - .rodata 0x00000000004cc7c0 0x180 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_globals.o) - 0x00000000004cc7c0 cvtas_pten_word - 0x00000000004cc860 cvtas_globals_t - 0x00000000004cc8c0 cvtas_globals_x - 0x00000000004cc920 cvtas_globals_s - .rodata 0x00000000004cc940 0x4e0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_53.o) - 0x00000000004cc940 cvtas_pten_t - 0x00000000004ccc40 cvtas_tiny_pten_t - 0x00000000004ccce0 cvtas_tiny_pten_t_map - 0x00000000004ccd40 cvtas_huge_pten_t - 0x00000000004ccdc0 cvtas_huge_pten_t_map - .rodata 0x00000000004cce20 0x5e0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_64.o) - 0x00000000004cce20 cvtas_pten_64 - 0x00000000004cd120 cvtas_pten_64_bexp - 0x00000000004cd1e0 cvtas_tiny_pten_64 - 0x00000000004cd260 cvtas_tiny_pten_64_map - 0x00000000004cd2e0 cvtas_huge_pten_64 - 0x00000000004cd360 cvtas_huge_pten_64_map - 0x00000000004cd3ba cvtas_tiny_pten_64_bexp - 0x00000000004cd3d8 cvtas_huge_pten_64_bexp - .rodata 0x00000000004cd400 0x520 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_128.o) - 0x00000000004cd400 cvtas_pten_128 - 0x00000000004cd5c0 cvtas_tiny_tiny_pten_128 - 0x00000000004cd600 cvtas_tiny_pten_128 - 0x00000000004cd6a0 cvtas_tiny_pten_128_map - 0x00000000004cd740 cvtas_huge_huge_pten_128 - 0x00000000004cd780 cvtas_huge_pten_128 - 0x00000000004cd820 cvtas_huge_pten_128_map - 0x00000000004cd8a8 cvtas_pten_128_bexp - 0x00000000004cd8de cvtas_tiny_tiny_pten_128_bexp - 0x00000000004cd8e6 cvtas_tiny_pten_128_bexp - 0x00000000004cd8fa cvtas_huge_huge_pten_128_bexp - 0x00000000004cd902 cvtas_huge_pten_128_bexp - .rodata 0x00000000004cd920 0x20 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_ct.o) - .rodata 0x00000000004cd940 0x20 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_ct.o) - .rodata 0x00000000004cd960 0x20 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_gen.o) - .rodata 0x00000000004cd980 0x20 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_gen.o) - .rodata.str1.4 - 0x00000000004cd9a0 0x45a /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(libm_error.o) - 0x484 (size before relaxing) - *fill* 0x00000000004cddfa 0x6 - .rodata 0x00000000004cde00 0x918 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(libm_error.o) - .rodata 0x00000000004ce718 0x8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(qcomp.o) - .rodata 0x00000000004ce720 0xc /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fp2q.o) - *fill* 0x00000000004ce72c 0x4 - .rodata 0x00000000004ce730 0x28 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(q2fp.o) - .rodata.str1.4 - 0x00000000004ce758 0x113 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_display.o) - 0x118 (size before relaxing) - *fill* 0x00000000004ce86b 0x15 - .rodata.str1.32 - 0x00000000004ce880 0xa2 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_display.o) - 0xc0 (size before relaxing) - *fill* 0x00000000004ce922 0x2 - .rodata.str1.4 - 0x00000000004ce924 0x24 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_backtrace.o) - 0x3c (size before relaxing) - .rodata 0x00000000004ce948 0x24 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_backtrace.o) - .rodata.str1.4 - 0x00000000004ce96c 0x14b /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(new_proc_init.o) - 0x150 (size before relaxing) - *fill* 0x00000000004ceab7 0x9 - .rodata 0x00000000004ceac0 0xa0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_addsubq.o) - .rodata 0x00000000004ceb60 0x90 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_divq.o) - .rodata.ssse3 0x00000000004cebf0 0x1c0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memcpy.o) - .rodata.ssse3 0x00000000004cedb0 0x500 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memcpy.o) - .rodata.ssse3 0x00000000004cf2b0 0x1c0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memmove.o) - .rodata.ssse3 0x00000000004cf470 0x500 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memmove.o) - .rodata.str1.4 - 0x00000000004cf970 0x58c /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(irc_msg_support.o) - 0x5b0 (size before relaxing) - *fill* 0x00000000004cfefc 0x4 - .rodata.str1.32 - 0x00000000004cff00 0x660 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(irc_msg_support.o) - .rodata.cst8 0x00000000004d0560 0x8 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - -.rodata1 - *(.rodata1) - -.eh_frame_hdr 0x00000000004d0568 0xee4 - *(.eh_frame_hdr) - .eh_frame_hdr 0x00000000004d0568 0xee4 /usr/lib/../lib64/crti.o - -.eh_frame 0x00000000004d1450 0xc694 - *(.eh_frame) - .eh_frame 0x00000000004d1450 0x40 /usr/lib/../lib64/crt1.o - .eh_frame 0x00000000004d1490 0x20 /usr/lib/../lib64/crti.o - 0x38 (size before relaxing) - .eh_frame 0x00000000004d14b0 0x38 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/for_main.o - 0x50 (size before relaxing) - .eh_frame 0x00000000004d14e8 0x158 rdbfmsua.o - .eh_frame 0x00000000004d1640 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flclos.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1660 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flflun.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1680 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltbop.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d16a8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltdat.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d16c8 0x30 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltinq.o) - 0x48 (size before relaxing) - .eh_frame 0x00000000004d16f8 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stldsp.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1720 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlstr.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1740 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmbl.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1768 0x30 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmst.o) - 0x48 (size before relaxing) - .eh_frame 0x00000000004d1798 0x30 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbrstn.o) - 0x48 (size before relaxing) - .eh_frame 0x00000000004d17c8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flbksp.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d17e8 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flinqr.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1810 0x30 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flpath.o) - 0x48 (size before relaxing) - .eh_frame 0x00000000004d1840 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flsopn.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1860 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssenvr.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1888 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssgsym.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d18b0 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlcuc.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d18d8 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stuclc.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1900 0x30 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbastn.o) - 0x48 (size before relaxing) - .eh_frame 0x00000000004d1930 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flglun.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1950 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libbridge.a(dcbsrh.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1970 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ireadns.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1990 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d19b0 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapn.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d19d8 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapx.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1a00 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgw.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1a28 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readdx.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1a48 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readns.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1a68 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1a88 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(status.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1aa8 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1ad0 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1af8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upb.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1b18 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdlen.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1b38 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1b60 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wtstat.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1b80 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(adn30.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1ba0 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1bc8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort2.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1be8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort_exit.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1c08 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1c28 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(conwin.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1c50 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cpbfdx.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1c78 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(drstpl.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1c98 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxinit.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1cc0 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxmini.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1ce8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getwin.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1d08 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ibfms.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1d28 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ichkstr.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1d50 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ifxy.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1d70 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invcon.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1d90 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invwin.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1db0 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ipkm.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1dd0 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(irev.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1df0 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupm.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1e10 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lmsg.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1e30 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrpc.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1e50 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrps.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1e70 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1e98 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(newwin.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1eb8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nmwrd.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1ed8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nxtwin.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1ef8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ovrbs1.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1f18 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(padmsg.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1f40 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkb.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1f68 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkbs1.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1f88 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkc.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1fb0 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pktdd.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d1fd0 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs01.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d1ff8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs1.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d2018 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2040 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdcmps.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2068 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdtree.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2090 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdusdx.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d20b8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readmg.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d20d8 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(seqsdx.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2100 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(stndrd.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2128 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(string.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2150 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strnum.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2178 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strsuc.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d21a0 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(trybump.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d21c0 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upbb.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d21e0 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upc.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2208 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(usrtpl.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2230 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(capit.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d2250 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrna.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2278 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrn.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d22a0 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cktaba.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d22c8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cnved4.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d22e8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(digit.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d2308 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(elemdx.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d2328 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getlens.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2350 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(gets1loc.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d2370 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(i4dy.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d2390 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(idn30.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d23b8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(igetdate.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d23d8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(istdesc.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d23f8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupb.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d2418 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupbs01.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2440 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstchr.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2468 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstnum.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2490 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstjpb.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d24b0 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(makestab.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d24d8 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(mvb.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2500 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemock.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d2520 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtab.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2548 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbax.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2570 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenuaa.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2598 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenubd.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d25c0 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numbck.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d25e0 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtab.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2608 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbt.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d2628 0x30 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parstr.o) - 0x48 (size before relaxing) - .eh_frame 0x00000000004d2658 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parusr.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2680 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parutg.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d26a8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rcstpl.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d26c8 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgb.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d26f0 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(restd.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2718 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rsvfvm.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d2738 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strcln.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d2758 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabsub.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2780 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(uptdd.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d27a0 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdesc.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d27c0 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cadn30.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d27e8 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chekstab.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2810 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(inctab.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2838 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbb.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d2858 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbd.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d2880 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtbd.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d28a8 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabent.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d28c8 0x28 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(valx.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d28f0 0x20 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rjust.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004d2910 0x358 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) - 0x370 (size before relaxing) - .eh_frame 0x00000000004d2c68 0x1c0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) - 0x1d8 (size before relaxing) - .eh_frame 0x00000000004d2e28 0xa08 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) - 0xa20 (size before relaxing) - .eh_frame 0x00000000004d3830 0x30 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_preconnected_units_init.o) - 0x48 (size before relaxing) - .eh_frame 0x00000000004d3860 0x1d0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_reentrancy.o) - 0x1e8 (size before relaxing) - .eh_frame 0x00000000004d3a30 0x1e8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_secnds.o) - 0x200 (size before relaxing) - .eh_frame 0x00000000004d3c18 0x238 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_stop.o) - 0x250 (size before relaxing) - .eh_frame 0x00000000004d3e50 0x320 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_vm.o) - 0x338 (size before relaxing) - .eh_frame 0x00000000004d4170 0x6e8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wint_fmt.o) - 0x700 (size before relaxing) - .eh_frame 0x00000000004d4858 0x9b0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_fmt.o) - 0x9c8 (size before relaxing) - .eh_frame 0x00000000004d5208 0xbe8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_lis.o) - 0xc00 (size before relaxing) - .eh_frame 0x00000000004d5df0 0x758 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) - 0x770 (size before relaxing) - .eh_frame 0x00000000004d6548 0x698 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) - 0x6b0 (size before relaxing) - .eh_frame 0x00000000004d6be0 0x180 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio_wrap.o) - 0x198 (size before relaxing) - .eh_frame 0x00000000004d6d60 0x290 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_int.o) - 0x2a8 (size before relaxing) - .eh_frame 0x00000000004d6ff0 0xc8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_f.o) - 0xe0 (size before relaxing) - .eh_frame 0x00000000004d70b8 0xc8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_d.o) - 0xe0 (size before relaxing) - .eh_frame 0x00000000004d7180 0xc8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_g.o) - 0xe0 (size before relaxing) - .eh_frame 0x00000000004d7248 0x1e0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cray.o) - 0x1f8 (size before relaxing) - .eh_frame 0x00000000004d7428 0xe0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_short.o) - 0xf8 (size before relaxing) - .eh_frame 0x00000000004d7508 0x108 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_long.o) - 0x120 (size before relaxing) - .eh_frame 0x00000000004d7610 0x508 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_double.o) - 0x520 (size before relaxing) - .eh_frame 0x00000000004d7b18 0x2a8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_single.o) - 0x2c0 (size before relaxing) - .eh_frame 0x00000000004d7dc0 0x220 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close.o) - 0x238 (size before relaxing) - .eh_frame 0x00000000004d7fe0 0x70 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close_proc.o) - 0x88 (size before relaxing) - .eh_frame 0x00000000004d8050 0x28 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_default_io_sizes_env_init.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d8078 0x1d8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_desc_item.o) - 0x1f0 (size before relaxing) - .eh_frame 0x00000000004d8250 0x4d8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_diags_intel.o) - 0x4f0 (size before relaxing) - .eh_frame 0x00000000004d8728 0x28 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_exit.o) - 0x40 (size before relaxing) - .eh_frame 0x00000000004d8750 0x60 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_exit_handler.o) - 0x78 (size before relaxing) - .eh_frame 0x00000000004d87b0 0x6a8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_comp.o) - 0x6c0 (size before relaxing) - .eh_frame 0x00000000004d8e58 0xf0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) - 0x108 (size before relaxing) - .eh_frame 0x00000000004d8f48 0x4c0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_get.o) - 0x4d8 (size before relaxing) - .eh_frame 0x00000000004d9408 0xe8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_intrp_fmt.o) - 0x100 (size before relaxing) - .eh_frame 0x00000000004d94f0 0x430 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_lub_mgt.o) - 0x448 (size before relaxing) - .eh_frame 0x00000000004d9920 0xb0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_need_lf.o) - 0xc8 (size before relaxing) - .eh_frame 0x00000000004d99d0 0x220 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_put.o) - 0x238 (size before relaxing) - .eh_frame 0x00000000004d9bf0 0x9e0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq.o) - 0x9f8 (size before relaxing) - .eh_frame 0x00000000004da5d0 0xa0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(tbk_traceback.o) - 0xb8 (size before relaxing) - .eh_frame 0x00000000004da670 0x100 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_int_to_text.o) - 0x118 (size before relaxing) - .eh_frame 0x00000000004da770 0x180 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_data_to_text.o) - 0x198 (size before relaxing) - .eh_frame 0x00000000004da8f0 0x140 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_log_to_text.o) - 0x158 (size before relaxing) - .eh_frame 0x00000000004daa30 0x150 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_data.o) - 0x168 (size before relaxing) - .eh_frame 0x00000000004dab80 0x90 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_log.o) - 0xa8 (size before relaxing) - .eh_frame 0x00000000004dac10 0x2f8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_t.o) - 0x310 (size before relaxing) - .eh_frame 0x00000000004daf08 0x2f8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_s.o) - 0x310 (size before relaxing) - .eh_frame 0x00000000004db200 0x2d8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_x.o) - 0x2f0 (size before relaxing) - .eh_frame 0x00000000004db4d8 0x90 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_s.o) - 0xa8 (size before relaxing) - .eh_frame 0x00000000004db568 0x90 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_t.o) - 0xa8 (size before relaxing) - .eh_frame 0x00000000004db5f8 0x60 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_s_to_a.o) - 0x78 (size before relaxing) - .eh_frame 0x00000000004db658 0x60 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_t_to_a.o) - 0x78 (size before relaxing) - .eh_frame 0x00000000004db6b8 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_s.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004db6d0 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_t.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004db6e8 0x90 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_x.o) - 0xa8 (size before relaxing) - .eh_frame 0x00000000004db778 0x60 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_x_to_a.o) - 0x78 (size before relaxing) - .eh_frame 0x00000000004db7d8 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_x.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004db7f0 0x20 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(fetestexcept.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004db810 0x20 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_ct.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004db830 0x20 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_ct.o) - 0x38 (size before relaxing) - .eh_frame 0x00000000004db850 0x30 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_gen.o) - 0x48 (size before relaxing) - .eh_frame 0x00000000004db880 0x30 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_gen.o) - 0x48 (size before relaxing) - .eh_frame 0x00000000004db8b0 0xe8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(libm_error.o) - 0x100 (size before relaxing) - .eh_frame 0x00000000004db998 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherrf.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004db9b0 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherrl.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004db9c8 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherr.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004db9e0 0x60 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ints2q.o) - 0x78 (size before relaxing) - .eh_frame 0x00000000004dba40 0xa8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(qcomp.o) - 0xc0 (size before relaxing) - .eh_frame 0x00000000004dbae8 0x48 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fp2q.o) - 0x60 (size before relaxing) - .eh_frame 0x00000000004dbb30 0x88 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(q2fp.o) - 0xa0 (size before relaxing) - .eh_frame 0x00000000004dbbb8 0x1e8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_display.o) - 0x200 (size before relaxing) - .eh_frame 0x00000000004dbda0 0x470 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_backtrace.o) - 0x488 (size before relaxing) - .eh_frame 0x00000000004dc210 0x1a8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(cpu_feature_disp.o) - 0x1c0 (size before relaxing) - .eh_frame 0x00000000004dc3b8 0x60 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemcpy.o) - 0x78 (size before relaxing) - .eh_frame 0x00000000004dc418 0x48 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemmove.o) - 0x60 (size before relaxing) - .eh_frame 0x00000000004dc460 0x30 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemset.o) - 0x48 (size before relaxing) - .eh_frame 0x00000000004dc490 0x80 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(new_proc_init.o) - 0x98 (size before relaxing) - .eh_frame 0x00000000004dc510 0xb30 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_addsubq.o) - 0xb48 (size before relaxing) - .eh_frame 0x00000000004dd040 0x570 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_divq.o) - 0x588 (size before relaxing) - .eh_frame 0x00000000004dd5b0 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strcpy.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004dd5c8 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncpy.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004dd5e0 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strlen.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004dd5f8 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strchr.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004dd610 0xd8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncmp.o) - 0xf0 (size before relaxing) - .eh_frame 0x00000000004dd6e8 0x58 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strcat.o) - 0x70 (size before relaxing) - .eh_frame 0x00000000004dd740 0x68 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncat.o) - 0x80 (size before relaxing) - .eh_frame 0x00000000004dd7a8 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_memcpy_pp.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004dd7c0 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_memset_pp.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004dd7d8 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memcpy.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004dd7f0 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memcpy.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004dd808 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memmove.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004dd820 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memmove.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004dd838 0x108 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(irc_msg_support.o) - 0x120 (size before relaxing) - .eh_frame 0x00000000004dd940 0xe0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_mem_ops.o) - 0xf8 (size before relaxing) - .eh_frame 0x00000000004dda20 0x68 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(proc_init_utils.o) - 0x80 (size before relaxing) - .eh_frame 0x00000000004dda88 0x40 /usr/lib64/libc_nonshared.a(elf-init.oS) - 0x58 (size before relaxing) - .eh_frame 0x00000000004ddac8 0x18 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - 0x30 (size before relaxing) - .eh_frame 0x00000000004ddae0 0x4 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtend.o - -.gcc_except_table - *(.gcc_except_table .gcc_except_table.*) - -.exception_ranges - *(.exception_ranges .exception_ranges*) - 0x00000000004ddae4 . = (ALIGN (0x200000) - ((0x200000 - .) & 0x1fffff)) - 0x00000000006de80c . = DATA_SEGMENT_ALIGN (0x200000, 0x1000) - -.eh_frame - *(.eh_frame) - -.gcc_except_table - *(.gcc_except_table .gcc_except_table.*) - -.exception_ranges - *(.exception_ranges .exception_ranges*) - -.tdata - *(.tdata .tdata.* .gnu.linkonce.td.*) - -.tbss - *(.tbss .tbss.* .gnu.linkonce.tb.*) - *(.tcommon) - -.preinit_array 0x00000000006de80c 0x0 - 0x00000000006de80c PROVIDE (__preinit_array_start, .) - *(.preinit_array) - 0x00000000006de80c PROVIDE (__preinit_array_end, .) - -.init_array 0x00000000006de80c 0x0 - 0x00000000006de80c PROVIDE (__init_array_start, .) - *(SORT(.init_array.*)) - *(.init_array) - 0x00000000006de80c PROVIDE (__init_array_end, .) - -.fini_array 0x00000000006de80c 0x0 - 0x00000000006de80c PROVIDE (__fini_array_start, .) - *(SORT(.fini_array.*)) - *(.fini_array) - 0x00000000006de80c PROVIDE (__fini_array_end, .) - -.ctors 0x00000000006de810 0x18 - *crtbegin.o(.ctors) - .ctors 0x00000000006de810 0x8 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtbegin.o - *crtbegin?.o(.ctors) - *(EXCLUDE_FILE(*crtend?.o *crtend.o) .ctors) - .ctors 0x00000000006de818 0x8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_mem_ops.o) - *(SORT(.ctors.*)) - *(.ctors) - .ctors 0x00000000006de820 0x8 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtend.o - -.dtors 0x00000000006de828 0x10 - *crtbegin.o(.dtors) - .dtors 0x00000000006de828 0x8 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtbegin.o - *crtbegin?.o(.dtors) - *(EXCLUDE_FILE(*crtend?.o *crtend.o) .dtors) - *(SORT(.dtors.*)) - *(.dtors) - .dtors 0x00000000006de830 0x8 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtend.o - 0x00000000006de830 __DTOR_END__ - -.jcr 0x00000000006de838 0x8 - *(.jcr) - .jcr 0x00000000006de838 0x0 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtbegin.o - .jcr 0x00000000006de838 0x8 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtend.o - -.data.rel.ro 0x00000000006de840 0x480 - *(.data.rel.ro.local* .gnu.linkonce.d.rel.ro.local.*) - .data.rel.ro.local - 0x00000000006de840 0xa0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(libm_error.o) - .data.rel.ro.local - 0x00000000006de8e0 0x3e0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(irc_msg_support.o) - *(.data.rel.ro .data.rel.ro.* .gnu.linkonce.d.rel.ro.*) - -.dynamic 0x00000000006decc0 0x1e0 - *(.dynamic) - .dynamic 0x00000000006decc0 0x1e0 /usr/lib/../lib64/crt1.o - 0x00000000006decc0 _DYNAMIC - -.got 0x00000000006deea0 0x158 - *(.got) - .got 0x00000000006deea0 0x158 /usr/lib/../lib64/crt1.o - *(.igot) - 0x00000000006dffe8 . = DATA_SEGMENT_RELRO_END (., (SIZEOF (.got.plt) >= 0x18)?0x18:0x0) - -.got.plt 0x00000000006df000 0x398 - *(.got.plt) - .got.plt 0x00000000006df000 0x398 /usr/lib/../lib64/crt1.o - 0x00000000006df000 _GLOBAL_OFFSET_TABLE_ - *(.igot.plt) - .igot.plt 0x0000000000000000 0x0 /usr/lib/../lib64/crt1.o - -.data 0x00000000006df3c0 0x3ce0 - *(.data .data.* .gnu.linkonce.d.*) - .data 0x00000000006df3c0 0x4 /usr/lib/../lib64/crt1.o - 0x00000000006df3c0 data_start - 0x00000000006df3c0 __data_start - .data 0x00000000006df3c4 0x0 /usr/lib/../lib64/crti.o - *fill* 0x00000000006df3c4 0x4 - .data 0x00000000006df3c8 0x8 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtbegin.o - 0x00000000006df3c8 __dso_handle - .data 0x00000000006df3d0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/for_main.o - *fill* 0x00000000006df3d0 0x10 - .data 0x00000000006df3e0 0x240 rdbfmsua.o - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flclos.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flflun.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltbop.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltdat.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltinq.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stldsp.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlstr.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmbl.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmst.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbrstn.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flbksp.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flinqr.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flpath.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flsopn.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssenvr.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssgsym.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlcuc.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stuclc.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbastn.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flglun.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libbridge.a(dcbsrh.o) - .data 0x00000000006df620 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ireadns.o) - *fill* 0x00000000006df620 0x20 - .data 0x00000000006df640 0xd8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapn.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapx.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgw.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readdx.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readns.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(status.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upb.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdlen.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wtstat.o) - .data 0x00000000006df718 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(adn30.o) - *fill* 0x00000000006df718 0x28 - .data 0x00000000006df740 0x7dc /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) - .data 0x00000000006dff1c 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort2.o) - .data 0x00000000006dff1c 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort_exit.o) - .data 0x00000000006dff1c 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort.o) - .data 0x00000000006dff1c 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(conwin.o) - .data 0x00000000006dff1c 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cpbfdx.o) - .data 0x00000000006dff1c 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(drstpl.o) - *fill* 0x00000000006dff1c 0x24 - .data 0x00000000006dff40 0x128 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxinit.o) - .data 0x00000000006e0068 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxmini.o) - .data 0x00000000006e0068 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getwin.o) - .data 0x00000000006e0068 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ibfms.o) - .data 0x00000000006e0068 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ichkstr.o) - .data 0x00000000006e0068 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ifxy.o) - .data 0x00000000006e0068 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invcon.o) - .data 0x00000000006e0068 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invwin.o) - .data 0x00000000006e0068 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ipkm.o) - .data 0x00000000006e0068 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(irev.o) - .data 0x00000000006e0068 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupm.o) - .data 0x00000000006e0068 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lmsg.o) - .data 0x00000000006e0068 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrpc.o) - .data 0x00000000006e0068 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrps.o) - .data 0x00000000006e0068 0x8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) - .data 0x00000000006e0070 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(newwin.o) - .data 0x00000000006e0070 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nmwrd.o) - .data 0x00000000006e0070 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nxtwin.o) - .data 0x00000000006e0070 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ovrbs1.o) - .data 0x00000000006e0070 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(padmsg.o) - .data 0x00000000006e0070 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkb.o) - .data 0x00000000006e0070 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkbs1.o) - .data 0x00000000006e0070 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkc.o) - .data 0x00000000006e0070 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pktdd.o) - .data 0x00000000006e0070 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs01.o) - .data 0x00000000006e0070 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs1.o) - *fill* 0x00000000006e0070 0x10 - .data 0x00000000006e0080 0x68 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) - .data 0x00000000006e00e8 0x8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdcmps.o) - .data 0x00000000006e00f0 0x8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdtree.o) - .data 0x00000000006e00f8 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdusdx.o) - .data 0x00000000006e00f8 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readmg.o) - .data 0x00000000006e00f8 0x8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(seqsdx.o) - .data 0x00000000006e0100 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(stndrd.o) - .data 0x00000000006e0100 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(string.o) - .data 0x00000000006e0100 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strnum.o) - .data 0x00000000006e0100 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strsuc.o) - .data 0x00000000006e0100 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(trybump.o) - .data 0x00000000006e0100 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upbb.o) - .data 0x00000000006e0100 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upc.o) - .data 0x00000000006e0100 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(usrtpl.o) - .data 0x00000000006e0100 0x3a /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(capit.o) - *fill* 0x00000000006e013a 0x2 - .data 0x00000000006e013c 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrna.o) - .data 0x00000000006e013c 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrn.o) - .data 0x00000000006e013c 0xa /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cktaba.o) - *fill* 0x00000000006e0146 0x2 - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cnved4.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(digit.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(elemdx.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getlens.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(gets1loc.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(i4dy.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(idn30.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(igetdate.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(istdesc.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupb.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupbs01.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstchr.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstnum.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstjpb.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(makestab.o) - .data 0x00000000006e0148 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(mvb.o) - *fill* 0x00000000006e0148 0x18 - .data 0x00000000006e0160 0x46 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemock.o) - *fill* 0x00000000006e01a6 0x2 - .data 0x00000000006e01a8 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtab.o) - .data 0x00000000006e01a8 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbax.o) - .data 0x00000000006e01a8 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenuaa.o) - .data 0x00000000006e01a8 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenubd.o) - .data 0x00000000006e01a8 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numbck.o) - .data 0x00000000006e01a8 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtab.o) - .data 0x00000000006e01a8 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbt.o) - .data 0x00000000006e01a8 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parstr.o) - .data 0x00000000006e01a8 0xc /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parusr.o) - *fill* 0x00000000006e01b4 0xc - .data 0x00000000006e01c0 0x60 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parutg.o) - .data 0x00000000006e0220 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rcstpl.o) - .data 0x00000000006e0220 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgb.o) - .data 0x00000000006e0220 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(restd.o) - .data 0x00000000006e0220 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rsvfvm.o) - .data 0x00000000006e0220 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strcln.o) - .data 0x00000000006e0220 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabsub.o) - .data 0x00000000006e0224 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(uptdd.o) - .data 0x00000000006e0224 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdesc.o) - .data 0x00000000006e0224 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cadn30.o) - .data 0x00000000006e0224 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chekstab.o) - .data 0x00000000006e0224 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(inctab.o) - .data 0x00000000006e0224 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbb.o) - .data 0x00000000006e0224 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbd.o) - .data 0x00000000006e0224 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtbd.o) - .data 0x00000000006e0224 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabent.o) - .data 0x00000000006e0224 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(valx.o) - .data 0x00000000006e0224 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rjust.o) - *fill* 0x00000000006e0224 0x4 - .data 0x00000000006e0228 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) - 0x00000000006e0228 for__segv_default_msg - 0x00000000006e0230 for__l_current_arg - .data 0x00000000006e0238 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) - .data 0x00000000006e0238 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) - .data 0x00000000006e0238 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_preconnected_units_init.o) - *fill* 0x00000000006e0238 0x8 - .data 0x00000000006e0240 0x140 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_reentrancy.o) - 0x00000000006e0240 for__static_threadstor_private - .data 0x00000000006e0380 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_secnds.o) - .data 0x00000000006e0380 0x80 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_stop.o) - .data 0x00000000006e0400 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_vm.o) - .data 0x00000000006e0400 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wint_fmt.o) - .data 0x00000000006e0400 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_fmt.o) - .data 0x00000000006e0400 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_lis.o) - .data 0x00000000006e0400 0x4 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio_wrap.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_int.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_f.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_d.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_g.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cray.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_short.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_long.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_double.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_single.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close_proc.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_default_io_sizes_env_init.o) - .data 0x00000000006e0404 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_desc_item.o) - *fill* 0x00000000006e0404 0x1c - .data 0x00000000006e0420 0x1e80 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_diags_intel.o) - .data 0x00000000006e22a0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_exit.o) - .data 0x00000000006e22a0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_exit_handler.o) - .data 0x00000000006e22a0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_comp.o) - .data 0x00000000006e22a0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) - .data 0x00000000006e22a0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_get.o) - .data 0x00000000006e22a0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_intrp_fmt.o) - .data 0x00000000006e22a0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_ldir_wfs.o) - .data 0x00000000006e22a0 0xc /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_lub_mgt.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_need_lf.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_put.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(tbk_traceback.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt__globals.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_int_to_text.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_data_to_text.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_log_to_text.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_data.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_log.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_t.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_s.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_x.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_s.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_t.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_s_to_a.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_t_to_a.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_s.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_t.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_x.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_x_to_a.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_x.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_globals.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_53.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_64.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_128.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(fetestexcept.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_stub.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_stub.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_ct.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_ct.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_gen.o) - .data 0x00000000006e22ac 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_gen.o) - *fill* 0x00000000006e22ac 0x14 - .data 0x00000000006e22c0 0x3c0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(libm_error.o) - 0x00000000006e2660 __libm_pmatherrf - 0x00000000006e2668 __libm_pmatherr - 0x00000000006e2670 __libm_pmatherrl - 0x00000000006e267c _LIB_VERSIONIMF - .data 0x00000000006e2680 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherrf.o) - .data 0x00000000006e2680 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherrl.o) - .data 0x00000000006e2680 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherr.o) - .data 0x00000000006e2680 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ints2q.o) - .data 0x00000000006e2680 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(qcomp.o) - .data 0x00000000006e2680 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fp2q.o) - .data 0x00000000006e2680 0x28 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(q2fp.o) - .data 0x00000000006e26a8 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_display.o) - .data 0x00000000006e26a8 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_backtrace.o) - .data 0x00000000006e26a8 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(cpu_feature_disp.o) - .data 0x00000000006e26a8 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemcpy.o) - .data 0x00000000006e26a8 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemmove.o) - .data 0x00000000006e26a8 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemset.o) - *fill* 0x00000000006e26a8 0x18 - .data 0x00000000006e26c0 0x160 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(new_proc_init.o) - .data 0x00000000006e2820 0x28 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_addsubq.o) - .data 0x00000000006e2848 0x30 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_divq.o) - .data 0x00000000006e2878 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strcpy.o) - .data 0x00000000006e2878 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncpy.o) - .data 0x00000000006e2878 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strlen.o) - .data 0x00000000006e2878 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strchr.o) - .data 0x00000000006e2878 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncmp.o) - .data 0x00000000006e2878 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strcat.o) - .data 0x00000000006e2878 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncat.o) - .data 0x00000000006e2878 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_memcpy_pp.o) - .data 0x00000000006e2878 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_memset_pp.o) - .data 0x00000000006e2878 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memcpy.o) - .data 0x00000000006e2878 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memcpy.o) - .data 0x00000000006e2878 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memmove.o) - .data 0x00000000006e2878 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memmove.o) - .data 0x00000000006e2878 0x8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(irc_msg_support.o) - .data 0x00000000006e2880 0x820 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_mem_ops.o) - 0x00000000006e3080 __libirc_largest_cache_size - 0x00000000006e3084 __libirc_largest_cache_size_half - 0x00000000006e3088 __libirc_data_cache_size - 0x00000000006e308c __libirc_data_cache_size_half - .data 0x00000000006e30a0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(proc_init_utils.o) - .data 0x00000000006e30a0 0x0 /usr/lib64/libc_nonshared.a(elf-init.oS) - .data 0x00000000006e30a0 0x0 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - .data 0x00000000006e30a0 0x0 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtend.o - .data 0x00000000006e30a0 0x0 /usr/lib/../lib64/crtn.o - -.tm_clone_table - 0x00000000006e30a0 0x0 - .tm_clone_table - 0x00000000006e30a0 0x0 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtbegin.o - .tm_clone_table - 0x00000000006e30a0 0x0 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtend.o - -.data1 - *(.data1) - 0x00000000006e30a0 _edata = . - 0x00000000006e30a0 PROVIDE (edata, .) - 0x00000000006e30a0 . = . - 0x00000000006e30a0 __bss_start = . - -.bss 0x00000000006e30c0 0x2ebcf68 - *(.dynbss) - .dynbss 0x00000000006e30c0 0x18 /usr/lib/../lib64/crt1.o - 0x00000000006e30c0 stdin@@GLIBC_2.2.5 - 0x00000000006e30c8 stderr@@GLIBC_2.2.5 - 0x00000000006e30d0 stdout@@GLIBC_2.2.5 - *(.bss .bss.* .gnu.linkonce.b.*) - .bss 0x00000000006e30d8 0x0 /usr/lib/../lib64/crt1.o - .bss 0x00000000006e30d8 0x0 /usr/lib/../lib64/crti.o - .bss 0x00000000006e30d8 0x10 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtbegin.o - .bss 0x00000000006e30e8 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/for_main.o - *fill* 0x00000000006e30e8 0x18 - .bss 0x00000000006e3100 0x91360 rdbfmsua.o - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flclos.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flflun.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltbop.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltdat.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltinq.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stldsp.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlstr.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmbl.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmst.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbrstn.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flbksp.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flinqr.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flpath.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flsopn.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssenvr.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssgsym.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlcuc.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stuclc.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbastn.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flglun.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libbridge.a(dcbsrh.o) - .bss 0x0000000000774460 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ireadns.o) - .bss 0x0000000000774460 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) - *fill* 0x0000000000774464 0x1c - .bss 0x0000000000774480 0xc350 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapn.o) - *fill* 0x00000000007807d0 0x30 - .bss 0x0000000000780800 0xc350 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapx.o) - .bss 0x000000000078cb50 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgw.o) - .bss 0x000000000078cb50 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readdx.o) - .bss 0x000000000078cb50 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readns.o) - .bss 0x000000000078cb50 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) - .bss 0x000000000078cb50 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(status.o) - .bss 0x000000000078cb50 0x8 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) - .bss 0x000000000078cb58 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) - .bss 0x000000000078cb58 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upb.o) - .bss 0x000000000078cb58 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdlen.o) - *fill* 0x000000000078cb5c 0x24 - .bss 0x000000000078cb80 0xc350 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wtstat.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(adn30.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort2.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort_exit.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(conwin.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cpbfdx.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(drstpl.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxinit.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxmini.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getwin.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ibfms.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ichkstr.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ifxy.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invcon.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invwin.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ipkm.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(irev.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupm.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lmsg.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrpc.o) - .bss 0x0000000000798ed0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrps.o) - *fill* 0x0000000000798ed0 0x30 - .bss 0x0000000000798f00 0xc350 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) - .bss 0x00000000007a5250 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(newwin.o) - .bss 0x00000000007a5250 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nmwrd.o) - .bss 0x00000000007a5250 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nxtwin.o) - .bss 0x00000000007a5250 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ovrbs1.o) - .bss 0x00000000007a5254 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(padmsg.o) - .bss 0x00000000007a5254 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkb.o) - .bss 0x00000000007a5254 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkbs1.o) - .bss 0x00000000007a5254 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkc.o) - .bss 0x00000000007a5254 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pktdd.o) - .bss 0x00000000007a5254 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs01.o) - .bss 0x00000000007a5258 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs1.o) - *fill* 0x00000000007a525c 0x24 - .bss 0x00000000007a5280 0xc350 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) - .bss 0x00000000007b15d0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdcmps.o) - *fill* 0x00000000007b15d0 0x30 - .bss 0x00000000007b1600 0x13880 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdtree.o) - .bss 0x00000000007c4e80 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdusdx.o) - .bss 0x00000000007c4e80 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readmg.o) - .bss 0x00000000007c4e80 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(seqsdx.o) - .bss 0x00000000007c4e80 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(stndrd.o) - .bss 0x00000000007c4e80 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(string.o) - .bss 0x00000000007c4e80 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strnum.o) - .bss 0x00000000007c4e80 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strsuc.o) - .bss 0x00000000007c4e80 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(trybump.o) - .bss 0x00000000007c4e80 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upbb.o) - .bss 0x00000000007c4e80 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upc.o) - .bss 0x00000000007c4e80 0x3a980 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(usrtpl.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(capit.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrna.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrn.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cktaba.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cnved4.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(digit.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(elemdx.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getlens.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(gets1loc.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(i4dy.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(idn30.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(igetdate.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(istdesc.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupb.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupbs01.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstchr.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstnum.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstjpb.o) - .bss 0x00000000007ff800 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(makestab.o) - .bss 0x00000000007ff800 0x30d40 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(mvb.o) - .bss 0x0000000000830540 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemock.o) - .bss 0x0000000000830540 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtab.o) - .bss 0x0000000000830540 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbax.o) - .bss 0x0000000000830540 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenuaa.o) - .bss 0x0000000000830540 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenubd.o) - .bss 0x0000000000830540 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numbck.o) - .bss 0x0000000000830540 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtab.o) - .bss 0x0000000000830540 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbt.o) - .bss 0x0000000000830540 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parstr.o) - .bss 0x0000000000830540 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parusr.o) - .bss 0x0000000000830540 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parutg.o) - .bss 0x0000000000830540 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rcstpl.o) - .bss 0x0000000000830540 0x186a0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgb.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(restd.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rsvfvm.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strcln.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabsub.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(uptdd.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdesc.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cadn30.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chekstab.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(inctab.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbb.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbd.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtbd.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabent.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(valx.o) - .bss 0x0000000000848be0 0x0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rjust.o) - .bss 0x0000000000848be0 0x48 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) - 0x0000000000848bf0 for__l_excpt_info - 0x0000000000848bfc for__l_fpe_mask - 0x0000000000848c00 for__l_undcnt - 0x0000000000848c04 for__l_ovfcnt - 0x0000000000848c08 for__l_div0cnt - 0x0000000000848c0c for__l_invcnt - 0x0000000000848c10 for__l_inecnt - 0x0000000000848c14 for__l_fmtrecl - 0x0000000000848c18 for__l_ufmtrecl - 0x0000000000848c1c for__l_blocksize - 0x0000000000848c20 for__l_buffercount - .bss 0x0000000000848c28 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_io_util.o) - *fill* 0x0000000000848c28 0x18 - .bss 0x0000000000848c40 0x440 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open.o) - 0x0000000000849060 for__l_exit_hand_decl - .bss 0x0000000000849080 0x15e0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_preconnected_units_init.o) - .bss 0x000000000084a660 0x18 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_reentrancy.o) - 0x000000000084a670 for__reentrancy_mode - 0x000000000084a674 for__reentrancy_initialized - .bss 0x000000000084a678 0x4 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_secnds.o) - .bss 0x000000000084a67c 0x8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_stop.o) - .bss 0x000000000084a684 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_vm.o) - .bss 0x000000000084a694 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wint_fmt.o) - .bss 0x000000000084a694 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_fmt.o) - .bss 0x000000000084a694 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq_lis.o) - *fill* 0x000000000084a694 0x4 - .bss 0x000000000084a698 0xd8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) - 0x000000000084a740 for__aio_global_mutex - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_open_proc.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio_wrap.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_int.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_f.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_d.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_vax_g.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cray.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_short.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ibm_long.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_double.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_ieee_single.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_close_proc.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_default_io_sizes_env_init.o) - .bss 0x000000000084a770 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_desc_item.o) - *fill* 0x000000000084a770 0x10 - .bss 0x000000000084a780 0x260 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_diags_intel.o) - 0x000000000084a9a0 for__user_iomsg_buf - 0x000000000084a9a8 for__user_iomsg_len - .bss 0x000000000084a9e0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_exit.o) - .bss 0x000000000084a9e0 0x4 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_exit_handler.o) - 0x000000000084a9e0 for__l_exit_termination - .bss 0x000000000084a9e4 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_comp.o) - .bss 0x000000000084a9e4 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_fmt_val.o) - .bss 0x000000000084a9e4 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_get.o) - .bss 0x000000000084a9e4 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_intrp_fmt.o) - .bss 0x000000000084a9e4 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_ldir_wfs.o) - *fill* 0x000000000084a9e4 0x1c - .bss 0x000000000084aa00 0x2760 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_lub_mgt.o) - 0x000000000084aa20 for__lub_table - .bss 0x000000000084d160 0x20a0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_need_lf.o) - 0x000000000084d160 for__file_info_hash_table - .bss 0x000000000084f200 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_put.o) - .bss 0x000000000084f200 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_wseq.o) - .bss 0x000000000084f200 0x4 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(tbk_traceback.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt__globals.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_int_to_text.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_data_to_text.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_log_to_text.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_data.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_text_to_log.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_t.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_s.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvt_cvtas_x.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_s.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_t.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_s_to_a.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_t_to_a.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_s.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_t.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_a_to_x.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_x_to_a.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_nan_x.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_globals.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_53.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_64.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(cvtas_pow_ten_128.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(fetestexcept.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_stub.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_stub.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_ct.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_ct.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_gen.o) - .bss 0x000000000084f204 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_gen.o) - *fill* 0x000000000084f204 0x4 - .bss 0x000000000084f208 0x8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(libm_error.o) - .bss 0x000000000084f210 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherrf.o) - .bss 0x000000000084f210 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherrl.o) - .bss 0x000000000084f210 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(matherr.o) - .bss 0x000000000084f210 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ints2q.o) - .bss 0x000000000084f210 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(qcomp.o) - .bss 0x000000000084f210 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fp2q.o) - .bss 0x000000000084f210 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(q2fp.o) - .bss 0x000000000084f210 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_display.o) - *fill* 0x000000000084f210 0x10 - .bss 0x000000000084f220 0x180 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(tbk_backtrace.o) - 0x000000000084f2c0 tbk__jmp_env - .bss 0x000000000084f3a0 0x10 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(cpu_feature_disp.o) - 0x000000000084f3a0 __intel_cpu_feature_indicator - 0x000000000084f3a8 __intel_cpu_feature_indicator_x - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemcpy.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemmove.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemset.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(new_proc_init.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_addsubq.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_divq.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strcpy.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncpy.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strlen.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strchr.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncmp.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strcat.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(sse2_strncat.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_memcpy_pp.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_memset_pp.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memcpy.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memcpy.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_memmove.o) - .bss 0x000000000084f3b0 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(intel_ssse3_rep_memmove.o) - *fill* 0x000000000084f3b0 0x10 - .bss 0x000000000084f3c0 0x420 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(irc_msg_support.o) - .bss 0x000000000084f7e0 0x60 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fast_mem_ops.o) - 0x000000000084f824 __libirc_mem_ops_method - 0x000000000084f828 __libirc_largest_cachelinesize - .bss 0x000000000084f840 0x0 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(proc_init_utils.o) - .bss 0x000000000084f840 0x0 /usr/lib64/libc_nonshared.a(elf-init.oS) - .bss 0x000000000084f840 0x0 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - .bss 0x000000000084f840 0x0 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtend.o - .bss 0x000000000084f840 0x0 /usr/lib/../lib64/crtn.o - *(COMMON) - COMMON 0x000000000084f840 0x1c4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flflun.o) - 0x000000000084f840 gmbdta_ - *fill* 0x000000000084fa04 0x3c - COMMON 0x000000000084fa40 0x484 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) - 0x000000000084fa40 stbfr_ - 0x000000000084fb40 nulbfr_ - 0x000000000084fbc0 msgfmt_ - 0x000000000084fc40 msgcwd_ - 0x000000000084fec0 quiet_ - *fill* 0x000000000084fec4 0x1c - COMMON 0x000000000084fee0 0x2c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgw.o) - 0x000000000084fee0 hrdwrd_ - *fill* 0x000000000084ff0c 0x34 - COMMON 0x000000000084ff40 0x13d628 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readns.o) - 0x000000000084ff40 tables_ - *fill* 0x000000000098d568 0x18 - COMMON 0x000000000098d580 0x192e80 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) - 0x000000000098d580 bitbuf_ - 0x0000000000b20380 unptyp_ - COMMON 0x0000000000b20400 0x753150 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) - 0x0000000000b20400 usrint_ - 0x0000000001273480 usrstr_ - *fill* 0x0000000001273550 0x30 - COMMON 0x0000000001273580 0x804 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdlen.o) - 0x0000000001273580 charac_ - *fill* 0x0000000001273d84 0x3c - COMMON 0x0000000001273dc0 0xbbe88c /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) - 0x0000000001273dc0 dxtab_ - 0x00000000012740c0 tababd_ - *fill* 0x0000000001e3264c 0x34 - COMMON 0x0000000001e32680 0x188d4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) - 0x0000000001e32680 maxcmp_ - 0x0000000001e326a0 msgstd_ - 0x0000000001e326c0 reptab_ - 0x0000000001e32740 bufrmg_ - 0x0000000001e3eaa0 msgcmp_ - 0x0000000001e3eac0 acmode_ - 0x0000000001e3eb00 bufrsr_ - 0x0000000001e4af00 dateln_ - 0x0000000001e4af20 mrgcom_ - 0x0000000001e4af40 padesc_ - *fill* 0x0000000001e4af54 0x2c - COMMON 0x0000000001e4af80 0xfc /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) - 0x0000000001e4af80 s01cm_ - 0x0000000001e4b000 sect01_ - *fill* 0x0000000001e4b07c 0x4 - COMMON 0x0000000001e4b080 0x27100 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdtree.o) - 0x0000000001e4b080 usrbit_ - COMMON 0x0000000001e72180 0x4a3c0 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(string.o) - 0x0000000001e72180 stcach_ - 0x0000000001eba600 stords_ - COMMON 0x0000000001ebc540 0x4 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parutg.o) - 0x0000000001ebc540 utgprm_ - *fill* 0x0000000001ebc544 0x3c - COMMON 0x0000000001ebc580 0x16e3600 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rcstpl.o) - 0x0000000001ebc580 usrtmp_ - COMMON 0x000000000359fb80 0x10 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabsub.o) - 0x000000000359fb80 tabccc_ - COMMON 0x000000000359fb90 0xc /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_init.o) - 0x000000000359fb90 for__a_argv - 0x000000000359fb98 for__l_argc - *fill* 0x000000000359fb9c 0x4 - COMMON 0x000000000359fba0 0x480 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_aio.o) - 0x000000000359fba0 thread_count_mutex - 0x000000000359fbc8 threads_in_flight_mutex - 0x000000000359fbf0 for__pthread_mutex_unlock_ptr - 0x000000000359fbf8 for__pthread_mutex_init_ptr - 0x000000000359fc00 for__pthread_mutex_lock_ptr - 0x000000000359fc20 for__aio_lub_table - COMMON 0x00000000035a0020 0x8 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libifcore.a(for_diags_intel.o) - 0x00000000035a0020 message_catalog - 0x00000000035a0028 . = ALIGN ((. != 0x0)?0x8:0x1) - -.lbss - *(.dynlbss) - *(.lbss .lbss.* .gnu.linkonce.lb.*) - *(LARGE_COMMON) - 0x00000000035a0028 . = ALIGN (0x8) - -.lrodata - *(.lrodata .lrodata.* .gnu.linkonce.lr.*) - -.ldata 0x00000000039a0028 0x0 - *(.ldata .ldata.* .gnu.linkonce.l.*) - 0x00000000039a0028 . = ALIGN ((. != 0x0)?0x8:0x1) - 0x00000000039a0028 . = ALIGN (0x8) - 0x00000000039a0028 _end = . - 0x00000000039a0028 PROVIDE (end, .) - 0x00000000039a0028 . = DATA_SEGMENT_END (.) - -.stab - *(.stab) - -.stabstr - *(.stabstr) - -.stab.excl - *(.stab.excl) - -.stab.exclstr - *(.stab.exclstr) - -.stab.index - *(.stab.index) - -.stab.indexstr - *(.stab.indexstr) - -.comment 0x0000000000000000 0x73 - *(.comment) - .comment 0x0000000000000000 0x39 /usr/lib/../lib64/crt1.o - 0x3a (size before relaxing) - .comment 0x0000000000000000 0x3a /usr/lib/../lib64/crti.o - .comment 0x0000000000000039 0x26 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtbegin.o - 0x27 (size before relaxing) - .comment 0x000000000000005f 0x14 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/for_main.o - .comment 0x0000000000000000 0x14 rdbfmsua.o - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flclos.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flflun.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltbop.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltdat.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(fltinq.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stldsp.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlstr.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmbl.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(strmst.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbrstn.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flbksp.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flinqr.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flpath.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flsopn.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssenvr.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(ssgsym.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stlcuc.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(stuclc.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(tbastn.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libgemlib.a(flglun.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libbridge.a(dcbsrh.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ireadns.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbf.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapn.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(posapx.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgw.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readdx.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readns.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readsb.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(status.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbint.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ufbrw.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upb.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdlen.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(writdx.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wtstat.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(adn30.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bfrini.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort2.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort_exit.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(bort.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(conwin.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cpbfdx.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(drstpl.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxinit.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(dxmini.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getwin.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ibfms.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ichkstr.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ifxy.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invcon.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(invwin.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ipkm.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(irev.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupm.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lmsg.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrpc.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstrps.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(msgwrt.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(newwin.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nmwrd.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nxtwin.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(ovrbs1.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(padmsg.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkb.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkbs1.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkc.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pktdd.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs01.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(pkvs1.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdbfdx.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdcmps.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdtree.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdusdx.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(readmg.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(seqsdx.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(stndrd.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(string.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strnum.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strsuc.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(trybump.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upbb.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(upc.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(usrtpl.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(capit.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrna.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chrtrn.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cktaba.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cnved4.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(digit.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(elemdx.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(getlens.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(gets1loc.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(i4dy.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(idn30.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(igetdate.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(istdesc.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupb.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(iupbs01.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstchr.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(jstnum.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(lstjpb.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(makestab.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(mvb.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemock.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtab.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbax.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenuaa.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nenubd.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numbck.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtab.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(openbt.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parstr.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parusr.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(parutg.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rcstpl.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rdmsgb.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(restd.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rsvfvm.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(strcln.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabsub.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(uptdd.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(wrdesc.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(cadn30.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(chekstab.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(inctab.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbb.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(nemtbd.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(numtbd.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(tabent.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(valx.o) - .comment 0x0000000000000000 0x27 /gpfs/hps/nco/ops/nwprod/gempak.v6.32.0/nawips/os/linux3.0.101_x86_64/lib/libncepBUFR.a(rjust.o) - .comment 0x0000000000000000 0x14 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lroundf_stub.o) - .comment 0x0000000000000000 0x14 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libimf.a(lround_stub.o) - .comment 0x0000000000000000 0x14 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemcpy.o) - .comment 0x0000000000000000 0x14 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemmove.o) - .comment 0x0000000000000000 0x14 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(fastmemset.o) - .comment 0x0000000000000000 0x14 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_addsubq.o) - .comment 0x0000000000000000 0x14 /opt/intel/composer_xe_2015.3.187/compiler/lib/intel64/libirc.a(ia32_divq.o) - .comment 0x0000000000000000 0x27 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - .comment 0x0000000000000000 0x27 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2/crtend.o - .comment 0x0000000000000000 0x3a /usr/lib/../lib64/crtn.o - -.debug - *(.debug) - -.line - *(.line) - -.debug_srcinfo - *(.debug_srcinfo) - -.debug_sfnames - *(.debug_sfnames) - -.debug_aranges 0x0000000000000000 0x90 - *(.debug_aranges) - .debug_aranges - 0x0000000000000000 0x30 /usr/lib/../lib64/crt1.o - .debug_aranges - 0x0000000000000030 0x30 /usr/lib64/libc_nonshared.a(elf-init.oS) - .debug_aranges - 0x0000000000000060 0x30 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - -.debug_pubnames - 0x0000000000000000 0x5f - *(.debug_pubnames) - .debug_pubnames - 0x0000000000000000 0x25 /usr/lib/../lib64/crt1.o - .debug_pubnames - 0x0000000000000025 0x3a /usr/lib64/libc_nonshared.a(elf-init.oS) - -.debug_info 0x0000000000000000 0x58e - *(.debug_info .gnu.linkonce.wi.*) - .debug_info 0x0000000000000000 0x102 /usr/lib/../lib64/crt1.o - .debug_info 0x0000000000000102 0x130 /usr/lib64/libc_nonshared.a(elf-init.oS) - .debug_info 0x0000000000000232 0x35c /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - -.debug_abbrev 0x0000000000000000 0x22d - *(.debug_abbrev) - .debug_abbrev 0x0000000000000000 0x5f /usr/lib/../lib64/crt1.o - .debug_abbrev 0x000000000000005f 0xd4 /usr/lib64/libc_nonshared.a(elf-init.oS) - .debug_abbrev 0x0000000000000133 0xfa /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - -.debug_line 0x0000000000000000 0x22c - *(.debug_line) - .debug_line 0x0000000000000000 0x88 /usr/lib/../lib64/crt1.o - .debug_line 0x0000000000000088 0x96 /usr/lib64/libc_nonshared.a(elf-init.oS) - .debug_line 0x000000000000011e 0x10e /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - -.debug_frame 0x0000000000000000 0x58 - *(.debug_frame) - .debug_frame 0x0000000000000000 0x58 /usr/lib64/libc_nonshared.a(elf-init.oS) - -.debug_str 0x0000000000000000 0x428 - *(.debug_str) - .debug_str 0x0000000000000000 0x90 /usr/lib/../lib64/crt1.o - 0xd0 (size before relaxing) - .debug_str 0x0000000000000090 0x6a /usr/lib64/libc_nonshared.a(elf-init.oS) - 0xe0 (size before relaxing) - .debug_str 0x00000000000000fa 0x32e /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - 0x3ba (size before relaxing) - -.debug_loc 0x0000000000000000 0x1b7 - *(.debug_loc) - .debug_loc 0x0000000000000000 0xfe /usr/lib64/libc_nonshared.a(elf-init.oS) - .debug_loc 0x00000000000000fe 0xb9 /opt/gcc/4.9.2/snos/lib/gcc/x86_64-suse-linux/4.9.2//libgcc.a(_powidf2.o) - -.debug_macinfo - *(.debug_macinfo) - -.debug_weaknames - *(.debug_weaknames) - -.debug_funcnames - *(.debug_funcnames) - -.debug_typenames - *(.debug_typenames) - -.debug_varnames - *(.debug_varnames) - -.debug_pubtypes - *(.debug_pubtypes) - -.debug_ranges 0x0000000000000000 0x50 - *(.debug_ranges) - .debug_ranges 0x0000000000000000 0x50 /usr/lib64/libc_nonshared.a(elf-init.oS) - -.debug_macro - *(.debug_macro) - -.gnu.attributes - *(.gnu.attributes) - -/DISCARD/ - *(.note.GNU-stack) - *(.gnu_debuglink) - *(.gnu.lto_*) -OUTPUT(rdbfmsua elf64-x86-64) diff --git a/util/sorc/rdbfmsua.fd/README b/util/sorc/rdbfmsua.fd/README deleted file mode 100755 index 4128761bcf..0000000000 --- a/util/sorc/rdbfmsua.fd/README +++ /dev/null @@ -1,2 +0,0 @@ -added libgem.a and changed libbufr_4_32 to 64-bit. -also changed -m32 -m64. diff --git a/util/sorc/rdbfmsua.fd/README.new b/util/sorc/rdbfmsua.fd/README.new deleted file mode 100755 index f72a61f38a..0000000000 --- a/util/sorc/rdbfmsua.fd/README.new +++ /dev/null @@ -1,10 +0,0 @@ -added libgem.a and changed libbufr_4_32 to 64-bit. -also changed -m32 -m64. - -# JY - 02/09/2016 -Run the following command before run the "make" - . /nwprod/gempak/.gempak - -# Boi - 09/10/2016 -on CRAY -module load gempak/6.32.0 diff --git a/util/sorc/rdbfmsua.fd/compile_rdbfmsua_wcoss.sh b/util/sorc/rdbfmsua.fd/compile_rdbfmsua_wcoss.sh deleted file mode 100755 index 872434108d..0000000000 --- a/util/sorc/rdbfmsua.fd/compile_rdbfmsua_wcoss.sh +++ /dev/null @@ -1,43 +0,0 @@ -#!/bin/sh - -###################################################################### -# -# Build executable : GFS utilities -# -###################################################################### - -LMOD_EXACT_MATCH=no -source ../../../sorc/machine-setup.sh > /dev/null 2>&1 -cwd=`pwd` - -if [ "$target" = "wcoss_dell_p3" ] || [ "$target" = "wcoss_cray" ] || [ "$target" = "hera" ] ; then - echo " " - echo " You are on WCOSS: $target " - echo " " -elif [ "$target" = "wcoss" ] ; then - echo " " - echo " " - echo " You are on WCOSS: $target " - echo " You do not need to build GFS utilities for GFS V15.0.0 " - echo " " - echo " " - exit -else - echo " " - echo " Your machine is $target is not recognized as a WCOSS machine." - echo " The script $0 can not continue. Aborting!" - echo " " - exit -fi -echo " " - -# Load required modules -source ../../modulefiles/gfs_util.${target} -module list - -set -x - -mkdir -p ../../exec -make -f makefile.$target -make -f makefile.$target clean -mv rdbfmsua ../../exec diff --git a/util/sorc/rdbfmsua.fd/makefile b/util/sorc/rdbfmsua.fd/makefile deleted file mode 100755 index 69d183f394..0000000000 --- a/util/sorc/rdbfmsua.fd/makefile +++ /dev/null @@ -1,84 +0,0 @@ -SHELL=/bin/sh -# -# This makefile was produced by /usr/bin/fmgen at 11:21:07 AM on 10/28/94 -# If it is invoked by the command line -# make -f makefile -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable named a.out. -# -# If it is invoked by the command line -# make -f makefile a.out.prof -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable which profiles -# named a.out.prof. -# -# To remove all the objects but leave the executables use the command line -# make -f makefile clean -# -# To remove everything but the source files use the command line -# make -f makefile clobber -# -# To remove the source files created by /usr/bin/fmgen and this makefile -# use the command line -# make -f makefile void -# -# The parameters SRCS and OBJS should not need to be changed. If, however, -# you need to add a new module add the name of the source module to the -# SRCS parameter and add the name of the resulting object file to the OBJS -# parameter. The new modules are not limited to fortran, but may be C, YACC, -# LEX, or CAL. An explicit rule will need to be added for PASCAL modules. -# -OBJS= rdbfmsua.o - - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# -FC = ifort -# FFLAGS = -O3 -q32 -I${GEMINC} -I${NAWIPS}/os/${NA_OS}/include -# FFLAGS = -I${GEMINC} -I${NAWIPS}/os/${NA_OS}/include -FFLAGS = -I${GEMINC} -I${OS_INC} -# LDFLAGS = -O3 -q32 -s -# LDFLAGS = -Wl,-Map,MAPFILE - -# BRIDGE=/gpfs/dell1/nco/ops/nwpara/gempak.v7.3.1/nawips/os/linux3.10.0_x86_64/lib/libbridge.a -BRIDGE=${GEMOLB}/libbridge.a - -LIBS = ${DECOD_UT_LIB} ${BUFR_LIB4} \ - -L${GEMOLB} -lgemlib -lappl -lsyslib -lcgemlib -lgfortran ${BRIDGE} - -# -L${GEMOLB} -lgemlib -lappl -lsyslib -lcgemlib -lgfortran ${BRIDGE} -# -L/nwprod/gempak/nawips1/os/linux2.6.32_x86_64/lib -lgemlib -lappl -lsyslib -lcgemlib -lbridge -lncepBUFR \ -# -lgfortran - -CMD = rdbfmsua - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# CFLAGS= -O3 -q32 - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# - -$(CMD): $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(LIBS) - - -# The following rule reads the required NAWIPS definitions and then recursively -# runs this same makefile with a new target in the spawned shell. -# - -clean: - -rm -f ${OBJS} - -clobber: clean - -rm -f ${CMD} - -void: clobber - -rm -f ${SRCS} makefile diff --git a/util/sorc/rdbfmsua.fd/makefile.hera b/util/sorc/rdbfmsua.fd/makefile.hera deleted file mode 100755 index a1359e6cb8..0000000000 --- a/util/sorc/rdbfmsua.fd/makefile.hera +++ /dev/null @@ -1,88 +0,0 @@ -SHELL=/bin/sh -# -# This makefile was produced by /usr/bin/fmgen at 11:21:07 AM on 10/28/94 -# If it is invoked by the command line -# make -f makefile -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable named a.out. -# -# If it is invoked by the command line -# make -f makefile a.out.prof -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable which profiles -# named a.out.prof. -# -# To remove all the objects but leave the executables use the command line -# make -f makefile clean -# -# To remove everything but the source files use the command line -# make -f makefile clobber -# -# To remove the source files created by /usr/bin/fmgen and this makefile -# use the command line -# make -f makefile void -# -# The parameters SRCS and OBJS should not need to be changed. If, however, -# you need to add a new module add the name of the source module to the -# SRCS parameter and add the name of the resulting object file to the OBJS -# parameter. The new modules are not limited to fortran, but may be C, YACC, -# LEX, or CAL. An explicit rule will need to be added for PASCAL modules. -# -OBJS= rdbfmsua.o - - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# -FC = ifort -# FFLAGS = -O3 -q32 -I${GEMINC} -I${NAWIPS}/os/${NA_OS}/include -# FFLAGS = -I${GEMINC} -I${NAWIPS}/os/${NA_OS}/include -FFLAGS = -I${GEMINC} -I${OS_INC} -# LDFLAGS = -O3 -q32 -s -# LDFLAGS = -Wl,-Map,MAPFILE - -# BRIDGE=/gpfs/dell1/nco/ops/nwpara/gempak.v7.3.1/nawips/os/linux3.10.0_x86_64/lib/libbridge.a -BRIDGE=${GEMOLB}/bridge.a -GFORTRAN=/apps/gcc/6.2.0/lib64 - -LIBS = ${DECOD_UT_LIB} ${BUFR_LIB4} \ - ${GEMLIB}/gemlib.a ${GEMLIB}/appl.a ${GEMLIB}/syslib.a ${GEMLIB}/cgemlib.a -L${GFORTRAN} -lgfortran ${BRIDGE} - -# LIBS = ${DECOD_UT_LIB} ${BUFR_LIB4} \ -# -L${GEMOLB} -lgemlib -lappl -lsyslib -lcgemlib -lgfortran ${BRIDGE} - -# -L${GEMOLB} -lgemlib -lappl -lsyslib -lcgemlib -lgfortran ${BRIDGE} -# -L/nwprod/gempak/nawips1/os/linux2.6.32_x86_64/lib -lgemlib -lappl -lsyslib -lcgemlib -lbridge -lncepBUFR \ -# -lgfortran - -CMD = rdbfmsua - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# CFLAGS= -O3 -q32 - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# - -$(CMD): $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(LIBS) - - -# The following rule reads the required NAWIPS definitions and then recursively -# runs this same makefile with a new target in the spawned shell. -# - -clean: - -rm -f ${OBJS} - -clobber: clean - -rm -f ${CMD} - -void: clobber - -rm -f ${SRCS} makefile diff --git a/util/sorc/rdbfmsua.fd/makefile.wcoss_cray b/util/sorc/rdbfmsua.fd/makefile.wcoss_cray deleted file mode 100755 index 69d183f394..0000000000 --- a/util/sorc/rdbfmsua.fd/makefile.wcoss_cray +++ /dev/null @@ -1,84 +0,0 @@ -SHELL=/bin/sh -# -# This makefile was produced by /usr/bin/fmgen at 11:21:07 AM on 10/28/94 -# If it is invoked by the command line -# make -f makefile -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable named a.out. -# -# If it is invoked by the command line -# make -f makefile a.out.prof -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable which profiles -# named a.out.prof. -# -# To remove all the objects but leave the executables use the command line -# make -f makefile clean -# -# To remove everything but the source files use the command line -# make -f makefile clobber -# -# To remove the source files created by /usr/bin/fmgen and this makefile -# use the command line -# make -f makefile void -# -# The parameters SRCS and OBJS should not need to be changed. If, however, -# you need to add a new module add the name of the source module to the -# SRCS parameter and add the name of the resulting object file to the OBJS -# parameter. The new modules are not limited to fortran, but may be C, YACC, -# LEX, or CAL. An explicit rule will need to be added for PASCAL modules. -# -OBJS= rdbfmsua.o - - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# -FC = ifort -# FFLAGS = -O3 -q32 -I${GEMINC} -I${NAWIPS}/os/${NA_OS}/include -# FFLAGS = -I${GEMINC} -I${NAWIPS}/os/${NA_OS}/include -FFLAGS = -I${GEMINC} -I${OS_INC} -# LDFLAGS = -O3 -q32 -s -# LDFLAGS = -Wl,-Map,MAPFILE - -# BRIDGE=/gpfs/dell1/nco/ops/nwpara/gempak.v7.3.1/nawips/os/linux3.10.0_x86_64/lib/libbridge.a -BRIDGE=${GEMOLB}/libbridge.a - -LIBS = ${DECOD_UT_LIB} ${BUFR_LIB4} \ - -L${GEMOLB} -lgemlib -lappl -lsyslib -lcgemlib -lgfortran ${BRIDGE} - -# -L${GEMOLB} -lgemlib -lappl -lsyslib -lcgemlib -lgfortran ${BRIDGE} -# -L/nwprod/gempak/nawips1/os/linux2.6.32_x86_64/lib -lgemlib -lappl -lsyslib -lcgemlib -lbridge -lncepBUFR \ -# -lgfortran - -CMD = rdbfmsua - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# CFLAGS= -O3 -q32 - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# - -$(CMD): $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(LIBS) - - -# The following rule reads the required NAWIPS definitions and then recursively -# runs this same makefile with a new target in the spawned shell. -# - -clean: - -rm -f ${OBJS} - -clobber: clean - -rm -f ${CMD} - -void: clobber - -rm -f ${SRCS} makefile diff --git a/util/sorc/rdbfmsua.fd/makefile.wcoss_dell_p3 b/util/sorc/rdbfmsua.fd/makefile.wcoss_dell_p3 deleted file mode 100755 index 69d183f394..0000000000 --- a/util/sorc/rdbfmsua.fd/makefile.wcoss_dell_p3 +++ /dev/null @@ -1,84 +0,0 @@ -SHELL=/bin/sh -# -# This makefile was produced by /usr/bin/fmgen at 11:21:07 AM on 10/28/94 -# If it is invoked by the command line -# make -f makefile -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable named a.out. -# -# If it is invoked by the command line -# make -f makefile a.out.prof -# it will compile the fortran modules indicated by SRCS into the object -# modules indicated by OBJS and produce an executable which profiles -# named a.out.prof. -# -# To remove all the objects but leave the executables use the command line -# make -f makefile clean -# -# To remove everything but the source files use the command line -# make -f makefile clobber -# -# To remove the source files created by /usr/bin/fmgen and this makefile -# use the command line -# make -f makefile void -# -# The parameters SRCS and OBJS should not need to be changed. If, however, -# you need to add a new module add the name of the source module to the -# SRCS parameter and add the name of the resulting object file to the OBJS -# parameter. The new modules are not limited to fortran, but may be C, YACC, -# LEX, or CAL. An explicit rule will need to be added for PASCAL modules. -# -OBJS= rdbfmsua.o - - -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# -FC = ifort -# FFLAGS = -O3 -q32 -I${GEMINC} -I${NAWIPS}/os/${NA_OS}/include -# FFLAGS = -I${GEMINC} -I${NAWIPS}/os/${NA_OS}/include -FFLAGS = -I${GEMINC} -I${OS_INC} -# LDFLAGS = -O3 -q32 -s -# LDFLAGS = -Wl,-Map,MAPFILE - -# BRIDGE=/gpfs/dell1/nco/ops/nwpara/gempak.v7.3.1/nawips/os/linux3.10.0_x86_64/lib/libbridge.a -BRIDGE=${GEMOLB}/libbridge.a - -LIBS = ${DECOD_UT_LIB} ${BUFR_LIB4} \ - -L${GEMOLB} -lgemlib -lappl -lsyslib -lcgemlib -lgfortran ${BRIDGE} - -# -L${GEMOLB} -lgemlib -lappl -lsyslib -lcgemlib -lgfortran ${BRIDGE} -# -L/nwprod/gempak/nawips1/os/linux2.6.32_x86_64/lib -lgemlib -lappl -lsyslib -lcgemlib -lbridge -lncepBUFR \ -# -lgfortran - -CMD = rdbfmsua - -# To perform the default compilation, use the first line -# To compile with flowtracing turned on, use the second line -# To compile giving profile additonal information, use the third line -# CFLAGS= -O3 -q32 - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# - -$(CMD): $(OBJS) - $(FC) $(LDFLAGS) -o $(@) $(OBJS) $(LIBS) - - -# The following rule reads the required NAWIPS definitions and then recursively -# runs this same makefile with a new target in the spawned shell. -# - -clean: - -rm -f ${OBJS} - -clobber: clean - -rm -f ${CMD} - -void: clobber - -rm -f ${SRCS} makefile diff --git a/util/sorc/rdbfmsua.fd/rdbfmsua.f b/util/sorc/rdbfmsua.fd/rdbfmsua.f deleted file mode 100755 index c2d5088920..0000000000 --- a/util/sorc/rdbfmsua.fd/rdbfmsua.f +++ /dev/null @@ -1,398 +0,0 @@ - PROGRAM RDBFUA -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C -C MAIN PROGRAM: RDBFUA -C PRGMMR: J. ATOR ORG: NP12 DATE: 2007-08-13 -C -C ABSTRACT: Upper Air Plotted Data for levels 1000MB; 925MB; 850MB; 700MB; -C 500MB; 400MB; 300MB; 250MB; 200MB; 150MB, and 100MB for the -C following regions: 1)United States; 2)Canada; 3)Alaska; and, -C the 4)Mexico and Caribbean. Note that Alaska includes eastern -C Russia. Also adding South America, Africa, and the Pacific. -C -C PROGRAM HISTORY LOG: -C -C 2007-08-13 J. ATOR -- ORIGINAL AUTHOR -C 2007-08-20 C. Magee -- Added block 25 (eastern Russia) -C 2007-09-20 S. Lilly -- Changing to read blks 60 thru 91. -C 2007-09-20 C. Magee -- Added code to read upper air and metar stn tables -C 2007-09-25 S. Lilly -- Added logic to write statements in order to put STID, -C STNM and TIME on the same line. -C 2007-09-27 C. Magee -- Change output for stntbl.out. Use st_rmbl to remove -C leading blank from reportid if internal write was -C used to convert integer WMO block/stn number to -C char report id. -C 2012-01-24 J. Cahoon -- Modified from original RDBFUA to include -C significant and standard together in output -C 2012-02-15 B. Mabe -- Changed Program name and output file to reflect -C change to output for sig and man data -C 2016-10-18 B. Vuong -- Removed hardwire '/nwprod/dictionaries/' in CALL FL_TBOP -C 2020-01-15 B. Vuong -- Increased dimensional array r8lvl(6,200) -C -C USAGE: -C INPUT FILES: -C UNIT 40 - adpupa dumpfile (contains data from BUFR tank b002/xx001) -C -C sonde.land.tbl -C metar.tbl -C -C OUTPUT FILES: -C UNIT 51 - rdbfmsua.out - contains ASCII upper air data for the desired -C stations. -C UNIT 52 - stnmstbl.out - contains ASCII station table info for use by -C html generator. -C -C SUBPROGRAMS CALLED: -C UNIQUE: -C LIBRARY: BUFRLIB - OPENBF UFBINT -C GEMLIB - FL_TBOP ST_RMBL TB_RSTN -C BRIDGE - DC_BSRH -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE : IBM-SP -C -C$$$ - INCLUDE 'GEMPRM.PRM' - INCLUDE 'BRIDGE.PRM' -C*---------------------------------------------------------------------- -C* Set the name of the output file. -C*---------------------------------------------------------------------- - - CHARACTER*(*) FLO, STNO - - PARAMETER ( FLO = 'rdbfmsua.out' ) - PARAMETER ( STNO = 'sonde.idsms.tbl' ) - - REAL*8 BFMSNG - PARAMETER ( BFMSNG = 10.0E10 ) - - PARAMETER ( GPMSNG = -9999.0 ) - PARAMETER ( MAXSTN = 10000 ) - - REAL*8 r8hdr ( 9, 1 ), r8lvl ( 6, 200 ), r8arr( 1, 1 ) - REAL*8 r8tmp ( 6, 100 ), r8out ( 6, 300 ),swpbuf - REAL*8 r8tmptot ( 6, 300 ) - - CHARACTER*8 cmgtag, reportid - CHARACTER stnnam*32, tbchrs*20, state*2, tabcon*2 - CHARACTER ldcoun( LLSTFL )*2, mtcoun ( MAXSTN )*2 - CHARACTER ldstid ( LLSTFL )*8, mtstid ( MAXSTN )*8 - INTEGER ldstnm ( LLSTFL ), mtstnm ( MAXSTN ), ispri - INTEGER itabnum - REAL slat, slon, selv - LOGICAL nomatch, needHeader - -C*---------------------------------------------------------------------- -C* Open and read the sonde land station table. -C*---------------------------------------------------------------------- - CALL FL_TBOP ( 'sonde.land.tbl', - + 'stns', iunltb, iertop ) - IF ( iertop .ne. 0 ) THEN - print*,' error opening sonde land station table' - END IF - - ii = 1 - ierrst = 0 - DO WHILE ( ( ii .le. LLSTFL ) .and. ( ierrst .eq. 0 ) ) - CALL TB_RSTN ( iunltb, ldstid (ii), stnnam, ldstnm (ii), - + state, ldcoun (ii), slat, slon, - + selv, ispri, tbchrs, ierrst ) - ii = ii + 1 - END DO - IF ( ierrst .eq. -1 ) THEN - numua = ii - 1 - END IF -C*---------------------------------------------------------------------- -C* Close the sonde land station table file. -C*---------------------------------------------------------------------- - CALL FL_CLOS ( iunltb, iercls ) -C*---------------------------------------------------------------------- -C* Open and read the metar station table. -C*---------------------------------------------------------------------- - CALL FL_TBOP ( 'metar_stnm.tbl', - + 'stns', iunmtb, iertop ) - IF ( iertop .ne. 0 ) THEN - print*,' error opening metar station table' - END IF - - jj = 1 - ierrst = 0 - DO WHILE ( ( jj .le. MAXSTN ) .and. ( ierrst .eq. 0 ) ) - CALL TB_RSTN ( iunmtb, mtstid (jj), stnnam, mtstnm (jj), - + state, mtcoun(jj), slat, slon, - + selv, ispri, tbchrs, ierrst ) - jj = jj + 1 - END DO - IF ( ierrst .eq. -1 ) THEN - nummet = jj - 1 - END IF -C*---------------------------------------------------------------------- -C* Close the metar station table file. -C*---------------------------------------------------------------------- - CALL FL_CLOS ( iunmtb, iercls ) -C*---------------------------------------------------------------------- -C* Open and initialize the output files. -C*---------------------------------------------------------------------- - - OPEN ( UNIT = 51, FILE = FLO ) - WRITE ( 51, FMT = '(A)' ) 'PARM=PRES;HGHT;TMPK;DWPK;DRCT;SPED' - OPEN ( UNIT = 52, FILE = STNO) - -C*---------------------------------------------------------------------- -C* Open the BUFR file. -C*---------------------------------------------------------------------- - - CALL OPENBF ( 40, 'IN', 40 ) - -C*---------------------------------------------------------------------- -C* Read a BUFR subset from the BUFR file. -C*---------------------------------------------------------------------- - - DO WHILE ( IREADNS ( 40, cmgtag, imgdt ) .eq. 0 ) - - IF ( cmgtag .eq. 'NC002001' ) THEN - -C*---------------------------------------------------------------------- -C* Unpack the header information from this subset. -C*---------------------------------------------------------------------- - - CALL UFBINT ( 40, r8hdr, 9, 1, nlev, - + 'WMOB WMOS CLAT CLON SELV YEAR MNTH DAYS HOUR' ) - - IF ( ( ( r8hdr(1,1) .ge. 60 ) .and. - + ( r8hdr(1,1) .le. 91 ) ) .or. - + ( r8hdr(1,1) .eq. 25 ) ) THEN - -C*---------------------------------------------------------------------- -C* Unpack the level information from this subset. -C* and replicate for VISG =2,4,and 32 -C*---------------------------------------------------------------------- - levelit = 0 - needHeader = .true. - nlevtot = 0 - DO WHILE ( levelit .le. 2 ) - IF ( levelit .eq. 0 ) THEN - CALL UFBINT ( 40, r8lvl, 6, 50, nlev, - + 'VSIG=2 PRLC GP10 TMDB TMDP WDIR WSPD' ) - ELSE IF ( levelit .eq. 1 ) THEN - CALL UFBINT ( 40, r8lvl, 6, 50, nlev, - + 'VSIG=4 PRLC GP10 TMDB TMDP WDIR WSPD' ) - ELSE IF ( levelit .eq. 2 ) THEN - CALL UFBINT ( 40, r8lvl, 6, 50, nlev, - + 'VSIG=32 PRLC GP10 TMDB TMDP WDIR WSPD' ) - END IF - IF ( nlev .gt. 0 ) THEN -C*---------------------------------------------------------------------- -C* Find the corresponding 3 or 4 character ID -C* in the sonde land station table. Store into -C* reportid only if non-blank. -C*---------------------------------------------------------------------- - iblkstn = NINT( r8hdr(1,1)*1000 + r8hdr(2,1) ) - nomatch = .true. - CALL DC_BSRH ( iblkstn, ldstnm, numua, - + ii, iersrh ) - IF ( iersrh .ge. 0 ) THEN - reportid = ldstid(ii) - tabcon = ldcoun(ii) - itabnum = ldstnm(ii) - IF ( ldstid (ii) .ne. ' ') THEN - nomatch = .false. - END IF - END IF -C*---------------------------------------------------------------------- -C* Either no match in sonde land table or tdstid -C* was found but ldstid was blank, so check metar -C* table for match and non-blank char id. -C*---------------------------------------------------------------------- - IF ( nomatch ) THEN - mblkstn = INT( iblkstn * 10 ) - CALL DC_BSRH ( mblkstn, mtstnm, nummet, - + jj, iersrh ) - IF ( iersrh .ge. 0 ) THEN - reportid = mtstid(jj) - tabcon = mtcoun(jj) - itabnum = mtstnm(jj) - nomatch = .false. - END IF - END IF -C*---------------------------------------------------------------------- -C* If no header, build it -C*---------------------------------------------------------------------- - IF ( needHeader ) THEN -C*---------------------------------------------------------------------- -C* Write the data to the output file. -C*---------------------------------------------------------------------- - IF ( reportid .ne. ' ' ) THEN -C*---------------------------------------------------------------------- -C* 3- or 4-char ID found. -C*---------------------------------------------------------------------- - WRITE ( 51, - + FMT = '(/,A,A5,3X,A,I2,I3.3,3x,A,3I2.2,A,2I2.2)' ) - + 'STID=', reportid(1:5), - + 'STNM=', INT(r8hdr(1,1)), INT(r8hdr(2,1)), - + 'TIME=', MOD(NINT(r8hdr(6,1)),100), - + NINT(r8hdr(7,1)), NINT(r8hdr(8,1)), - + '/', NINT(r8hdr(9,1)), 0 - WRITE ( 51, - + FMT = '(2(A,F7.2,1X),A,F7.1)' ) - + 'SLAT=', r8hdr(3,1), - + 'SLON=', r8hdr(4,1), - + 'SELV=', r8hdr(5,1) - ELSE -C*---------------------------------------------------------------------- -C* write WMO block/station instead -C*---------------------------------------------------------------------- - WRITE ( 51, - + FMT = '(/,A,I2,I3.3,3X,A,I2,I3.3,3x,A,3I2.2,A,2I2.2)' ) - + 'STID=', INT(r8hdr(1,1)), INT(r8hdr(2,1)), - + 'STNM=', INT(r8hdr(1,1)), INT(r8hdr(2,1)), - + 'TIME=', MOD(NINT(r8hdr(6,1)),100), - + NINT(r8hdr(7,1)), NINT(r8hdr(8,1)), - + '/', NINT(r8hdr(9,1)), 0 - WRITE ( 51, - + FMT = '(2(A,F7.2,1X),A,F7.1)' ) - + 'SLAT=', r8hdr(3,1), - + 'SLON=', r8hdr(4,1), - + 'SELV=', r8hdr(5,1) - END IF - - - WRITE ( 51, FMT = '(/,6(A8,1X))' ) - + 'PRES', 'HGHT', 'TMPK', 'DWPK', 'DRCT', 'SPED' - needHeader = .false. - END IF - DO jj = 1, nlev - -C*---------------------------------------------------------------------- -C* Convert pressure to millibars. -C*---------------------------------------------------------------------- - - IF ( r8lvl(1,jj) .lt. BFMSNG ) THEN - r8lvl(1,jj) = r8lvl (1,jj) / 100.0 - ELSE - r8lvl(1,jj) = GPMSNG - END IF - -C*---------------------------------------------------------------------- -C* Convert geopotential to height in meters. -C*---------------------------------------------------------------------- - - IF ( r8lvl(2,jj) .lt. BFMSNG ) THEN - r8lvl (2,jj) = r8lvl (2,jj) / 9.8 - ELSE - r8lvl (2,jj) = GPMSNG - END IF - - DO ii = 3, 6 - IF ( r8lvl(ii,jj) .ge. BFMSNG ) THEN - r8lvl (ii,jj) = GPMSNG - END IF - END DO - END DO -C*---------------------------------------------------------------------- -C* itterate through levels and add to total array -C* ignore -9999 and 0 pressure levels -C*---------------------------------------------------------------------- - IF ( nlevtot .eq. 0 ) THEN - nlevtot = 1 - END IF - DO jj = 1,nlev - IF ( r8lvl(1,jj) .gt. 99 ) THEN - DO ii = 1,6 - r8tmptot(ii,nlevtot) = r8lvl(ii,jj) - END DO - nlevtot = nlevtot + 1 - END IF - END DO - nlevtot = nlevtot - 1 - END IF - levelit = levelit + 1 - END DO -C*--------------------------------------------------------------------- -C* bubble sort so output starts at lowest level of the -C* atmosphere (usu. 1000mb), only if there are available -C* levels -C*--------------------------------------------------------------------- - IF (nlevtot .gt. 0) THEN - istop = nlevtot - 1 - iswflg = 1 - DO WHILE ( ( iswflg .ne. 0 ) .and. - + ( istop .ge. 1 ) ) - iswflg = 0 -C - DO j = 1, istop - IF ( r8tmptot(1,j) .lt. r8tmptot(1,j+1) ) THEN - iswflg = 1 - DO i = 1,6 - swpbuf = r8tmptot (i,j) - r8tmptot (i,j) = r8tmptot (i,j+1) - r8tmptot (i,j+1) = swpbuf - END DO - END IF - END DO - istop = istop-1 - END DO -C*--------------------------------------------------------------------- -C* check for exact or partial dupes and only write -C* one line for each level to output file. -C*--------------------------------------------------------------------- - DO jj = 1,nlevtot - DO ii = 1,6 - r8out(ii,jj) = r8tmptot(ii,jj) - END DO - END DO - - kk = 1 - DO jj = 1,nlevtot-1 - IF ( r8out(1,kk) .eq. r8tmptot(1,jj+1) ) THEN - r8out(1,kk) = r8tmptot(1,jj) - DO ii = 2,6 - IF ( r8out(ii,kk) .lt. r8tmptot(ii,jj+1)) - + THEN - r8out(ii,kk) = r8tmptot(ii,jj+1) - END IF - END DO - ELSE - kk = kk + 1 - r8out(1,kk) = r8tmptot(1,jj+1) - r8out(2,kk) = r8tmptot(2,jj+1) - r8out(3,kk) = r8tmptot(3,jj+1) - r8out(4,kk) = r8tmptot(4,jj+1) - r8out(5,kk) = r8tmptot(5,jj+1) - r8out(6,kk) = r8tmptot(6,jj+1) - END IF - END DO -C*---------------------------------------------------------------------- -C* write pres, hght, temp, dew point, wind dir, -C* and wind speed to output file. -C*---------------------------------------------------------------------- - DO jj = 1,kk - WRITE ( 51, FMT = '(6(F8.2,1X))' ) - + ( r8out (ii,jj), ii = 1,6 ) - END DO -C*---------------------------------------------------------------------- -C* Write info for the current station to new table. -C* Includes reportid, lat, lon, country, and blk/ -C* stn. -C*---------------------------------------------------------------------- - IF ( reportid .eq. ' ') THEN - WRITE ( reportid(1:6),FMT='(I6)') itabnum - CALL ST_RMBL ( reportid,reportid,len,iret ) - END IF - WRITE ( 52, FMT = '(A6,F7.2,1X,F7.2, - + 1X,A2,1x,I6)' ) - + reportid(1:6),r8hdr(3,1),r8hdr(4,1), - + tabcon,itabnum - END IF - END IF - END IF - END DO - - STOP - END diff --git a/util/sorc/rdbfmsua.fd/rdbfmsua.f_org b/util/sorc/rdbfmsua.fd/rdbfmsua.f_org deleted file mode 100755 index 343c985fcb..0000000000 --- a/util/sorc/rdbfmsua.fd/rdbfmsua.f_org +++ /dev/null @@ -1,397 +0,0 @@ - PROGRAM RDBFUA -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C -C MAIN PROGRAM: RDBFUA -C PRGMMR: J. ATOR ORG: NP12 DATE: 2007-08-13 -C -C ABSTRACT: Upper Air Plotted Data for levels 1000MB; 925MB; 850MB; 700MB; -C 500MB; 400MB; 300MB; 250MB; 200MB; 150MB, and 100MB for the -C following regions: 1)United States; 2)Canada; 3)Alaska; and, -C the 4)Mexico and Caribbean. Note that Alaska includes eastern -C Russia. Also adding South America, Africa, and the Pacific. -C -C PROGRAM HISTORY LOG: -C -C 2007-08-13 J. ATOR -- ORIGINAL AUTHOR -C 2007-08-20 C. Magee -- Added block 25 (eastern Russia) -C 2007-09-20 S. Lilly -- Changing to read blks 60 thru 91. -C 2007-09-20 C. Magee -- Added code to read upper air and metar stn tables -C 2007-09-25 S. Lilly -- Added logic to write statements in order to put STID, -C STNM and TIME on the same line. -C 2007-09-27 C. Magee -- Change output for stntbl.out. Use st_rmbl to remove -C leading blank from reportid if internal write was -C used to convert integer WMO block/stn number to -C char report id. -C 2012-01-24 J. Cahoon -- Modified from original RDBFUA to include -C significant and standard together in output -C 2012-02-15 B. Mabe -- Changed Program name and output file to reflect -C change to output for sig and man data -C 2016-10-18 B. Vuong -- Removed hardwire '/nwprod/dictionaries/' in CALL FL_TBOP -C -C USAGE: -C INPUT FILES: -C UNIT 40 - adpupa dumpfile (contains data from BUFR tank b002/xx001) -C -C sonde.land.tbl -C metar.tbl -C -C OUTPUT FILES: -C UNIT 51 - rdbfmsua.out - contains ASCII upper air data for the desired -C stations. -C UNIT 52 - stnmstbl.out - contains ASCII station table info for use by -C html generator. -C -C SUBPROGRAMS CALLED: -C UNIQUE: -C LIBRARY: BUFRLIB - OPENBF UFBINT -C GEMLIB - FL_TBOP ST_RMBL TB_RSTN -C BRIDGE - DC_BSRH -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE : IBM-SP -C -C$$$ - INCLUDE 'GEMPRM.PRM' - INCLUDE 'BRIDGE.PRM' -C*---------------------------------------------------------------------- -C* Set the name of the output file. -C*---------------------------------------------------------------------- - - CHARACTER*(*) FLO, STNO - - PARAMETER ( FLO = 'rdbfmsua.out' ) - PARAMETER ( STNO = 'sonde.idsms.tbl' ) - - REAL*8 BFMSNG - PARAMETER ( BFMSNG = 10.0E10 ) - - PARAMETER ( GPMSNG = -9999.0 ) - PARAMETER ( MAXSTN = 10000 ) - - REAL*8 r8hdr ( 9, 1 ), r8lvl ( 6, 100 ), r8arr( 1, 1 ) - REAL*8 r8tmp ( 6, 100 ), r8out ( 6, 300 ),swpbuf - REAL*8 r8tmptot ( 6, 300 ) - - CHARACTER*8 cmgtag, reportid - CHARACTER stnnam*32, tbchrs*20, state*2, tabcon*2 - CHARACTER ldcoun( LLSTFL )*2, mtcoun ( MAXSTN )*2 - CHARACTER ldstid ( LLSTFL )*8, mtstid ( MAXSTN )*8 - INTEGER ldstnm ( LLSTFL ), mtstnm ( MAXSTN ), ispri - INTEGER itabnum - REAL slat, slon, selv - LOGICAL nomatch, needHeader - -C*---------------------------------------------------------------------- -C* Open and read the sonde land station table. -C*---------------------------------------------------------------------- - CALL FL_TBOP ( 'sonde.land.tbl', - + 'stns', iunltb, iertop ) - IF ( iertop .ne. 0 ) THEN - print*,' error opening sonde land station table' - END IF - - ii = 1 - ierrst = 0 - DO WHILE ( ( ii .le. LLSTFL ) .and. ( ierrst .eq. 0 ) ) - CALL TB_RSTN ( iunltb, ldstid (ii), stnnam, ldstnm (ii), - + state, ldcoun (ii), slat, slon, - + selv, ispri, tbchrs, ierrst ) - ii = ii + 1 - END DO - IF ( ierrst .eq. -1 ) THEN - numua = ii - 1 - END IF -C*---------------------------------------------------------------------- -C* Close the sonde land station table file. -C*---------------------------------------------------------------------- - CALL FL_CLOS ( iunltb, iercls ) -C*---------------------------------------------------------------------- -C* Open and read the metar station table. -C*---------------------------------------------------------------------- - CALL FL_TBOP ( 'metar_stnm.tbl', - + 'stns', iunmtb, iertop ) - IF ( iertop .ne. 0 ) THEN - print*,' error opening metar station table' - END IF - - jj = 1 - ierrst = 0 - DO WHILE ( ( jj .le. MAXSTN ) .and. ( ierrst .eq. 0 ) ) - CALL TB_RSTN ( iunmtb, mtstid (jj), stnnam, mtstnm (jj), - + state, mtcoun(jj), slat, slon, - + selv, ispri, tbchrs, ierrst ) - jj = jj + 1 - END DO - IF ( ierrst .eq. -1 ) THEN - nummet = jj - 1 - END IF -C*---------------------------------------------------------------------- -C* Close the metar station table file. -C*---------------------------------------------------------------------- - CALL FL_CLOS ( iunmtb, iercls ) -C*---------------------------------------------------------------------- -C* Open and initialize the output files. -C*---------------------------------------------------------------------- - - OPEN ( UNIT = 51, FILE = FLO ) - WRITE ( 51, FMT = '(A)' ) 'PARM=PRES;HGHT;TMPK;DWPK;DRCT;SPED' - OPEN ( UNIT = 52, FILE = STNO) - -C*---------------------------------------------------------------------- -C* Open the BUFR file. -C*---------------------------------------------------------------------- - - CALL OPENBF ( 40, 'IN', 40 ) - -C*---------------------------------------------------------------------- -C* Read a BUFR subset from the BUFR file. -C*---------------------------------------------------------------------- - - DO WHILE ( IREADNS ( 40, cmgtag, imgdt ) .eq. 0 ) - - IF ( cmgtag .eq. 'NC002001' ) THEN - -C*---------------------------------------------------------------------- -C* Unpack the header information from this subset. -C*---------------------------------------------------------------------- - - CALL UFBINT ( 40, r8hdr, 9, 1, nlev, - + 'WMOB WMOS CLAT CLON SELV YEAR MNTH DAYS HOUR' ) - - IF ( ( ( r8hdr(1,1) .ge. 60 ) .and. - + ( r8hdr(1,1) .le. 91 ) ) .or. - + ( r8hdr(1,1) .eq. 25 ) ) THEN - -C*---------------------------------------------------------------------- -C* Unpack the level information from this subset. -C* and replicate for VISG =2,4,and 32 -C*---------------------------------------------------------------------- - levelit = 0 - needHeader = .true. - nlevtot = 0 - DO WHILE ( levelit .le. 2 ) - IF ( levelit .eq. 0 ) THEN - CALL UFBINT ( 40, r8lvl, 6, 50, nlev, - + 'VSIG=2 PRLC GP10 TMDB TMDP WDIR WSPD' ) - ELSE IF ( levelit .eq. 1 ) THEN - CALL UFBINT ( 40, r8lvl, 6, 50, nlev, - + 'VSIG=4 PRLC GP10 TMDB TMDP WDIR WSPD' ) - ELSE IF ( levelit .eq. 2 ) THEN - CALL UFBINT ( 40, r8lvl, 6, 50, nlev, - + 'VSIG=32 PRLC GP10 TMDB TMDP WDIR WSPD' ) - END IF - IF ( nlev .gt. 0 ) THEN -C*---------------------------------------------------------------------- -C* Find the corresponding 3 or 4 character ID -C* in the sonde land station table. Store into -C* reportid only if non-blank. -C*---------------------------------------------------------------------- - iblkstn = NINT( r8hdr(1,1)*1000 + r8hdr(2,1) ) - nomatch = .true. - CALL DC_BSRH ( iblkstn, ldstnm, numua, - + ii, iersrh ) - IF ( iersrh .ge. 0 ) THEN - reportid = ldstid(ii) - tabcon = ldcoun(ii) - itabnum = ldstnm(ii) - IF ( ldstid (ii) .ne. ' ') THEN - nomatch = .false. - END IF - END IF -C*---------------------------------------------------------------------- -C* Either no match in sonde land table or tdstid -C* was found but ldstid was blank, so check metar -C* table for match and non-blank char id. -C*---------------------------------------------------------------------- - IF ( nomatch ) THEN - mblkstn = INT( iblkstn * 10 ) - CALL DC_BSRH ( mblkstn, mtstnm, nummet, - + jj, iersrh ) - IF ( iersrh .ge. 0 ) THEN - reportid = mtstid(jj) - tabcon = mtcoun(jj) - itabnum = mtstnm(jj) - nomatch = .false. - END IF - END IF -C*---------------------------------------------------------------------- -C* If no header, build it -C*---------------------------------------------------------------------- - IF ( needHeader ) THEN -C*---------------------------------------------------------------------- -C* Write the data to the output file. -C*---------------------------------------------------------------------- - IF ( reportid .ne. ' ' ) THEN -C*---------------------------------------------------------------------- -C* 3- or 4-char ID found. -C*---------------------------------------------------------------------- - WRITE ( 51, - + FMT = '(/,A,A5,3X,A,I2,I3.3,3x,A,3I2.2,A,2I2.2)' ) - + 'STID=', reportid(1:5), - + 'STNM=', INT(r8hdr(1,1)), INT(r8hdr(2,1)), - + 'TIME=', MOD(NINT(r8hdr(6,1)),100), - + NINT(r8hdr(7,1)), NINT(r8hdr(8,1)), - + '/', NINT(r8hdr(9,1)), 0 - WRITE ( 51, - + FMT = '(2(A,F7.2,1X),A,F7.1)' ) - + 'SLAT=', r8hdr(3,1), - + 'SLON=', r8hdr(4,1), - + 'SELV=', r8hdr(5,1) - ELSE -C*---------------------------------------------------------------------- -C* write WMO block/station instead -C*---------------------------------------------------------------------- - WRITE ( 51, - + FMT = '(/,A,I2,I3.3,3X,A,I2,I3.3,3x,A,3I2.2,A,2I2.2)' ) - + 'STID=', INT(r8hdr(1,1)), INT(r8hdr(2,1)), - + 'STNM=', INT(r8hdr(1,1)), INT(r8hdr(2,1)), - + 'TIME=', MOD(NINT(r8hdr(6,1)),100), - + NINT(r8hdr(7,1)), NINT(r8hdr(8,1)), - + '/', NINT(r8hdr(9,1)), 0 - WRITE ( 51, - + FMT = '(2(A,F7.2,1X),A,F7.1)' ) - + 'SLAT=', r8hdr(3,1), - + 'SLON=', r8hdr(4,1), - + 'SELV=', r8hdr(5,1) - END IF - - - WRITE ( 51, FMT = '(/,6(A8,1X))' ) - + 'PRES', 'HGHT', 'TMPK', 'DWPK', 'DRCT', 'SPED' - needHeader = .false. - END IF - DO jj = 1, nlev - -C*---------------------------------------------------------------------- -C* Convert pressure to millibars. -C*---------------------------------------------------------------------- - - IF ( r8lvl(1,jj) .lt. BFMSNG ) THEN - r8lvl(1,jj) = r8lvl (1,jj) / 100.0 - ELSE - r8lvl(1,jj) = GPMSNG - END IF - -C*---------------------------------------------------------------------- -C* Convert geopotential to height in meters. -C*---------------------------------------------------------------------- - - IF ( r8lvl(2,jj) .lt. BFMSNG ) THEN - r8lvl (2,jj) = r8lvl (2,jj) / 9.8 - ELSE - r8lvl (2,jj) = GPMSNG - END IF - - DO ii = 3, 6 - IF ( r8lvl(ii,jj) .ge. BFMSNG ) THEN - r8lvl (ii,jj) = GPMSNG - END IF - END DO - END DO -C*---------------------------------------------------------------------- -C* itterate through levels and add to total array -C* ignore -9999 and 0 pressure levels -C*---------------------------------------------------------------------- - IF ( nlevtot .eq. 0 ) THEN - nlevtot = 1 - END IF - DO jj = 1,nlev - IF ( r8lvl(1,jj) .gt. 99 ) THEN - DO ii = 1,6 - r8tmptot(ii,nlevtot) = r8lvl(ii,jj) - END DO - nlevtot = nlevtot + 1 - END IF - END DO - nlevtot = nlevtot - 1 - END IF - levelit = levelit + 1 - END DO -C*--------------------------------------------------------------------- -C* bubble sort so output starts at lowest level of the -C* atmosphere (usu. 1000mb), only if there are available -C* levels -C*--------------------------------------------------------------------- - IF (nlevtot .gt. 0) THEN - istop = nlevtot - 1 - iswflg = 1 - DO WHILE ( ( iswflg .ne. 0 ) .and. - + ( istop .ge. 1 ) ) - iswflg = 0 -C - DO j = 1, istop - IF ( r8tmptot(1,j) .lt. r8tmptot(1,j+1) ) THEN - iswflg = 1 - DO i = 1,6 - swpbuf = r8tmptot (i,j) - r8tmptot (i,j) = r8tmptot (i,j+1) - r8tmptot (i,j+1) = swpbuf - END DO - END IF - END DO - istop = istop-1 - END DO -C*--------------------------------------------------------------------- -C* check for exact or partial dupes and only write -C* one line for each level to output file. -C*--------------------------------------------------------------------- - DO jj = 1,nlevtot - DO ii = 1,6 - r8out(ii,jj) = r8tmptot(ii,jj) - END DO - END DO - - kk = 1 - DO jj = 1,nlevtot-1 - IF ( r8out(1,kk) .eq. r8tmptot(1,jj+1) ) THEN - r8out(1,kk) = r8tmptot(1,jj) - DO ii = 2,6 - IF ( r8out(ii,kk) .lt. r8tmptot(ii,jj+1)) - + THEN - r8out(ii,kk) = r8tmptot(ii,jj+1) - END IF - END DO - ELSE - kk = kk + 1 - r8out(1,kk) = r8tmptot(1,jj+1) - r8out(2,kk) = r8tmptot(2,jj+1) - r8out(3,kk) = r8tmptot(3,jj+1) - r8out(4,kk) = r8tmptot(4,jj+1) - r8out(5,kk) = r8tmptot(5,jj+1) - r8out(6,kk) = r8tmptot(6,jj+1) - END IF - END DO -C*---------------------------------------------------------------------- -C* write pres, hght, temp, dew point, wind dir, -C* and wind speed to output file. -C*---------------------------------------------------------------------- - DO jj = 1,kk - WRITE ( 51, FMT = '(6(F8.2,1X))' ) - + ( r8out (ii,jj), ii = 1,6 ) - END DO -C*---------------------------------------------------------------------- -C* Write info for the current station to new table. -C* Includes reportid, lat, lon, country, and blk/ -C* stn. -C*---------------------------------------------------------------------- - IF ( reportid .eq. ' ') THEN - WRITE ( reportid(1:6),FMT='(I6)') itabnum - CALL ST_RMBL ( reportid,reportid,len,iret ) - END IF - WRITE ( 52, FMT = '(A6,F7.2,1X,F7.2, - + 1X,A2,1x,I6)' ) - + reportid(1:6),r8hdr(3,1),r8hdr(4,1), - + tabcon,itabnum - END IF - END IF - END IF - END DO - - STOP - END diff --git a/util/sorc/terrain.fd/makefile.sh b/util/sorc/terrain.fd/makefile.sh deleted file mode 100755 index d1b5f5bc34..0000000000 --- a/util/sorc/terrain.fd/makefile.sh +++ /dev/null @@ -1,34 +0,0 @@ -#!/bin/ksh -set -x - -machine=${machine:-WCOSS} - -if [ $machine = WCOSS ] ; then - CF=ifort - export MP_CORE_FILE_FORMAT=lite - #FFOPTS="-g -O0 -i4 -r8 -check all -ftrapuv -convert big_endian -fp-stack-check -fstack-protector -heap-arrays -recursiv -traceback -openmp" - FFOPTS="-i4 -O3 -r8 -convert big_endian -fp-model precise -openmp" - LDIR=/nwprod/lib - LIBS="-L/$LDIR -lw3emc_d -lw3nco_d -lbacio_4 -lsp_v2.0.1_d" - LDOPTS="-openmp -mkl" -elif [ $machine = WCOSS_C ] ; then - CF=ftn - FFOPTS="-i4 -O3 -r8 -convert big_endian -fp-model precise -openmp" - LIBS="${W3EMC_LIBd} ${W3NCO_LIBd} ${BACIO_LIB4} ${SP_LIBd}" - LDOPTS="-openmp -mkl" -fi - -f=mtnlm7_slm30g.f -x=../../exec/terrain.x -$CF $FFOPTS $f $LIBS $LDOPTS -o $x - -f=mtnlm7_slm30g_oclsm.f -x=../../exec/terrain_oclsm.x -$CF $FFOPTS $f $LIBS $LDOPTS -o $x - - - - - - - diff --git a/util/sorc/terrain.fd/mtnlm7_slm30g.f b/util/sorc/terrain.fd/mtnlm7_slm30g.f deleted file mode 100644 index 0f9c73c507..0000000000 --- a/util/sorc/terrain.fd/mtnlm7_slm30g.f +++ /dev/null @@ -1,2628 +0,0 @@ -!$$$ MAIN PROGRAM DOCUMENTATION BLOCK -! -! MAIN PROGRAM: TERRAIN TERRAIN MAKER FOR GLOBAL SPECTRAL MODEL -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-04-16 -! -! ABSTRACT: THIS PROGRAM CREATES 7 TERRAIN-RELATED FILES -! COMPUTED FROM THE NAVY 10-MINUTE TERRAIN DATASET. -! THE MODEL PHYSICS GRID PARAMETERS AND SPECTRAL TRUNCATION -! AND FILTER PARAMETERS ARE READ BY THIS PROGRAM AS INPUT. -! THE 7 FILES PRODUCED ARE RESPECTIVELY: -! 1) SEA-LAND MASK ON MODEL PHYSICS GRID -! 2) GRIDDED OROGRAPHY ON MODEL PHYSICS GRID -! 3) MOUNTAIN STD DEV ON MODEL PHYSICS GRID -! 4) SPECTRAL OROGRAPHY IN SPECTRAL DOMAIN -! 5) UNFILTERED GRIDDED OROGRAPHY ON MODEL PHYSICS GRID -! 6) GRIB SEA-LAND MASK ON MODEL PHYSICS GRID -! 7) GRIB GRIDDED OROGRAPHY ON MODEL PHYSICS GRID -! THE OROGRAPHY IS ONLY FILTERED FOR WAVENUMBERS GREATER THAN NF0. -! FOR WAVENUMBERS N BETWEEN NF0 AND NF1, THE OROGRAPHY IS FILTERED -! BY THE FACTOR 1-((N-NF0)/(NF1-NF0))**2. THE FILTERED OROGRAPHY -! WILL NOT HAVE INFORMATION BEYOND WAVENUMBER NF1. -! -! 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 including lat/lon grid -! 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 -! --- 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 -! --- but if no filter but spectral to grid (with gibbs) then NF1=jcap+2, and NF1=jcap+1 -! 11-06-22 S. Moorthi - convert the code to "implicit none" added grib -! output of unfiltered orography -! 13-02-20 S. Moorthi - Added SPTEZJ so that the filter can be applied -! at resolutions t1534 and higher -! Also optimized to code to use less memory -! 13-06-19 S. Moorthi - Made it work on wcoss -! -! -! USAGE: -! -! INPUT FILES: -! UNIT5 - PHYSICS LONGITUDES (IM), PHYSICS LATITUDES (JM), -! SPECTRAL TRUNCATION (NM), RHOMBOIDAL FLAG (NR), -! AND FIRST AND SECOND FILTER PARAMETERS (NF0,NF1). -! RESPECTIVELY READ IN FREE FORMAT. -! UNIT235 - GTOPO 30" AVR for ZAVG elevation -! UNIT10 - 30" UMD land (lake) cover mask see MSKSRC switch -! XUNIT11 - GTOPO AVR -! XUNIT12 - GTOPO STD DEV -! XUNIT13 - GTOPO MAX -! UNIT14 - GTOPO SLM (10' NAVY if switched to get lakes) -! -! OUTPUT FILES: -! UNIT51 - SEA-LAND MASK (IM,JM) -! UNIT52 - GRIDDED OROGRAPHY (IM,JM) -! UNIT53 - MOUNTAIN STD DEV (IM,JM) -! UNIT54 - SPECTRAL OROGRAPHY ((NM+1)*((NR+1)*NM+2)) -! UNIT55 - UNFILTERED GRIDDED OROGRAPHY (IM,JM) -! UNIT56 - GRIB SEA-LAND MASK (IM,JM) -! UNIT57 - GRIB GRIDDED OROGRAPHY (IM,JM) -! UNIT58 - GRIB PRINCIPAL COORD THETA (IM,JM) -! UNIT59 - GRIB PRINCIPAL COORD SIGMA (IM,JM) -! UNIT60 - GRIB PRINCIPAL COORD GAMMA (IM,JM) -! UNIT61 - GRIB MOUNTAIN STD VAR (IM,JM) -! UNIT62 - GRIB MOUNTAIN MAX ELEVATION (IM,JM) -! -! SUBPROGRAMS CALLED: -! UNIQUE: -! TERSUB - MAIN SUBPROGRAM -! read_g - read in 30" elevations -! SPLAT - COMPUTE GAUSSIAN LATITUDES OR EQUALLY-SPACED LATITUDES -! LIBRARY: -! SPTEZ - SPHERICAL TRANSFORM -! SPTEZJ - SPHERICAL TRANSFORM -! GBYTES - UNPACK BITS -! -! REMARKS: FORTRAN 9X EXTENSIONS ARE USED. -! ITOPO determines if the 43200X21600 topo 30" is read in -! from the 30" array record. .DEM tiles are done offline. -! -! ATTRIBUTES: -! CRAY YMP & IBM AIX 3 5 00C88D5D4C00. -!C -!$$$ -!FPP$ NOCONCUR F - implicit none -! - integer MTNRES, IM, JM, NM, NR, NF0, NF1, NW, IMN, JMN, latch - real EFAC,BLAT -! - latch = 1 - READ(5,*) MTNRES,IM,JM,NM,NR,NF0,NF1,EFAC,BLAT - -! --- 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,IM,JM,NM,NR,NF0,NF1,EFAC,BLAT - - NW = (NM+1)*((NR+1)*NM+2) - IMN = 360*120/MTNRES - JMN = 180*120/MTNRES - print *, ' Starting terr mtnlm7_slm10.f IMN,JMN:',IMN,JMN - - call start() - - CALL TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC,BLAT,latch) - -! call summary() - STOP - END - SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC,BLAT,latch) - implicit none -! - integer, parameter :: NMT=14 - logical, parameter :: check_nans=.false. -! logical, parameter :: check_nans=.true. -! - integer IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW - real efac, blat - INTEGER ZSLMX(2700,1350) - - INTEGER, allocatable:: ZAVG(:,:),ZSLM(:,:) - REAL(4), allocatable:: GICE(:,:) - integer*1,allocatable:: UMD(:,:) - - integer latch - integer*1 i3save - integer*2 glob(IMN,JMN), i2save - INTEGER KPDS(200),KGDS(200), zsave1,zsave2,itopo,kount - INTEGER kount2, islmx, jslmx, oldslm, msksrc - REAL COSCLT(JM), WGTCLT(JM), RCLT(JM), XLAT(JM),DIFFX(JM/2) - - REAL SLM(IM,JM), ORO(IM,JM), ORS(NW),ORF(IM,JM) - - REAL, allocatable :: VAR(:,:), VAR4(:,:), OA(:,:,:), OL(:,:,:)& - &, THETA(:,:), GAMMA(:,:), SIGMA(:,:) & - &, ELVMAX(:,:) - real oro_s(im,jm) - integer IST(IM,jm), IEN(IM,jm), JST(JM),JEN(JM) - integer, allocatable :: IWORK(:,:,:) - real glat(jmn) - real, allocatable :: work1(:,:),work2(:,:), work3(:,:) & - &, work4(:,:), work5(:,:), work6(:,:), & - & hprime(:,:,:) - - LOGICAL SPECTR, REVLAT, FILTER - integer numi(jm),ios,iosg,latg2,istat - integer maxc3,maxc4,maxc5,maxc6,maxc7,maxc8 - integer lonsperlat(jm/2),itest,jtest, i, j, k - &, it, jt, i1, jn, js, iw, ie, in, inw, ine, m, n, imt - &, is, ise, isw, lb, iret, imb2p1 - real oaa(4), ola(4), sumdif, avedif, alon, alat, pi - &, degrad, rn, rs, slma, oroa, vara, var4a, wgta, xn, xs - &, fff, www, phi, delxn - complex ffj(im/2+1) - - allocate (ZAVG(IMN,JMN)) - allocate (ZSLM(IMN,JMN)) - allocate (GICE(IMN+1,3601)) - allocate (UMD(IMN,JMN)) - allocate (iwork(im,jm,4)) - allocate (work1(im,jm), work2(im,jm), work3(im,jm) & - &, work4(im,jm), work5(im,jm), work6(im,jm) & - &, hprime(im,jm,nmt)) - allocate (VAR(im,jm), VAR4(im,jm), OA(im,jm,4), OL(im,jm,4) & - &, THETA(im,jm), GAMMA(im,jm), SIGMA(im,jm), ELVMAX(im,jm)) - -! -! SET CONSTANTS AND ZERO FIELDS -! - imb2p1 = im/2 + 1 - pi = 4.0 * atan(1.0) - DEGRAD = 180./PI - SPECTR = NM > 0 ! if NM <=0 then grid is assumed to be lat/lon - FILTER = .TRUE. ! Spectr Filter defaults true and set by NF1 & NF0 - - ! MSKSRC=0 navy 10 lake msk, 1 UMD 30, -1 no lakes -! MSKSRC = 0 - MSKSRC = 1 - - REVLAT = BLAT < 0 ! Reverse latitude/longitude for output - ITOPO = 1 ! topo 30" read, otherwise tiles (opt offline) - - write(0,*)' In TERSUB, ITOPO=',itopo -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! --- old S-Y. files -!- OPEN(UNIT=11,FORM='FORMATTED',ERR=900) ! average -!- OPEN(UNIT=12,FORM='FORMATTED',ERR=900) ! Std Dev -!- OPEN(UNIT=13,FORM='FORMATTED',ERR=900) ! maximum -!- OPEN(UNIT=14,FORM='FORMATTED',ERR=900) ! sea-land-lake-mask -! -! --- READ(11,11) ZAVG -! --- READ(12,11) ZVAR -! --- READ(13,11) ZMAX -! --- 11 FORMAT(20I4) -! -! --- MSKSRC 0 navy 10' lake mask, =1 for 30" UMD lake mask, -! --- MSKSRC internally set if above fails at -1 for no lakes -! --- -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IF (MSKSRC == 0 ) then - READ(14,12,iostat=ios) ZSLMX - 12 FORMAT(80I1) - if (ios /= 0) then - MSKSRC = -1 - print *,' navy10 lake mask rd fail -- ios,MSKSRC:',ios,MSKSRC - endif - ELSE - write(0,*)' Attempt to open/read UMD 30" slmsk MSKSRC=',MSKSRC -! --- not 0 so MSKSRC=1 and attempt to open/read UMD 30" slmsk - -! open(10,file="/global/noscrub/wx23ja/terrain30/landcover30.fixed -! &", recl=43200*21600, access='direct',iostat=istat) - - open(10,file="landcover30.fixed", recl=43200*21600, - & access='direct',iostat=istat) - IF (istat /= 0) then - MSKSRC = -1 - print *,' UMD lake mask open failed -- ios,MSKSRC:',ios,MSKSRC - ELSE -! - read(10, rec=1,iostat=istat) UMD - - ENDIF -! -------------- - IF (istat /= 0) then ! --- When UMD read fails attempt to read navy 10' - print *,' UMD lake mask rd err -- trying navy 10',istat - MSKSRC = 0 - print *,' ***** MSKSRC set to 0 MSKSRC=',MSKSRC - if (MSKSRC == 0 ) then - rewind 14 - READ(14,12,iostat=ios) ZSLMX - if (ios /= 0) then - MSKSRC = -1 - print *,' navy10 lake mask rd fail - ios,MSKSRC:',ios - &, MSKSRC - endif - endif - ELSE - print *,' UMD lake, UMD(500,500)=',UMD(500,500),MSKSRC - ENDIF -! -------------- -! --- good UMD land cover read and MSKSRC = 1 - ENDIF -! -!- READ_G for global 30" terrain -! - print *,' Read 30" topography or call read_g, ITOPO=',ITOPO - - if (itopo /= 0) then - read(235) glob - rewind(235) -! elseif ( ITOPO /= 0 )then -! call read_g(glob,ITOPO) - endif - -! --- transpose even though glob 30" is from S to N and NCEP std is N to S - - do j=1,jmn/2 - jt = jmn - j + 1 - do I=1,imn - 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) -! - -! --- IMN,JMN - write(0,*)' IM, JM, NM, NR, NF0, NF1, EFAC, BLAT' - write(0,*) IM,JM,NM,NR,NF0,NF1,EFAC,BLAT - write(0,*)' imn,jmn,glob(imn,jmn)=',imn,jmn,glob(imn,jmn) - write(0,*)' UBOUND ZAVG=',UBOUND(ZAVG) - write(0,*)' UBOUND glob=',UBOUND(glob) - write(0,*)' UBOUND ZSLM=',UBOUND(ZSLM) - write(0,*)' UBOUND GICE=',UBOUND(GICE) - - kount = 0 - kount2 = 0 -! -! --- 0 is ocean and 1 is land for slm -! - ZSLM = 1 - - SELECTCASE(MSKSRC) - - CASE(1) !---- 30" sea land mask. 0 are water (lake or ocean) - ! ---------------------------------------------- - -! --- transpose even though glob 30" is from S to N and NCEP std is N to S - do j=1,jmn/2 - jt = jmn - j + 1 - do I=1,imn - 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 -! --- UMD slmsk with 30" lakes and set ZAVG from glob - do j=1,jmn - do i=1,imn - if ( UMD(i,j) == 0 ) ZSLM(i,j) = 0 - ZAVG(i,j) = glob(i,j) - enddo - enddo -! - CASE(0) ! --- When navy 10' mask is set MSKSRC=0 - ! ----------------------------------- - -! --- MSKSRC 0 navy 10' lake mask, =1 for 30" UMD lake mask, -1 no lakes - write(0,*)' NAVY 10 (8) slmsk for lakes, MSKSRC=',MSKSRC - - kount = 0 - kount2 = 0 - do j=1,jmn - oldslm = ZSLM(IMN,j) - do i=1,imn - i1 = i + 1 -! --- slmsk with 10' lakes and set ZAVG from 30" glob - ZAVG(i,j) = glob(i,j) - if ( glob(i,j) == -9999 ) then - ZSLM(i,j) = 0 - kount = kount + 1 - endif - islmx = (i-1)/16 + 1 - jslmx = (j-1)/16 + 1 - if ( ZSLMX(islmx,jslmx) == 0 ) then - if ( j > 8 .and. j < JMN-8 ) then - if (i1 > IMN ) i1 = i1 - IMN -! ----- - if(ZSLM(i,j) == 1 .and. oldslm == 1 - & .and. ZSLM(i1,j) == 1) then -! if (i /= 1) oldslm = ZSLM(i,j) - ZSLM(i,j) = 0 - kount2 = kount2 + 1 - endif -! ----- - endif - endif - enddo - enddo -! --- - CASE(-1) - print *,' **** set ZAVG and slm from 30" glob, MSKSRC=',MSKSRC - kount = 0 - kount2 = 0 - do j=1,jmn - do i=1,imn - i1 = i + 1 -! --- UMD slmsk with 10' lakes and set ZAVG from 30" glob - ZAVG(i,j) = glob(i,j) - if ( glob(i,j) == -9999 ) then - ZSLM(i,j) = 0 - kount = kount + 1 - endif - enddo - enddo - END SELECT -! --- -! --- There was an error in the topo 30" data set at pole (-9999). - do i=1,imn - ZSLM(i,1) = 0 - ZSLM(i,JMN) = 1 - enddo -! - write(0,*)' kount,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. -! -! READ REDUCED GRID EXTENTS IF GIVEN -! - read(20,*,iostat=ios) latg2,lonsperlat - if (ios /= 0 .or. 2*latg2 /= jm) then - do j=1,jm - numi(j) = im - enddo - write(0,*) ios,latg2,'COMPUTE TERRAIN ON A FULL GAUSSIAN GRID' - else - do j=1,jm/2 - numi(j) = lonsperlat(j) - enddo - do j=jm/2+1,jm - numi(j) = lonsperlat(jm+1-j) - enddo - write(0,*) ios,latg2,'COMPUTE TERRAIN ON A REDUCED GAUSSIAN' - &' GRID', numi -! print *,ios,latg2,'COMPUTE TERRAIN ON A REDUCED GAUSSIAN GRID' - endif - - write(0,*) ios,latg2,'TERRAIN ON GAUSSIAN GRID',numi - -! -! This code assumes that lat runs from north to south for gg! -! - write(0,*)' SPECTR=',SPECTR,' REVLAT=',REVLAT,'** with GICE-07 **' - - IF (SPECTR) THEN - CALL SPLAT(4,JM,COSCLT,WGTCLT) - DO J=1,JM/2 - RCLT(J) = ACOS(COSCLT(J)) - 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 -! -! print *,' cosclt=',cosclt - print *,' RCLT(1)=',RCLT(1) - - 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)) - - write(0,*)' 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)) -! - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -! - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO - - write(0,*)' Before GICE ZAVG(1,2)=',ZAVG(1,2),ZSLM(1,2) - write(0,*)' Before GICE ZAVG(1,12)=',ZAVG(1,12),ZSLM(1,12) - write(0,*)' Before GICE ZAVG(1,52)=',ZAVG(1,52),ZSLM(1,52) - write(0,*)' Before GICE ZAVG(1,112)=',ZAVG(1,JMN-112),ZSLM(1,112) - -! GICE: Grumbine 30" Antarctica orog IMNx3616 from S to N & wraped E-W. -! NB: Zfields are S to N and W-E! - - iosg = 0 - READ(15,iostat=iosg) GICE - if (iosg /= 0 ) then - write(0,*)' *** Err on reading GICE record, iosg=',iosg - write(0,*)' exec continues but NO GICE correction done ' -! stop - else - write(0,*)' GICE 30" Antarctica RAMP orog 43200x3616 read OK' - write(0,*)' Processing! ' - write(0,*)' Processing! ' - write(0,*)' Processing! ' - do j = 1, 3601 - do i = 1, IMN - zsave1 = ZAVG(i,j) - zsave2 = ZSLM(i,j) - if( GICE(i,j) /= -99. .and. GICE(i,j) /= -1.0 ) then - if ( GICE(i,j) > 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 - ALON = float(i-1) * 360./float(IMN) - ALAT = glat(j) - -! if( ZAVG(i,j) .ne. zsave1 .and. i .lt. 3 ) -! & print *,' antarctica change to ZAVG(i=',i,'j=',j,')=', -! & ZAVG(i,j),ZSLM(i,j),' from originally:',zsave1,zsave2 -! &write(6,151)i,j,ZAVG(i,j),ZSLM(i,j),zsave1,zsave2,ALAT,ALON -! 151 format(1x,'antarctica ZAVG(i=',i3,' j=',i3,')=',i5,i3, -! &' orig:',i5,i3,' Lat=',f8.3,f9.3,'E') - - if( ZAVG(i,j) /= zsave1 ) then - if ( i <= 1201 .and. i > 1200 )then - write(6,152) i,j,ZAVG(i,j),ZSLM(i,j),zsave1,zsave2, - & ALAT,ALON,GICE(i,j) - 152 format(1x,' ZAVG(i=',i4,' j=',i4,')=',i5,i3, - & ' orig:',i5,i4,' Lat=',f7.3,f8.2,'E',' GICE=',f8.1) - endif - endif - enddo - enddo - endif - -! print *, -! & ' After GICE ZAVG(1,2)=',ZAVG(1,2),ZSLM(1,2) -! print *, -! & ' After GICE ZAVG(1,12)=',ZAVG(1,12),ZSLM(1,12) -! print *, -! & ' After GICE ZAVG(1,52)=',ZAVG(1,52),ZSLM(1,52) -! print *, -! & ' After GICE ZAVG(1,112)=',ZAVG(1,112),ZSLM(1,112) -! -! COMPUTE MOUNTAIN DATA : ORO SLM VAR (Std Dev) OC -! - if (numi(1) < im) then - do j=1,jm - do i=numi(j)+1,im - oro(i,j) = 0.0 - slm(i,j) = 0.0 - var(i,j) = 0.0 - var4(i,j) = 0.0 - enddo - enddo - endif -! - CALL MAKEMT(ZAVG,ZSLM,ORO,SLM,VAR,VAR4,GLAT, - & IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - call minmxj(IM,JM,ORO,' ORO') - call minmxj(IM,JM,SLM,' SLM') - call minmxj(IM,JM,VAR,' VAR') - call minmxj(IM,JM,VAR4,' VAR4') - if (check_nans) then ! --- check for nands in above - call nanc(ORO,IM*JM,"MAKEMT_ORO") - call nanc(SLM,IM*JM,"MAKEMT_SLM") - call nanc(VAR,IM*JM,"MAKEMT_VAR") - call nanc(VAR4,IM*JM,"MAKEMT_VAR4") - endif -! -! check antarctic pole -! DO J = 1,JM -! DO I = 1,numi(j) -! 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 - -! write(0,*)' ORO=',oro(:,:) -! -! === Compute mtn principal coord HTENSR: THETA,GAMMA,SIGMA -! - if (numi(1) < im) then - do j=1,jm - do i=numi(j)+1,im - theta(i,j) = 0.0 - gamma(i,j) = 0.0 - sigma(i,j) = 0.0 - enddo - enddo - endif -! - CALL MAKEPC(ZAVG,ZSLM,THETA,GAMMA,SIGMA,GLAT, - 1 IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - call minmxj(IM,JM,THETA,' THETA') - call minmxj(IM,JM,GAMMA,' GAMMA') - call minmxj(IM,JM,SIGMA,' SIGMA') - if (check_nans) then ! --- check for nands in above - call nanc(THETA,IM*JM,"MAKEPC_THETA") - call nanc(GAMMA,IM*JM,"MAKEPC_GAMMA") - call nanc(SIGMA,IM*JM,"MAKEPC_SIGMA") - endif -! -! COMPUTE MOUNTAIN DATA : OA OL -! - if (numi(1) < im) then - do j=1,jm - do i=numi(j)+1,im - oa(i,j,:) = 0.0 - ol(i,j,:) = 0.0 - elvmax(i,j) = 0.0 - enddo - enddo - endif -! - call minmxj(IM,JM,ORO,' ORO') - CALL MAKEOA(ZAVG,VAR,GLAT,OA,OL,IWORK,ELVMAX,ORO, - & WORK1,WORK2,WORK3,WORK4, - & WORK5,WORK6, - & IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - call minmxj(IM,JM,OA,' OA') - call minmxj(IM,JM,OL,' OL') - call minmxj(IM,JM,ELVMAX,' ELVMAX') - call minmxj(IM,JM,ORO,' ORO') - if (check_nans) then ! --- check for nands in above -! --- check for nands in above - call nanc(OA(1,1,1), IM*JM,"MAKEOA_OA(1,1,1)") - call nanc(OA(1,1,2), IM*JM,"MAKEOA_OA(1,1,2)") - call nanc(OA(1,1,3), IM*JM,"MAKEOA_OA(1,1,3)") - call nanc(OA(1,1,4), IM*JM,"MAKEOA_OA(1,1,4)") - call nanc(OL(1,1,1), IM*JM,"MAKEOA_OL(1,1,1)") - call nanc(OL(1,1,2), IM*JM,"MAKEOA_OL(1,1,2)") - call nanc(OL(1,1,3), IM*JM,"MAKEOA_OL(1,1,3)") - call nanc(OL(1,1,4), IM*JM,"MAKEOA_OL(1,1,4)") - call nanc(ELVMAX, IM*JM,"MAKEPC_ELVMAX") - endif - - maxc3 = 0 - maxc4 = 0 - maxc5 = 0 - maxc6 = 0 - maxc7 = 0 - maxc8 = 0 - DO J = 1,JM - DO I = 1,numi(j) - if (ELVMAX(I,J) > 3000.) maxc3 = maxc3 +1 - if (ELVMAX(I,J) > 4000.) maxc4 = maxc4 +1 - if (ELVMAX(I,J) > 5000.) maxc5 = maxc5 +1 - if (ELVMAX(I,J) > 6000.) maxc6 = maxc6 +1 - if (ELVMAX(I,J) > 7000.) maxc7 = maxc7 +1 - if (ELVMAX(I,J) > 8000.) maxc8 = maxc8 +1 - ENDDO - ENDDO - write(0,*)' MAXC3:',maxc3,maxc4,maxc5,maxc6,maxc7,maxc8 -! -! itest = 151 -! jtest = 56 -! - write(0,*)' ===> Replacing ELVMAX with ELVMAX-ORO <=== ' - write(0,*)' ===> if ELVMAX<=ORO replace with proxy <=== ' - write(0,*)' ===> the sum of mean orog (ORO) and std dev <=== ' - DO J = 1,JM - DO I = 1,numi(j) - if (ELVMAX(I,J) < ORO(I,J) ) then -!--- subtracting off ORO leaves std dev (this should never happen) - ELVMAX(I,J) = MAX( 3. * VAR(I,J),0.) - else - ELVMAX(I,J) = MAX( ELVMAX(I,J) - ORO(I,J),0.) - endif - ENDDO - ENDDO - maxc3 = 0 - maxc4 = 0 - maxc5 = 0 - maxc6 = 0 - maxc7 = 0 - maxc8 = 0 - DO J = 1,JM - DO I = 1,numi(j) - if (ELVMAX(I,J) > 3000.) maxc3 = maxc3 +1 - if (ELVMAX(I,J) > 4000.) maxc4 = maxc4 +1 - if (ELVMAX(I,J) > 5000.) maxc5 = maxc5 +1 - if (ELVMAX(I,J) > 6000.) maxc6 = maxc6 +1 - if (ELVMAX(I,J) > 7000.) maxc7 = maxc7 +1 - if (ELVMAX(I,J) > 8000.) maxc8 = maxc8 +1 - ENDDO - ENDDO - write(0,*)' after MAXC 3-6 km:',maxc3,maxc4,maxc5,maxc6 -! - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') -! if (JM .gt. 0) stop - - deallocate (ZAVG) - deallocate (ZSLM) - deallocate (UMD) - deallocate (GICE) - deallocate (work3,work4,work5,work6,iwork) -! -! ZERO OVER OCEAN -! - write(0,*)' Testing at point (itest,jtest)=',itest,jtest -! print *,' SLM(itest,jtest)=',slm(itest,jtest) - write(0,*)' ORO(itest,jtest)=',oro(itest,jtest) - - DO J = 1,JM - DO I = 1,numi(j) - IF(SLM(I,J) == 0.0) THEN -! VAR(I,J) = 0. - VAR4(I,J) = 0. - OA(I,J,1) = 0. - OA(I,J,2) = 0. - OA(I,J,3) = 0. - OA(I,J,4) = 0. - OL(I,J,1) = 0. - OL(I,J,2) = 0. - OL(I,J,3) = 0. - OL(I,J,4) = 0. -! THETA(I,J) = 0. -! GAMMA(I,J) = 0. -! SIGMA(I,J) = 0. -! ELVMAX(I,J) = 0. - ENDIF - ENDDO - ENDDO -! -! REMOVE ISOLATED POINTS -! - DO J=2,JM-1 - JN = J - 1 - JS = J + 1 - RN = REAL(NUMI(JN)) / REAL(NUMI(J)) - RS = REAL(NUMI(JS)) / REAL(NUMI(J)) - DO I=1,NUMI(J) - 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: August 27, 2012 -! OLA(K) = OA(IW,J,K) + OA(IE,J,K) - OLA(K) = OL(IW,J,K) + OL(IE,J,K) - ENDDO - WGTA = 2 - XN = RN*(I-1) + 1 - IF (ABS(XN-NINT(XN)) < 1.E-2) THEN - IN = MOD(NINT(XN)-1,NUMI(JN)) + 1 - INW = MOD(IN+NUMI(JN)-2,NUMI(JN)) + 1 - INE = MOD(IN,NUMI(JN)) + 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,NUMI(JN)) + 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 = RS*(I-1)+1 - IF(ABS(XS-NINT(XS)) < 1.E-2) THEN - IS = MOD(NINT(XS)-1,NUMI(JS)) + 1 - ISW = MOD(IS+NUMI(JS)-2,NUMI(JS)) + 1 - ISE = MOD(IS,NUMI(JS)) + 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,NUMI(JS)) + 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) == 0..AND.SLMA == 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) == 1. .AND. SLMA == 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 -!--- print for testing after isolated points removed - write(0,*)' after isolated points removed' - - call minmxj(IM,JM,ORO,' ORO') - -! print *,' JM=',JM,' numi=',numi - write(0,*)' ORO(itest,jtest)=',oro(itest,jtest) - write(0,*)' VAR(itest,jtest)=',var(itest,jtest) - write(0,*)' VAR4(itest,jtest)=',var4(itest,jtest) - write(0,*)' OA(itest,jtest,1)=',oa(itest,jtest,1) - write(0,*)' OA(itest,jtest,2)=',oa(itest,jtest,2) - write(0,*)' OA(itest,jtest,3)=',oa(itest,jtest,3) - write(0,*)' OA(itest,jtest,4)=',oa(itest,jtest,4) - write(0,*)' OL(itest,jtest,1)=',ol(itest,jtest,1) - write(0,*)' OL(itest,jtest,2)=',ol(itest,jtest,2) - write(0,*)' OL(itest,jtest,3)=',ol(itest,jtest,3) - write(0,*)' OL(itest,jtest,4)=',ol(itest,jtest,4) - write(0,*)' Testing at point (itest,jtest)=',itest,jtest - write(0,*)' THETA(itest,jtest)=',theta(itest,jtest) - write(0,*)' GAMMA(itest,jtest)=',GAMMA(itest,jtest) - write(0,*)' SIGMA(itest,jtest)=',SIGMA(itest,jtest) - write(0,*)' ELVMAX(itest,jtest)=',ELVMAX(itest,jtest) - write(0,*)' EFAC=',EFAC -! - DO J=1,JM - DO I=1,numi(j) - ORO(I,J) = ORO(I,J) + EFAC*VAR(I,J) - HPRIME(I,J,1) = VAR(I,J) - HPRIME(I,J,2) = VAR4(I,J) - HPRIME(I,J,3) = oa(I,J,1) - HPRIME(I,J,4) = oa(I,J,2) - HPRIME(I,J,5) = oa(I,J,3) - HPRIME(I,J,6) = oa(I,J,4) - HPRIME(I,J,7) = ol(I,J,1) - HPRIME(I,J,8) = ol(I,J,2) - HPRIME(I,J,9) = ol(I,J,3) - HPRIME(I,J,10) = ol(I,J,4) - HPRIME(I,J,11) = THETA(I,J) - HPRIME(I,J,12) = GAMMA(I,J) - HPRIME(I,J,13) = SIGMA(I,J) - HPRIME(I,J,14) = ELVMAX(I,J) - ENDDO - ENDDO -! - deallocate (VAR, VAR4, OA, OL) -! - 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 NF0=jcap+1 -! - oro_s = oro -! - IF ( NF1 - NF0 == 0 ) FILTER = .FALSE. - write(0,*)' NF1, NF0, FILTER=',NF1,NF0,FILTER - - IF (FILTER) THEN ! SPECTRALLY TRUNCATE AND FILTER OROGRAPHY - do j=1,jm - if(numi(j) < im) then - ffj = cmplx(0.,0.) - call spfft1(numi(j),imb2p1,numi(j),1,ffj,oro(1,j),-1) - call spfft1(im, imb2p1,im, 1,ffj,oro(1,j),+1) - endif - enddo - -! write(0,*)' calling sptezj -1 nm=',nm,' nw=',nw,' im=',im -! &,' jm=',jm,' latch=',latch - - CALL SPTEZ(NR,NM,4,IM,JM,ORS,ORO,-1) - -! CALL SPTEZJ(NM,NW,1,4,IM,JM,1,ORS,ORO,latch,-1) -! - FFF = 1./(NF1-NF0)**2 - I = 0 - DO M=0,NM - DO N=M,NM+NR*M - IF(N > 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 -! -! write(0,*),' calling sptezj +1 nm=',nm,' nw=',nw,' im=',im -! &,' jm=',jm,' latch=',latch - - CALL SPTEZ(NR,NM,4,IM,JM,ORS,ORF,+1) -! CALL SPTEZJ(NM,NW,1,4,IM,JM,1,ORS,ORF,latch,+1) - - do j=1,jm - if(numi(j) < im) then - call spfft1(im, imb2p1,im, 1,ffj,orf(1,j),-1) - call spfft1(numi(j),imb2p1,numi(j),1,ffj,orf(1,j),+1) - endif - enddo - - ELSE - IF (REVLAT) THEN - CALL REVERS(IM, JM, numi, SLM, WORK1) - CALL REVERS(IM, JM, numi, ORO, WORK1) - DO IMT=1,NMT - CALL REVERS(IM, JM, numi, HPRIME(1,1,IMT), WORK1) - ENDDO - ENDIF - ORS = 0. - ORF = ORO - ENDIF - oro = oro_s - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') - - write(0,*)' ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) - write(0,*)' after spectral filter is applied' - - call minmxj(IM,JM,ORO,' ORO') - call minmxj(IM,JM,ORF,' ORF') -! -! USE NEAREST NEIGHBOR INTERPOLATION TO FILL FULL GRIDS -! - call rg2gg(im,jm,numi,slm) - call rg2gg(im,jm,numi,oro) - call rg2gg(im,jm,numi,oro_s) - call rg2gg(im,jm,numi,orf) -! --- not apply to new prin coord and ELVMAX (*j*) - do imt=1,nmt - call rg2gg(im,jm,numi,hprime(1,1,imt)) - enddo -! -! write(0,*),' 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') - write(0,*)' ORO,ORF(itest,jtest),itest,jtest:', - & ORO(itest,jtest),ORF(itest,jtest),itest,jtest - write(0,*)' ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) -! check antarctic pole - DO J = 1,JM - DO I = 1,numi(j) - if ( i <= min(numi(j),21) .and. i > 0 )then - if (j == 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 - -! OUTPUT BINARY FIELDS - - WRITE(51) REAL(SLM,4) - WRITE(52) REAL(ORF,4) - WRITE(53) REAL(HPRIME,4) - WRITE(54) REAL(ORS,4) - WRITE(55) REAL(ORO,4) - WRITE(66) REAL(THETA,4) - WRITE(67) REAL(GAMMA,4) - WRITE(68) REAL(SIGMA,4) -! - call minmxj(IM,JM,ORO,' ORO') - - write(0,*)' IM=',IM,' JM=',JM,' SPECTR=',SPECTR - -!--- Test binary file output: - WRITE(71) REAL(SLM,4) - DO IMT=1,NMT - WRITE(71) REAL(HPRIME(:,:,IMT),4) - print *,' HPRIME(',itest,jtest,imt,')=',HPRIME(itest,jtest,imt) - ENDDO - WRITE(71) REAL(ORO,4) - IF (SPECTR) THEN - WRITE(71) REAL(ORF,4) ! smoothed spectral orography! - ENDIF - -! OUTPUT GRIB FIELDS - - KPDS = 0 - KPDS(1) = 7 - KPDS(2) = 78 - KPDS(3) = 255 - KPDS(4) = 128 - KPDS(5) = 81 - KPDS(6) = 1 - kpds(8) = 2004 - KPDS(9) = 1 - KPDS(10) = 1 - KPDS(13) = 4 - KPDS(15) = 1 - KPDS(16) = 51 - KPDS(17) = 1 - KPDS(18) = 1 - KPDS(19) = 1 - KPDS(21) = 20 - KPDS(22) = 1 - - KGDS = 0 - KGDS(1) = 4 - KGDS(2) = IM - KGDS(3) = JM - KGDS(4) = 90000-180000/PI*RCLT(1) - KGDS(6) = 128 - KGDS(7) = 180000/PI*RCLT(1)-90000 - KGDS(8) = -NINT(360000./IM) - KGDS(9) = NINT(360000./IM) - KGDS(10) = JM/2 - KGDS(20) = 255 - - CALL BAOPENwt(56,'fort.56',IRET) - CALL PUTGB(56,IM*JM,KPDS,KGDS,LB,SLM,IRET) - - write(0,*)' SLM: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET - - KPDS(5) = 8 - IF (SPECTR) THEN - CALL BAOPENwt(57,'fort.57',IRET) - CALL PUTGB(57,IM*JM,KPDS,KGDS,LB,ORF,IRET) - write(0,*)' ORF (ORO): putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5) - & ,IRET - CALL BAOPENwt(72,'fort.72',IRET) - CALL PUTGB(72,IM*JM,KPDS,KGDS,LB,ORO_S,IRET) - write(0,*)' ORO_UF (ORO): putgb-KPDS(22,5),iret:',KPDS(22), - & KPDS(5) - & ,IRET -! else ! grib output for lat/lon grid KPD's need to be defined -! CALL BAOPENwt(57,'fort.57',IRET) -! CALL PUTGB(57,IM*JM,KPDS,KGDS,LB,ORO,IRET) -! print *,' ORO (ORO): putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5) -! & ,IRET - ENDIF -! -! === write out theta (angle of land to East) using #101 (wave dir) -! === [radians] and since < 1 scale adjust kpds(22) -! - KPDS(5) = 101 - CALL BAOPENwt(58,'fort.58',IRET) - CALL PUTGB(58,IM*JM,KPDS,KGDS,LB,THETA,IRET) - - write(0,*)' THETA: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET -! -! === write out (land aspect ratio or anisotropy) using #102 -! === (as in wind wave hgt) -! - KPDS(22) = 2 - KPDS(5) = 102 - CALL BAOPENwt(60,'fort.60',IRET) - CALL PUTGB(60,IM*JM,KPDS,KGDS,LB,SIGMA,IRET) - write(0,*)' SIGMA: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET -! -! === write out (slope parameter sigma) using #9 -! === (as in std hgt) -! - KPDS(22) = 1 - KPDS(5) = 103 - CALL BAOPENwt(59,'fort.59',IRET) - CALL PUTGB(59,IM*JM,KPDS,KGDS,LB,GAMMA,IRET) - - write(0,*)' GAMMA: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET -! - KPDS(22) = 1 - KPDS(5) = 9 - CALL BAOPENwt(61,'fort.61',IRET) - CALL PUTGB(61,IM*JM,KPDS,KGDS,LB,HPRIME,IRET) - - write(0,*)' HPRIME: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET -! -! - KPDS(22) = 1 - KPDS(5) = 8 - CALL BAOPENwt(62,'fort.62',IRET) - CALL PUTGB(62,IM*JM,KPDS,KGDS,LB,ELVMAX,IRET) - - write(0,*)' ELVMAX: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET -! - RETURN - END - SUBROUTINE MAKEMT(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, - & GLAT,IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) -! - implicit none -! - integer im, jm, imn, jmn - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - &, IST(IM,jm),IEN(IM,jm),JST(JM),JEN(JM),numi(jm) - real ORO(IM,JM),SLM(IM,JM),VAR(IM,JM),VAR4(IM,JM) - &, GLAT(JMN),XLAT(JM) -! - LOGICAL FLAG, DEBUG -!==== DATA DEBUG/.TRUE./ - DATA DEBUG/.FALSE./ -! - integer i, j, im1, jm1, ii1, i1, j1 - real delx, delxn, faclon, xnsum, xland, xwatr, xl1, xs1 - &, xw1, xw2, xw4, height, xxlat -! - print *,' _____ SUBROUTINE MAKEMT ' -!---- GLOBAL XLAT AND XLON ( DEGREE ) -! - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -! - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO -! -!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -! -! (*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 -! - IF (IST(I,j) <= 0) IST(I,j) = IST(I,j) + IMN - IF (IEN(I,j) < 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))*0.5 - IF(FLAG .AND. GLAT(J1) > XXLAT) THEN - JST(J) = J1 - JEN(J+1) = J1 - 1 - FLAG = .FALSE. - ENDIF - ENDDO -!X 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) -! -!...FIRST, AVERAGED HEIGHT -! - 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 <= 0) I1 = I1 + IMN - IF(I1 > 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)) - IF(HEIGHT < -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 * HEIGHT - -! check antarctic pole -! if ( i .le. 10 .and. i .ge. 1 )then -! if (j .ge. JM-1 )then -! write(6,153)i,j,ORO(i,j),HEIGHT,SLM(i,j) -!=== 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=',i3,')=',2E14.5,3f5.1) -! endif -! endif - - ENDDO - ENDDO - IF(XNSUM > 1.) THEN - SLM(I,J) = FLOAT(NINT(XLAND/XNSUM)) - IF(SLM(I,J) /= 0.) THEN - if (xland > 0.0) ORO(I,J)= XL1 / XLAND - ELSE - if (xwatr > 0.0) 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 <= 0.) I1 = I1 + IMN - IF(I1 > IMN) I1 = I1 - IMN - DO J1=JST(J),JEN(J) - HEIGHT = FLOAT(ZAVG(I1,J1)) - IF(HEIGHT < -990.) HEIGHT = 0.0 - XW4 = XW4 + (HEIGHT-ORO(I,J)) ** 4 - ENDDO - ENDDO - IF(VAR(I,J) > 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" -! - - RETURN - END - SUBROUTINE MAKEPC(ZAVG,ZSLM,THETA,GAMMA,SIGMA, - 1 GLAT,IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) -! -!=== PC: principal coordinates of each Z avg orog box for L&M -! - implicit none -! - real, parameter :: REARTH=6.3712E+6 - integer IM,JM,IMN,JMN - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - &, IST(IM,jm),IEN(IM,jm),JST(JM),JEN(JM),numi(jm) - real GLAT(JMN),XLAT(JM),DELTAX(JMN) - &, ORO(IM,JM),SLM(IM,JM),HL(IM,JM),HK(IM,JM) - real HX2(IM,JM),HY2(IM,JM),HXY(IM,JM),HLPRIM(IM,JM) - &, THETA(IM,JM),GAMMA(IM,JM),SIGMA2(IM,JM),SIGMA(IM,JM) - LOGICAL FLAG, DEBUG -!=== DATA DEBUG/.TRUE./ - DATA DEBUG/.FALSE./ -! - integer i, j, jm1, ii1, i0, i1, j1, ip1, ijax - real pi, certh, delxn, deltay, delx, faclon, xxlat - &, xnsum, xland, xwatr, xl1, xs1, xfp, yfp, xfpyfp, xfp2 - &, yfp2, height, hi0, hi1, hip1, hijax, hi1j1, hj0, hjp1 -! - PI = 4.0 * ATAN(1.0) - CERTH = PI * REARTH -!---- GLOBAL XLAT AND XLON ( DEGREE ) -! - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION - DELTAY = CERTH / FLOAT(JMN) - print *, 'MAKEPC: DELTAY=',DELTAY -! - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - DELTAX(J) = DELTAY * COSD(GLAT(J)) - ENDDO -! -!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -! - 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 - IST(I,j) = IST(I,j) + 1 - IEN(I,j) = FACLON * FLOAT(I) - FACLON * 0.5 - -! if (debug) then -! if ( I < 10 .and. J < 10 ) -! 1 PRINT*, ' I j IST IEN ',I,j,IST(I,j),IEN(I,j) -! endif -! IST(I,j) = FACLON * FLOAT(I-1) + 1.0001 -! IEN(I,j) = FACLON * FLOAT(I) + 0.0001 - - IF (IST(I,j) <= 0) IST(I,j) = IST(I,j) + IMN - IF (IEN(I,j) < IST(I,j)) IEN(I,j) = IEN(I,j) + IMN - if (debug) then - if ( I < 10 .and. J < 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))*0.5 - IF(FLAG .AND. GLAT(J1) > 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 -! -!... DERIVITIVE TENSOR OF HEIGHT -! - 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. -! - 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 -! -!=== set the rest of the indexs for ave: 2pt staggered derivitive -! - i0 = i1 - 1 - if (i1 - 1 <= 0 ) i0 = i0 + imn - if (i1 - 1 > imn) i0 = i0 - imn - - ip1 = i1 + 1 - if (i1 + 1 <= 0 ) ip1 = ip1 + imn - if (i1 + 1 > imn) ip1 = ip1 - imn -! - DO J1=JST(J),JEN(J) - if (debug) then - if ( I1 == IST(I,J) .and. J1 == 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. -! - HEIGHT = FLOAT(ZAVG(I1,J1)) - hi0 = float(zavg(i0,j1)) - hip1 = float(zavg(ip1,j1)) -! - IF(HEIGHT < -990.) HEIGHT = 0.0 - if(hi0 < -990.) hi0 = 0.0 - if(hip1 < -990.) hip1 = 0.0 -!........ xfp = xfp + 0.5 * ( hip1 - hi0 ) / DELTAX(J1) - xfp = 0.5 * ( hip1 - hi0 ) / DELTAX(J1) - xfp2 = xfp2 + 0.25 * ( ( hip1 - hi0 )/DELTAX(J1) )** 2 -! -! --- not at boundaries - if ( J1 /= JST(1) .and. J1 /= JEN(JM) ) then - hj0 = float(zavg(i1,j1-1)) - hjp1 = float(zavg(i1,j1+1)) - if(hj0 < -990.) hj0 = 0.0 - if(hjp1 < -990.) hjp1 = 0.0 -!....... yfp = yfp + 0.5 * ( hjp1 - hj0 ) / DELTAY - yfp = 0.5 * ( hjp1 - hj0 ) / DELTAY - yfp2 = yfp2 + 0.25 * ( ( hjp1 - hj0 )/DELTAY )**2 - -!.............. elseif ( J1 == JST(J) .or. J1 == JEN(JM) ) then -! === the NH pole: NB J1 goes from High at NP to Low toward SP -! - elseif ( J1 == JST(1) ) then - ijax = i1 + imn/2 - if (ijax <= 0 ) ijax = ijax + imn - if (ijax > imn) ijax = ijax - imn -!..... 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 < -990.) hijax = 0.0 - if(hi1j1 < -990.) hi1j1 = 0.0 -!....... 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 -! -! === the SH pole: NB J1 goes from High at NP to Low toward SP -! - elseif ( J1 == JEN(JM) ) then - ijax = i1 + imn/2 - if (ijax <= 0 ) ijax = ijax + imn - if (ijax > imn) ijax = ijax - imn - hijax = float(zavg(ijax,j1)) - hi1j1 = float(zavg(i1,j1)) - if(hijax < -990.) hijax = 0.0 - if(hi1j1 < -990.) hi1j1 = 0.0 - if ( i1 < 5 ) - & print *,' S.Pole i1,j1 :',i1,j1,hijax,hi1j1 -!..... 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 -! -! === The above does an average across the pole for the bndry in j. -!23456789012345678901234567890123456789012345678901234567890123456789012...... -! - xfpyfp = xfpyfp + xfp * yfp - XL1 = XL1 + HEIGHT * FLOAT(ZSLM(I1,J1)) - XS1 = XS1 + HEIGHT * FLOAT(1-ZSLM(I1,J1)) -! -! === average the HX2, HY2 and HXY -! === This will be done over all land -! - ENDDO - ENDDO -! -! === HTENSR -! - IF(XNSUM > 1.) THEN - SLM(I,J) = FLOAT(NINT(XLAND/XNSUM)) - IF(SLM(I,J) /= 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 -!=== 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 -! -! === 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) /= 0. .AND. SLM(I,J) /= 0. ) THEN - THETA(I,J) = 0.5 * ATAN2D(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) >= 0.) then - SIGMA(I,J) = SQRT(SIGMA2(I,J) ) - if (sigma2(i,j) /= 0. .and. HK(I,J) >= 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" -! - RETURN - END - - 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) -! - implicit none -! - integer IM,JM,IMN,JMN - &, IST(IM,jm),IEN(IM,jm),JST(JM),JEN(JM),numi(jm) - &, ioa4(im,jm,4), ZAVG(IMN,JMN) - real GLAT(JMN),XLAT(JM) - &, ORO(IM,JM),ORO1(IM,JM),ELVMAX(IM,JM),ZMAX(IM,JM) - &, OA4(IM,JM,4) - real XNSUM(IM,JM),XNSUM1(IM,JM),XNSUM2(IM,JM) - &, XNSUM3(IM,JM),XNSUM4(IM,JM) - real VAR(IM,JM),OL(IM,JM,4) - LOGICAL FLAG -! - integer i, j, im1, jm1, i1, ii1, j1, kwd, ii, inci, isttt, jsttt - &, ns0, ns1, ns2, ns3, ns4, ns5, ns6, ieddd, jeddd, incj - real delx, delxn, faclon, xxlat, height, xnpu, xnpd, hc, t - &, tem -! -!---- GLOBAL XLAT AND XLON ( DEGREE ) -! -! --- IM1 = IM - 1 removed (not used in this sub) - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -! - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO - - write(0,*)'MAKEOA: IM=',IM,' JM=',JM,' IMN=',IMN,' JMN=',JMN -! -!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -! - DO j=1,jm - DO I=1,numi(j) - DELX = 360./numi(j) ! GAUSSIAN GRID RESOLUTION - FACLON = DELX / DELXN -! --- 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) <= 0) IST(I,j) = IST(I,j) + IMN - IF (IEN(I,j) < IST(I,j)) IEN(I,j) = IEN(I,j) + IMN -!x PRINT*, ' I j IST IEN ',I,j,IST(I,j),IEN(I,j) - if ( I .lt. 3 .and. J .lt. 3 ) - 1 PRINT*,' MAKEOA: I j IST IEN ',I,j,IST(I,j),IEN(I,j) - if ( I .lt. 3 .and. J .ge. JM-1 ) - 1 PRINT*,' MAKEOA: I j IST IEN ',I,j,IST(I,j),IEN(I,j) - ENDDO - ENDDO - write(0,*)'MAKEOA: DELXN,DELX,FACLON',DELXN,DELX,FACLON - write(0,*)' ***** 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) > XXLAT) THEN - JST(J) = J1 -! --- JEN(J+1) = J1 - 1 - FLAG = .FALSE. - if ( J == 1 ) PRINT*,' MAKEOA: XX j JST JEN ',j,JST(j),JEN(j) - ENDIF - ENDDO - if ( J < 3 ) PRINT*,' MAKEOA: j JST JEN ',j,JST(j),JEN(j) - if ( J >= JM-2 ) PRINT*,' MAKEOA: j JST JEN ',j,JST(j),JEN(j) -! FLAG=.TRUE. -! DO J1=JST(J),JMN -! IF(FLAG.AND.GLAT(J1).GT.XLAT(J)) THEN -! JEN(J) = 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) - write(0,*)' ***** JST(1) JEN(1) ',JST(1),JEN(1) - write(0,*)' ***** JST(JM) JEN(JM) ',JST(JM),JEN(JM) -! - 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 -! write(0,*)' J=',j,' in xnsum loop' - 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 <= 0.) I1 = I1 + IMN - IF (I1 > IMN) I1 = I1 - IMN - DO J1=JST(J),JEN(J) - HEIGHT = FLOAT(ZAVG(I1,J1)) - IF(HEIGHT < -990.) HEIGHT = 0.0 - IF ( HEIGHT > ORO(I,J) ) then - if ( HEIGHT > ZMAX(I,J) ) ZMAX(I,J) = HEIGHT - XNSUM(I,J) = XNSUM(I,J) + 1 - ENDIF - ENDDO - ENDDO - if ( I < 5 .and. J >= JM-5 ) then - write(0,*) ' 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 -! -!.... make ELVMAX ORO from MAKEMT sub -! -! --- 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 -!........ -! The MAX elev peak (no averaging) -!........ -! 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 -! - 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) -! - 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 -! - 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 -!x print*,' i j hc var ',i,j,hc,var(i,j) -!x print*,'xnsum12 ',xnsum1(i,j),xnsum2(i,j) -!x print*,'xnsum34 ',xnsum3(i,j),xnsum4(i,j) - ENDDO - ENDDO - write(0,*)' IN MAKEOA After XNSUM4' -! -!---- 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) -! -! - DO KWD = 1, 4 - DO J=1,JM - DO I=1,numi(j) - OA4(I,J,KWD) = 0.0 - ENDDO - 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(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.) - tem = XNSUM4(I,J+1) + XNSUM4(II,J+1) - if (tem > 0.0) then - OL(II,J+1,1) = (XNSUM3(I,J+1) + XNSUM3(II,J+1)) / tem - endif - if ( I .lt. 20 .and. J .ge. JM-19 ) then - write(0,*)' 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 - write(0,*)' MAKEOA: after OL loop1' - 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 - write(0,*)' MAKEOA: after OL loop2' - 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 - write(0,*)' MAKEOA: after OL loop3' - 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 - write(0,*)' MAKEOA: after OL loop4' -! - 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 -! - write(0,*)' IN MAKEOA Bef OA4' - 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 -! - 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 -! - WRITE(6,*) "! MAKEOA EXIT" -! - RETURN - END - SUBROUTINE REVERS(IM, JM, numi, F, WRK) -! - implicit none -! - integer im, jm - REAL F(IM,JM), WRK(IM,JM) - integer numi(jm), i, j, ir, jr, imb2 - real tem -! -! reverse east-west and north-south -!...... fix this routine up to take numi (*j*) -!..... at least have 5 variables ....and keep REVLAT .FALSE. - - imb2 = im / 2 - do j=1,jm - do i=1,im - WRK(i,j) = F(i,j) - enddo - enddo - do j=1,jm - jr = jm - j + 1 - do i=1,im - ir = i + imb2 - if (ir > im) ir = ir - im - f(ir,jr) = WRK(i,j) - enddo - enddo -! - tem = 0.0 - do i=1,im - tem= tem + F(I,1) - enddo - tem = tem / im - do i=1,im - F(I,1) = tem - enddo -! - RETURN - END - - subroutine rg2gg(im,jm,numi,a) -! - implicit none -! - integer,intent(in):: im,jm,numi(jm) - real,intent(inout):: a(im,jm) - integer j,ir,ig - real r,t(im) - do j=1,jm - r = real(numi(j))/real(im) - do ig=1,im - ir = mod(nint((ig-1)*r),numi(j)) + 1 - t(ig) = a(ir,j) - enddo - do ig=1,im - a(ig,j) = t(ig) - enddo - enddo - end subroutine - subroutine gg2rg(im,jm,numi,a) -! - implicit none -! - integer,intent(in):: im,jm,numi(jm) - real,intent(inout):: a(im,jm) - integer j,ir,ig - real r,t(im) - do j=1,jm - r = real(numi(j))/real(im) - do ir=1,numi(j) - ig = nint((ir-1)/r) + 1 - t(ir) = a(ig,j) - enddo - do ir=1,numi(j) - a(ir,j) = t(ir) - enddo - enddo - end subroutine - SUBROUTINE minmxj(IM,JM,A,title) - -! this routine is using real*4 on the sp - - implicit none - - integer im, jm - real A(IM,JM),rmin,rmax - integer i,j - character*8 title - - rmin = 1.e+10 - rmax = -rmin -!sela.................................................... -!sela if(rmin.eq.1.e+10)return -!sela.................................................... - DO j=1,JM - DO i=1,IM - if (A(i,j) >= rmax) rmax = A(i,j) - if (A(i,j) <= rmin) rmin = A(i,j) - ENDDO - ENDDO - write(0,150)rmin,rmax,title -150 format('rmin=',e13.4,2x,'rmax=',e13.4,2x,a8,' ') -! - RETURN - END - SUBROUTINE mnmxja(IM,JM,A,imax,jmax,title) - -! this routine is using real*4 on the sp - - implicit none - - integer im, jm - real A(IM,JM),rmin,rmax - integer i,j,imax,jmax - character*8 title - - rmin = 1.e+10 - rmax = -rmin -!sela.................................................... -!sela if(rmin.eq.1.e+10)return -!sela.................................................... - DO j=1,JM - DO i=1,IM - if (A(i,j) >= rmax) then - rmax = A(i,j) - imax = i - jmax = j - endif - if (A(i,j) <= rmin) rmin = A(i,j) - ENDDO - ENDDO - write(6,150)rmin,rmax,title -150 format('rmin=',e13.4,2x,'rmax=',e13.4,2x,a8,' ') -! - RETURN - END - -!----------------------------------------------------------------------- - SUBROUTINE SPFFT1(IMAX,INCW,INCG,KMAX,W,G,IDIR) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: SPFFT1 PERFORM MULTIPLE FAST FOURIER TRANSFORMS -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -! -! ABSTRACT: THIS SUBPROGRAM PERFORMS MULTIPLE FAST FOURIER TRANSFORMS -! BETWEEN COMPLEX AMPLITUDES IN FOURIER SPACE AND REAL VALUES -! IN CYCLIC PHYSICAL SPACE. -! SUBPROGRAM SPFFT1 INITIALIZES TRIGONOMETRIC DATA EACH CALL. -! USE SUBPROGRAM SPFFT TO SAVE TIME AND INITIALIZE ONCE. -! THIS VERSION INVOKES THE IBM ESSL FFT. -! -! PROGRAM HISTORY LOG: -! 1998-12-18 IREDELL -! -! USAGE: CALL SPFFT1(IMAX,INCW,INCG,KMAX,W,G,IDIR) -! -! INPUT ARGUMENT LIST: -! IMAX - INTEGER NUMBER OF VALUES IN THE CYCLIC PHYSICAL SPACE -! (SEE LIMITATIONS ON IMAX IN REMARKS BELOW.) -! INCW - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY -! (INCW >= IMAX/2+1) -! INCG - INTEGER FIRST DIMENSION OF THE REAL VALUE ARRAY -! (INCG >= IMAX) -! KMAX - INTEGER NUMBER OF TRANSFORMS TO PERFORM -! W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR>0 -! G - REAL(INCG,KMAX) REAL VALUES IF IDIR<0 -! IDIR - INTEGER DIRECTION FLAG -! IDIR>0 TO TRANSFORM FROM FOURIER TO PHYSICAL SPACE -! IDIR<0 TO TRANSFORM FROM PHYSICAL TO FOURIER SPACE -! -! OUTPUT ARGUMENT LIST: -! W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR<0 -! G - REAL(INCG,KMAX) REAL VALUES IF IDIR>0 -! -! SUBPROGRAMS CALLED: -! SCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -! DCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -! SRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -! DRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -! REMARKS: -! THE RESTRICTIONS ON IMAX ARE THAT IT MUST BE A MULTIPLE -! OF 1 TO 25 FACTORS OF TWO, UP TO 2 FACTORS OF THREE, -! AND UP TO 1 FACTOR OF FIVE, SEVEN AND ELEVEN. -! -! THIS SUBPROGRAM IS THREAD-SAFE. -! -!$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR - COMPLEX,INTENT(INOUT):: W(INCW,KMAX) - REAL,INTENT(INOUT):: G(INCG,KMAX) - REAL:: AUX1(25000+INT(0.82*IMAX)) - REAL:: AUX2(20000+INT(0.57*IMAX)) - INTEGER:: NAUX1,NAUX2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NAUX1=25000+INT(0.82*IMAX) - NAUX2=20000+INT(0.57*IMAX) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! FOURIER TO PHYSICAL TRANSFORM. - SELECT CASE(IDIR) - CASE(1:) - SELECT CASE(DIGITS(1.)) - CASE(DIGITS(1._4)) - CALL SCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL SCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CASE(DIGITS(1._8)) - CALL DCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL DCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - END SELECT -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! PHYSICAL TO FOURIER TRANSFORM. - CASE(:-1) - SELECT CASE(DIGITS(1.)) - CASE(DIGITS(1._4)) - CALL SRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL SRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CASE(DIGITS(1._8)) - CALL DRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL DRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - END SELECT - END SELECT - END SUBROUTINE - subroutine read_g(glob,ITOPO) -! -! --- if ITOPO = 1 then read gtopo30_gg.fine 43200X21600 30" file -! --- if ITOPO = 2 then read topo 30" .DEM tile files -! --- in either case, glob will be n Interger*2 array. -! --- This routine write out a grads ctl file for displaying the -! --- tiles in the output working dir. The glob array can not be -! --- acted on with grads, but the tiles can be if lat/lon are reduced slightly -!! - implicit none -!! - integer*2 glob(360*120,180*120) -!! - integer, parameter :: ix=40*120, jx=50*120 - &, ia=60*120, ja=30*120 -!! - integer*2 idat(ix,jx),itopo -!! -!!mr integer*2 m9999 -!!mr data m9999 / -9999 / -!! -!!mr integer i_count(360*120) -!!mr integer j_max_y(360*120) -!! - integer i,j,inttyp -!! - real(kind=8) dloin,dlain,rlon,rlat -!! - read(235) glob - rewind(235) -!! -!! - print*,' ' - call maxmin (glob,360*120*180*120,'global0') -!! -!! - dloin = 1.d0/120.d0 - dlain = 1.d0/120.d0 -!! - rlon = -179.995833333333333333333333d0 - rlat = 89.995833333333333333333333d0 -!! - inttyp =-1 ! average rectangular subset -!!mr inttyp = 1 ! take closest grid point value -!!mr inttyp = 0 ! interpolate from four closest grid point values -!! -! call la2ga_gtopo30(glob,360*120,180*120, -! & dloin,dlain,rlon,rlat,inttyp, -! & .true.,glob, -! & 0,lonf,latg) -!! - return - end - subroutine maxmin(ia,len,tile) -!!mr - implicit none -!!mr - integer len - integer*2 ia(len) - character*7 tile - integer iaamax, iaamin, j, m, ja, kount - integer(8) sum2,std,mean,isum - integer i_count_notset,kount_9 - -! --- missing is -9999 -! - isum = 0 - sum2 = 0 - kount = 0 - kount_9 = 0 - iaamax = -9999999 -!!mr iaamin = 1 - iaamin = 9999999 - i_count_notset = 0 - - do m=1,len - ja=ia(m) -!!mr if ( ja .lt. 0 ) print *,' ja < 0:',ja -!!mr if ( ja .eq. -9999 ) goto 10 - if ( ja .eq. -9999 ) then - kount_9 = kount_9 + 1 - cycle - endif - if ( ja == -12345 ) i_count_notset = i_count_notset + 1 -!!mr 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 -!!mr sum2 = sum2 + ifix( float(ja) * float(ja) ) - sum2 = sum2 + ja*ja - enddo -! - 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 minmaxj(IM,JM,A,title) - -! this routine is using real*4 on the sp - - implicit none - - integer im, jm - real(kind=4) A(IM,JM),rmin,rmax,undef - integer i,j,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. -!sela.................................................... -!sela if(rmin.eq.1.e+10)return -!sela.................................................... - DO j=1,JM - DO i=1,IM - if (A(i,j) >= rmax)then - rmax = A(i,j) - imax = i - jmax = j - endif - if (A(i,j) <= 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) -! - RETURN - END - subroutine nanc(a,l,c) -! compiler opt TRAPS= -qinitauto=FF911299 -qflttrap=ov:zero:inv:en -qsig trap -! or call subroutine below -! subroutine to report NaNS and NaNQ within an address -! range for real*8 words. -! as written the routine prints a single line for each call -! and prints a message and returns to the caller on detection of the FIRST -! NaN in the range. The message is passed in the third -! argument. If no NaN values are found it returns silently. -! A real*4 version can be created by making A real*4 - -! arguments (all are input only) -! -! A real*8 variable or array -! L number of words to scan (length of array) -! C distinctive message set in caller to indicate where -! the routine was called. -! - integer inan1,inan2,inan3,inan4,inaq1,inaq2,inaq3,inaq4 - real word - integer itest - equivalence (itest,word) -! -! signaling NaN - data inan1/x'7F800001'/ - data inan2/x'7FBFFFFF'/ - data inan3/x'FF800001'/ - data inan4/x'FFBFFFFF'/ -! -! quiet NaN -! - data inaq1/x'7FC00000'/ - data inaq2/x'7FFFFFFF'/ - data inaq3/x'FFC00000'/ - data inaq4/x'FFFFFFFF'/ -! - real(kind=8)a(l),rtc,t1,t2 - character*24 cn - character*(*) c - t1=rtc() -!gwv print *, ' nanc call ',c - do k=1,l - word = a(k) - if( (itest .GE. inan1 .AND. itest .LE. inan2) .OR. - * (itest .GE. inan3 .AND. itest .LE. inan4) ) then - print *,' NaNs detected at word',k,' ',c - return - endif - if( (itest .GE. inaq1 .AND. itest .LE. inaq2) .OR. - * (itest .GE. inaq3 .AND. itest .LE. inaq4) ) then - print *,' NaNq detected at word',k,' ',c - return - endif - - 101 format(e20.10) - end do - t2=rtc() -!gwv print 102,l,t2-t1,c - 102 format(' time to check ',i9,' words is ',f10.4,' ',a24) - return - end -C----------------------------------------------------------------------- - - SUBROUTINE SPTEZJ(JCAP,NC,KM,IDRT,LONB,LATB,JC,WAVE,GRID - &, latch,idir) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: SPTEZJ TRANSFORM A SINGLE SPECTRAL FIELD TO GRID -! PRGMMR: MOORTHI ORG: W/NMC23 DATE: 13-02-20 -! -! ABSTRACT: TRANSFORMS A SINGLE SPECTRAL FIELDS TO GRID -! -! PROGRAM HISTORY LOG: -! 13-02-20 S. MOORTHI -! -! USAGE: CALL SPTEZJ(JCAP,NC,KM,IDRT,LONB,LATB,JC,WAVE,GRID,IDIR) -! INPUT ARGUMENT LIST: -! JCAP INTEGER SPECTRAL TRUNCATION -! NC INTEGER FIRST DIMENSION (NC>=(JCAP+1)*(JCAP+2)) -! KM INTEGER NUMBER OF LEVELS -! IDRT INTEGER DATA REPRESENTATION TYPE -! (IDRT=4 FOR GAUSSIAN GRID, -! IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -! IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -! LONB INTEGER NUMBER OF LONGITUDES -! LATB INTEGER NUMBER OF LATITUDES -! JC INTEGER NUMBER OF CPUS -! WAVE REAL (NC) WAVE FIELD if IDIR>0 -! OUTPUT ARGUMENT LIST: -! GRID REAL (cwLONB,LATB,I,KM) GRID FIELD (E->W, N->S) IF IDIR<0 -! -! IDIR - INTEGER TRANSFORM FLAG -! (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -! LATCH - Latitude chunk used in the transform loop -! SUBPROGRAMS CALLED: -! SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!$$$ - implicit none -! - integer jcap, nc, km, idrt, lonb, latb, jc, latch, idir - REAL wave(NC,KM) - REAL GRID(LONB,LATB,KM) -! - real, allocatable :: gridl(:,:) -! - integer lonb2m, i, j, in, is, latbb2, lonb2, j1, j2, jl, ijl, ijn - &, ij, js, jn, ja, jb -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! SPECTRAL TRANSFORMS -! - LATBB2 = (LATB+1)/2 - LONB2 = LONB + LONB - ijn = LONB2 * LATCH - allocate (gridl(ijn,km)) - IN = 1 - IS = 1 + LONB -! -! write(0,*)' lonb=',lonb,' lonb2=',lonb2,' latbb2=',latbb2 -! &, ' latch=',latch,' ijn=',ijn,' idir=',idir,' km=',km -! - if (idir < 0) wave = 0.0 -! - DO J1=1,LATBB2,LATCH - J2 = MIN(J1+LATCH-1,LATBB2) - -! JL = 2*(J2-J1+1) -! IJL = LONB*JL -! IJ = LONB2 * (J2-J1+1) - - if (idir > 0) then -! write(0,*)' waveb=',wave(1:5,1) - CALL SPTRAN(0,JCAP,IDRT,LONB,LATB,KM,1,1,LONB2,LONB2,NC,IJN - &, J1,J2,JC,WAVE,GRIDL(IN,1),GRIDL(IS,1),1) - do j=j1,j2 - jn = j - js = latb+1-j - ja = (J-J1)*lonb2 - jb = ja + lonb - do i=1,lonb - grid(i,jn,:) = gridl(I+ja,:) - grid(i,js,:) = gridl(I+jb,:) - enddo - enddo -! write(0,*)' grida=',grid(lonb/2,jn,:) - else -! write(0,*)' SPTEZJ: j1=',j1,' j2=',j2 - do j=j1,j2 - jn = j - js = latb+1-j - ja = (J-J1)*lonb2 - jb = ja + lonb - do i=1,lonb - gridl(I+ja,:) = grid(i,jn,:) - gridl(I+jb,:) = grid(i,js,:) - enddo - enddo -! write(0,*)' BEF SPTRAN gridlN=',gridl(ja+1:ja+lonb,1),' j=',j -! write(0,*)' BEF SPTRAN gridlS=',gridl(jb+1:jb+lonb,1),' j=',j - CALL SPTRAN(0,JCAP,IDRT,LONB,LATB,KM,1,1,LONB2,LONB2,NC,IJN - &, J1,J2,JC,WAVE,GRIDL(IN,1),GRIDL(IS,1),-1) -! write(0,*)' wave=',wave(1:10,1) - endif -! - ENDDO ! j - loop - deallocate (gridl) -! - END -C----------------------------------------------------------------------- - SUBROUTINE SPLAT0(IDRT,JMAX,SLAT,WLAT) -C SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLAT COMPUTE LATITUDE FUNCTIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: COMPUTES COSINES OF COLATITUDE AND GAUSSIAN WEIGHTS -C FOR ONE OF THE FOLLOWING SPECIFIC GLOBAL SETS OF LATITUDES. -C GAUSSIAN LATITUDES (IDRT=4) -C EQUALLY-SPACED LATITUDES INCLUDING POLES (IDRT=0) -C EQUALLY-SPACED LATITUDES EXCLUDING POLES (IDRT=256) -C THE GAUSSIAN LATITUDES ARE LOCATED AT THE ZEROES OF THE -C LEGENDRE POLYNOMIAL OF THE GIVEN ORDER. THESE LATITUDES -C ARE EFFICIENT FOR REVERSIBLE TRANSFORMS FROM SPECTRAL SPACE. -C (ABOUT TWICE AS MANY EQUALLY-SPACED LATITUDES ARE NEEDED.) -C THE WEIGHTS FOR THE EQUALLY-SPACED LATITUDES ARE BASED ON -C ELLSAESSER (JAM,1966). (NO WEIGHT IS GIVEN THE POLE POINT.) -C NOTE THAT WHEN ANALYZING GRID TO SPECTRAL IN LATITUDE PAIRS, -C IF AN EQUATOR POINT EXISTS, ITS WEIGHT SHOULD BE HALVED. -C THIS VERSION INVOKES THE IBM ESSL MATRIX SOLVER. -C -C PROGRAM HISTORY LOG: -C 96-02-20 IREDELL -C 97-10-20 IREDELL ADJUST PRECISION -C 98-06-11 IREDELL GENERALIZE PRECISION USING FORTRAN 90 INTRINSIC -C 1998-12-03 IREDELL GENERALIZE PRECISION FURTHER -C 1998-12-03 IREDELL USES AIX ESSL BLAS CALLS -C 2009-12-27 DSTARK updated to switch between ESSL calls on an AIX -C platform, and Numerical Recipies calls elsewise. -C 2010-12-30 SLOVACEK update alignment so preprocessor does not cause -C compilation failure -C 2012-09-01 E.Mirvis & M.Iredell merging & debugging linux errors -C of _d and _8 using generic LU factorization. -C 2012-11-05 E.Mirvis generic FFTPACK and LU lapack were removed -C---------------------------------------------------------------- -C USAGE: CALL SPLAT(IDRT,JMAX,SLAT,WLAT) -C -C INPUT ARGUMENT LIST: -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C JMAX - INTEGER NUMBER OF LATITUDES. -C -C OUTPUT ARGUMENT LIST: -C SLAT - REAL (JMAX) SINES OF LATITUDE. -C WLAT - REAL (JMAX) GAUSSIAN WEIGHTS. -C -C SUBPROGRAMS CALLED: -C DGEF MATRIX FACTORIZATION - ESSL -C DGES MATRIX SOLVER - ESSL -C LUDCMP LU factorization - numerical recipies -C LUBKSB Matrix solver - numerical recipies -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C - REAL SLAT(JMAX),WLAT(JMAX) - INTEGER,PARAMETER:: KD=SELECTED_REAL_KIND(15,45) - REAL(KIND=KD):: PK(JMAX/2),PKM1(JMAX/2),PKM2(JMAX/2) - REAL(KIND=KD):: SLATD(JMAX/2),SP,SPMAX,EPS=10.*EPSILON(SP) - PARAMETER(JZ=50) - REAL BZ(JZ) - DATA BZ / 2.4048255577, 5.5200781103, - $ 8.6537279129, 11.7915344391, 14.9309177086, 18.0710639679, - $ 21.2116366299, 24.3524715308, 27.4934791320, 30.6346064684, - $ 33.7758202136, 36.9170983537, 40.0584257646, 43.1997917132, - $ 46.3411883717, 49.4826098974, 52.6240518411, 55.7655107550, - $ 58.9069839261, 62.0484691902, 65.1899648002, 68.3314693299, - $ 71.4729816036, 74.6145006437, 77.7560256304, 80.8975558711, - $ 84.0390907769, 87.1806298436, 90.3221726372, 93.4637187819, - $ 96.6052679510, 99.7468198587, 102.888374254, 106.029930916, - $ 109.171489649, 112.313050280, 115.454612653, 118.596176630, - $ 121.737742088, 124.879308913, 128.020877005, 131.162446275, - $ 134.304016638, 137.445588020, 140.587160352, 143.728733573, - $ 146.870307625, 150.011882457, 153.153458019, 156.295034268 / - REAL:: DLT,D1=1. - REAL AWORK((JMAX+1)/2,((JMAX+1)/2)),BWORK(((JMAX+1)/2)) - INTEGER:: JHE,JHO,J0=0 - INTEGER IPVT((JMAX+1)/2) - PARAMETER(PI=3.14159265358979,C=(1.-(2./PI)**2)*0.25) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GAUSSIAN LATITUDES - IF(IDRT.EQ.4) THEN - JH=JMAX/2 - JHE=(JMAX+1)/2 - R=1./SQRT((JMAX+0.5)**2+C) - DO J=1,MIN(JH,JZ) - SLATD(J)=COS(BZ(J)*R) - ENDDO - DO J=JZ+1,JH - SLATD(J)=COS((BZ(JZ)+(J-JZ)*PI)*R) - ENDDO - SPMAX=1. - DO WHILE(SPMAX.GT.EPS) - SPMAX=0. - DO J=1,JH - PKM1(J)=1. - PK(J)=SLATD(J) - ENDDO - DO N=2,JMAX - DO J=1,JH - PKM2(J)=PKM1(J) - PKM1(J)=PK(J) - PK(J)=((2*N-1)*SLATD(J)*PKM1(J)-(N-1)*PKM2(J))/N - ENDDO - ENDDO - DO J=1,JH - SP=PK(J)*(1.-SLATD(J)**2)/(JMAX*(PKM1(J)-SLATD(J)*PK(J))) - SLATD(J)=SLATD(J)-SP - SPMAX=MAX(SPMAX,ABS(SP)) - ENDDO - ENDDO -CDIR$ IVDEP - DO J=1,JH - SLAT(J)=SLATD(J) - WLAT(J)=(2.*(1.-SLATD(J)**2))/(JMAX*PKM1(J))**2 - SLAT(JMAX+1-J)=-SLAT(J) - WLAT(JMAX+1-J)=WLAT(J) - ENDDO - IF(JHE.GT.JH) THEN - SLAT(JHE)=0. - WLAT(JHE)=2./JMAX**2 - DO N=2,JMAX,2 - WLAT(JHE)=WLAT(JHE)*N**2/(N-1)**2 - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C EQUALLY-SPACED LATITUDES INCLUDING POLES - ELSEIF(IDRT.EQ.0) THEN - JH=JMAX/2 - JHE=(JMAX+1)/2 - JHO=JHE-1 - DLT=PI/(JMAX-1) - SLAT(1)=1. - DO J=2,JH - SLAT(J)=COS((J-1)*DLT) - ENDDO - DO JS=1,JHO - DO J=1,JHO - AWORK(JS,J)=COS(2*(JS-1)*J*DLT) - ENDDO - ENDDO - DO JS=1,JHO - BWORK(JS)=-D1/(4*(JS-1)**2-1) - ENDDO -!#if IBM4 || IBM8 -! CALL DGEF(AWORK,JHE,JHO,IPVT) -! CALL DGES(AWORK,JHE,JHO,IPVT,BWORK,J0) -!#endif -!#if LINUX - call ludcmp(awork,jho,jhe,ipvt) - call lubksb(awork,jho,jhe,ipvt,bwork) -!#endif - WLAT(1)=0. - DO J=1,JHO - WLAT(J+1)=BWORK(J) - ENDDO -CDIR$ IVDEP - DO J=1,JH - SLAT(JMAX+1-J)=-SLAT(J) - WLAT(JMAX+1-J)=WLAT(J) - ENDDO - IF(JHE.GT.JH) THEN - SLAT(JHE)=0. - WLAT(JHE)=2.*WLAT(JHE) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C EQUALLY-SPACED LATITUDES EXCLUDING POLES - ELSEIF(IDRT.EQ.256) THEN - JH=JMAX/2 - JHE=(JMAX+1)/2 - JHO=JHE - DLT=PI/JMAX - SLAT(1)=1. - DO J=1,JH - SLAT(J)=COS((J-0.5)*DLT) - ENDDO - DO JS=1,JHO - DO J=1,JHO - AWORK(JS,J)=COS(2*(JS-1)*(J-0.5)*DLT) - ENDDO - ENDDO - DO JS=1,JHO - BWORK(JS)=-D1/(4*(JS-1)**2-1) - ENDDO -!#if IBM4 || IBM8 -! CALL DGEF(AWORK,JHE,JHO,IPVT) -! CALL DGES(AWORK,JHE,JHO,IPVT,BWORK,J0) -!#endif -!#if LINUX - call ludcmp(awork,jho,jhe,ipvt,d) - call lubksb(awork,jho,jhe,ipvt,bwork) -!#endif - WLAT(1)=0. - DO J=1,JHO - WLAT(J)=BWORK(J) - ENDDO -CDIR$ IVDEP - DO J=1,JH - SLAT(JMAX+1-J)=-SLAT(J) - WLAT(JMAX+1-J)=WLAT(J) - ENDDO - IF(JHE.GT.JH) THEN - SLAT(JHE)=0. - WLAT(JHE)=2.*WLAT(JHE) - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/util/sorc/terrain.fd/mtnlm7_slm30g_oclsm.f b/util/sorc/terrain.fd/mtnlm7_slm30g_oclsm.f deleted file mode 100644 index 0566d1a48a..0000000000 --- a/util/sorc/terrain.fd/mtnlm7_slm30g_oclsm.f +++ /dev/null @@ -1,2772 +0,0 @@ -!$$$ MAIN PROGRAM DOCUMENTATION BLOCK -! -! MAIN PROGRAM: TERRAIN TERRAIN MAKER FOR GLOBAL SPECTRAL MODEL -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-04-16 -! -! ABSTRACT: THIS PROGRAM CREATES 7 TERRAIN-RELATED FILES -! COMPUTED FROM THE NAVY 10-MINUTE TERRAIN DATASET. -! THE MODEL PHYSICS GRID PARAMETERS AND SPECTRAL TRUNCATION -! AND FILTER PARAMETERS ARE READ BY THIS PROGRAM AS INPUT. -! THE 7 FILES PRODUCED ARE RESPECTIVELY: -! 1) SEA-LAND MASK ON MODEL PHYSICS GRID -! 2) GRIDDED OROGRAPHY ON MODEL PHYSICS GRID -! 3) MOUNTAIN STD DEV ON MODEL PHYSICS GRID -! 4) SPECTRAL OROGRAPHY IN SPECTRAL DOMAIN -! 5) UNFILTERED GRIDDED OROGRAPHY ON MODEL PHYSICS GRID -! 6) GRIB SEA-LAND MASK ON MODEL PHYSICS GRID -! 7) GRIB GRIDDED OROGRAPHY ON MODEL PHYSICS GRID -! THE OROGRAPHY IS ONLY FILTERED FOR WAVENUMBERS GREATER THAN NF0. -! FOR WAVENUMBERS N BETWEEN NF0 AND NF1, THE OROGRAPHY IS FILTERED -! BY THE FACTOR 1-((N-NF0)/(NF1-NF0))**2. THE FILTERED OROGRAPHY -! WILL NOT HAVE INFORMATION BEYOND WAVENUMBER NF1. -! -! 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 including lat/lon grid -! 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 -! --- 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 -! --- but if no filter but spectral to grid (with gibbs) then NF1=jcap+2, and NF1=jcap+1 -! 11-06-22 S. Moorthi - convert the code to "implicit none" added grib -! output of unfiltered orography -! 13-02-20 S. Moorthi - Added SPTEZJ so that the filter can be applied -! at resolutions t1534 and higher -! Also optimized to code to use less memory -! 13-06-19 S. Moorthi - Made it work on wcoss -! -! -! USAGE: -! -! INPUT FILES: -! UNIT5 - PHYSICS LONGITUDES (IM), PHYSICS LATITUDES (JM), -! SPECTRAL TRUNCATION (NM), RHOMBOIDAL FLAG (NR), -! AND FIRST AND SECOND FILTER PARAMETERS (NF0,NF1). -! RESPECTIVELY READ IN FREE FORMAT. -! UNIT235 - GTOPO 30" AVR for ZAVG elevation -! UNIT10 - 30" UMD land (lake) cover mask see MSKSRC switch -! XUNIT11 - GTOPO AVR -! XUNIT12 - GTOPO STD DEV -! XUNIT13 - GTOPO MAX -! UNIT14 - GTOPO SLM (10' NAVY if switched to get lakes) -! UNIT15 - GICE Grumbine 30" RAMP Antarctica orog IMNx3616 -! UNIT25 - Ocean land-sea mask on gaussian grid -! -! OUTPUT FILES: -! UNIT51 - SEA-LAND MASK (IM,JM) -! UNIT52 - GRIDDED OROGRAPHY (IM,JM) -! UNIT53 - MOUNTAIN STD DEV (IM,JM) -! UNIT54 - SPECTRAL OROGRAPHY ((NM+1)*((NR+1)*NM+2)) -! UNIT55 - UNFILTERED GRIDDED OROGRAPHY (IM,JM) -! UNIT56 - GRIB SEA-LAND MASK (IM,JM) -! UNIT57 - GRIB GRIDDED OROGRAPHY (IM,JM) -! UNIT58 - GRIB PRINCIPAL COORD THETA (IM,JM) -! UNIT59 - GRIB PRINCIPAL COORD SIGMA (IM,JM) -! UNIT60 - GRIB PRINCIPAL COORD GAMMA (IM,JM) -! UNIT61 - GRIB MOUNTAIN STD VAR (IM,JM) -! UNIT62 - GRIB MOUNTAIN MAX ELEVATION (IM,JM) -! -! SUBPROGRAMS CALLED: -! UNIQUE: -! TERSUB - MAIN SUBPROGRAM -! read_g - read in 30" elevations -! SPLAT - COMPUTE GAUSSIAN LATITUDES OR EQUALLY-SPACED LATITUDES -! LIBRARY: -! SPTEZ - SPHERICAL TRANSFORM -! SPTEZJ - SPHERICAL TRANSFORM -! GBYTES - UNPACK BITS -! -! REMARKS: FORTRAN 9X EXTENSIONS ARE USED. -! ITOPO determines if the 43200X21600 topo 30" is read in -! from the 30" array record. .DEM tiles are done offline. -! -! ATTRIBUTES: -! CRAY YMP & IBM AIX 3 5 00C88D5D4C00. -!C -!$$$ -!FPP$ NOCONCUR F - implicit none -! - integer MTNRES, IM, JM, NM, NR, NF0, NF1, NW, IMN, JMN, latch - real EFAC,BLAT -! - latch = 1 - READ(5,*) MTNRES,IM,JM,NM,NR,NF0,NF1,EFAC,BLAT - -! --- 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,IM,JM,NM,NR,NF0,NF1,EFAC,BLAT - - NW = (NM+1)*((NR+1)*NM+2) - IMN = 360*120/MTNRES - JMN = 180*120/MTNRES - print *, ' Starting terr mtnlm7_slm10.f IMN,JMN:',IMN,JMN - - call start() - - CALL TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC,BLAT,latch) - -! call summary() - STOP - END - SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC,BLAT,latch) - implicit none -! - integer, parameter :: NMT=14 - logical, parameter :: check_nans=.false. -! logical, parameter :: check_nans=.true. -! - integer IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW - real efac, blat - INTEGER ZSLMX(2700,1350) - - INTEGER, allocatable:: ZAVG(:,:), ZSLM(:,:) - REAL(4), allocatable:: GICE(:,:), OCLSM(:,:) - integer*1,allocatable:: UMD(:,:) - - integer latch - integer*1 i3save - integer*2 glob(IMN,JMN), i2save - INTEGER KPDS(200),KGDS(200), zsave1,zsave2,itopo,kount - INTEGER kount2, islmx, jslmx, oldslm, msksrc, mskocn, notocn -! - real, dimension(jm) :: COSCLT, WGTCLT, RCLT, XLAT - REAL, dimension(im,jm) :: SLM, ORO, ORF, oro_s - real :: ors(nw), diffx(jm/2) - - REAL, allocatable :: VAR(:,:), VAR4(:,:), OA(:,:,:), OL(:,:,:)& - &, THETA(:,:), GAMMA(:,:), SIGMA(:,:) & - &, ELVMAX(:,:),SLMI(:,:) - integer IST(IM,jm), IEN(IM,jm), JST(JM),JEN(JM) - integer, allocatable :: IWORK(:,:,:) - real glat(jmn) - real, allocatable :: work1(:,:),work2(:,:), work3(:,:) & - &, work4(:,:), work5(:,:), work6(:,:), & - & hprime(:,:,:) - - LOGICAL SPECTR, REVLAT, FILTER - integer numi(jm),ios,iosg,latg2,istat - integer maxc3,maxc4,maxc5,maxc6,maxc7,maxc8 - integer lonsperlat(jm/2),itest,jtest, i, j, k - &, it, jt, i1, jn, js, iw, ie, in, inw, ine, m, n, imt - &, is, ise, isw, lb, iret, imb2p1 - real oaa(4), ola(4), sumdif, avedif, alon, alat, pi - &, degrad, rn, rs, slma, oroa, vara, var4a, wgta, xn, xs - &, fff, www, phi, delxn - complex ffj(im/2+1) - - allocate (ZAVG(IMN,JMN)) - allocate (ZSLM(IMN,JMN)) - allocate (GICE(IMN+1,3601)) - allocate (UMD(IMN,JMN)) - allocate (OCLSM(IM,JM)) - allocate (iwork(im,jm,4)) - allocate (work1(im,jm), work2(im,jm), work3(im,jm) & - &, work4(im,jm), work5(im,jm), work6(im,jm) & - &, hprime(im,jm,nmt)) - allocate (VAR(im,jm), VAR4(im,jm), OA(im,jm,4), OL(im,jm,4) & - &, THETA(im,jm), GAMMA(im,jm), SIGMA(im,jm), ELVMAX(im,jm)) - -! -! SET CONSTANTS AND ZERO FIELDS -! - imb2p1 = im/2 + 1 - pi = 4.0 * atan(1.0) - DEGRAD = 180./PI - SPECTR = NM > 0 ! if NM <=0 then grid is assumed to be lat/lon - FILTER = .TRUE. ! Spectral Filter defaults true and set by NF1 & NF0 - - ! MSKSRC=0 navy 10 lake msk, 1 UMD 30, -1 no lakes -! MSKSRC = 0 - MSKSRC = 1 - MSKOCN = 0 ! 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. - - REVLAT = BLAT < 0 ! Reverse latitude/longitude for output - ITOPO = 1 ! topo 30" read, otherwise tiles (opt offline) - - write(0,*)' In TERSUB, ITOPO=',itopo - - if (mskocn == 1) then - write(0,*) ' Ocean Model LSM Present and ' - write(0,*) ' Overrides OCEAN POINTS in LSM: mskocn=',mskocn - if (notocn == 1) then - write(0,*) ' Ocean LSM Reversed: NOTOCN=',notocn - endif - endif -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! --- old S-Y. files -!- OPEN(UNIT=11,FORM='FORMATTED',ERR=900) ! average -!- OPEN(UNIT=12,FORM='FORMATTED',ERR=900) ! Std Dev -!- OPEN(UNIT=13,FORM='FORMATTED',ERR=900) ! maximum -!- OPEN(UNIT=14,FORM='FORMATTED',ERR=900) ! sea-land-lake-mask -! -! --- READ(11,11) ZAVG -! --- READ(12,11) ZVAR -! --- READ(13,11) ZMAX -! --- 11 FORMAT(20I4) -! -! --- MSKSRC 0 navy 10' lake mask, =1 for 30" UMD lake mask, -! --- MSKSRC internally set if above fails at -1 for no lakes -! --- -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IF (MSKSRC == 0 ) then - READ(14,12,iostat=ios) ZSLMX - 12 FORMAT(80I1) - if (ios /= 0) then - MSKSRC = -1 - write(0,*)' navy10 lake mask rd fail - ios,MSKSRC:',ios,MSKSRC - endif - ELSE - write(0,*)' Attempt to open/read UMD 30" slmsk MSKSRC=',MSKSRC -! --- not 0 so MSKSRC=1 and attempt to open/read UMD 30" slmsk - -! open(10,file="/global/noscrub/wx23ja/terrain30/landcover30.fixed -! &", recl=43200*21600, access='direct',iostat=istat) - - open(10,file="landcover30.fixed", recl=43200*21600, - & access='direct',iostat=istat) - IF (istat /= 0) then - MSKSRC = -1 - print *,' UMD lake mask open failed -- ios,MSKSRC:',ios,MSKSRC - ELSE -! - read(10, rec=1,iostat=istat) UMD - - ENDIF -! -------------- - IF (istat /= 0) then ! --- When UMD read fails attempt to read navy 10' - print *,' UMD lake mask readd err -- trying navy 10',istat - MSKSRC = 0 - print *,' ***** MSKSRC set to 0 MSKSRC=',MSKSRC - if (MSKSRC == 0 ) then - rewind 14 - READ(14,12,iostat=ios) ZSLMX - if (ios /= 0) then - MSKSRC = -1 - print *,' navy10 lake mask rd fail - ios,MSKSRC:',ios - &, MSKSRC - endif - endif - ELSE - print *,' UMD lake, UMD(500,500)=',UMD(500,500),MSKSRC - ENDIF -! -------------- -! --- good UMD land cover read and MSKSRC = 1 - ENDIF -! -!- READ_G for global 30" terrain -! - print *,' Read 30" topography or call read_g, ITOPO=',ITOPO - - if (itopo /= 0) then - read(235) glob - rewind(235) -! elseif ( ITOPO /= 0 )then -! call read_g(glob,ITOPO) - endif - -! --- transpose even though glob 30" is from S to N and NCEP std is N to S - - do j=1,jmn/2 - jt = jmn - j + 1 - do I=1,imn - 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) -! - -! --- IMN,JMN - write(0,*)' IM, JM, NM, NR, NF0, NF1, EFAC, BLAT' - write(0,*) IM,JM,NM,NR,NF0,NF1,EFAC,BLAT - write(0,*)' imn,jmn,glob(imn,jmn)=',imn,jmn,glob(imn,jmn) - write(0,*)' UBOUND ZAVG=',UBOUND(ZAVG) - write(0,*)' UBOUND glob=',UBOUND(glob) - write(0,*)' UBOUND ZSLM=',UBOUND(ZSLM) - write(0,*)' UBOUND GICE=',UBOUND(GICE) - - kount = 0 - kount2 = 0 -! -! --- 0 is ocean and 1 is land for slm -! -! --- ZSLM initialize with all land 1, ocean 0 -! ZSLM=1 - do j=1,jmn - do i=1,imn - zslm(i,j) = 1 - enddo - enddo - - SELECTCASE(MSKSRC) - - CASE(1) !---- 30" sea land mask. 0 are water (lake or ocean) - ! ---------------------------------------------- - -! --- transpose even though glob 30" is from S to N and NCEP std is N to S - do j=1,jmn/2 - jt = jmn - j + 1 - do I=1,imn - 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 -! --- UMD slmsk with 30" lakes and set ZAVG from glob - do j=1,jmn - do i=1,imn - if ( UMD(i,j) == 0 ) ZSLM(i,j) = 0 - ZAVG(i,j) = glob(i,j) - enddo - enddo -! - CASE(0) ! --- When navy 10' mask is set MSKSRC=0 - ! ----------------------------------- - -! --- MSKSRC 0 navy 10' lake mask, =1 for 30" UMD lake mask, -1 no lakes - write(0,*)' NAVY 10 (8) slmsk for lakes, MSKSRC=',MSKSRC - - kount = 0 - kount2 = 0 - do j=1,jmn - oldslm = ZSLM(IMN,j) - do i=1,imn - i1 = i + 1 -! --- slmsk with 10' lakes and set ZAVG from 30" glob - ZAVG(i,j) = glob(i,j) - if ( glob(i,j) == -9999 ) then - ZSLM(i,j) = 0 - kount = kount + 1 - endif - islmx = (i-1)/16 + 1 - jslmx = (j-1)/16 + 1 - if ( ZSLMX(islmx,jslmx) == 0 ) then - if ( j > 8 .and. j < JMN-8 ) then - if (i1 > IMN ) i1 = i1 - IMN -! ----- - if(ZSLM(i,j) == 1 .and. oldslm == 1 - & .and. ZSLM(i1,j) == 1) then -! if (i /= 1) oldslm = ZSLM(i,j) - ZSLM(i,j) = 0 - kount2 = kount2 + 1 - endif -! ----- - endif - endif - enddo - enddo -! --- - CASE(-1) - print *,' **** set ZAVG and slm from 30" glob, MSKSRC=',MSKSRC - kount = 0 - kount2 = 0 - do j=1,jmn - do i=1,imn - i1 = i + 1 -! --- UMD slmsk with 10' lakes and set ZAVG from 30" glob - ZAVG(i,j) = glob(i,j) - if ( glob(i,j) == -9999 ) then - ZSLM(i,j) = 0 - kount = kount + 1 - endif - enddo - enddo - END SELECT -! --- -! --- There was an error in the topo 30" data set at pole (-9999). - do i=1,imn - ZSLM(i,1) = 0 - ZSLM(i,JMN) = 1 - enddo -! - write(0,*)' kount,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. -! -! READ REDUCED GRID EXTENTS IF GIVEN -! - read(20,*,iostat=ios) latg2,lonsperlat - if (ios /= 0 .or. 2*latg2 /= jm) then - do j=1,jm - numi(j) = im - enddo - write(0,*) ios,latg2,'COMPUTE TERRAIN ON A FULL GAUSSIAN GRID' - else - do j=1,jm/2 - numi(j) = lonsperlat(j) - enddo - do j=jm/2+1,jm - numi(j) = lonsperlat(jm+1-j) - enddo - write(0,*) ios,latg2,'COMPUTE TERRAIN ON A REDUCED GAUSSIAN', - & ' GRID', numi -! print *,ios,latg2,'COMPUTE TERRAIN ON A REDUCED GAUSSIAN GRID' - endif - - write(0,*) ios,latg2,'TERRAIN ON GAUSSIAN GRID',numi - -! -! This code assumes that lat runs from north to south for gg! -! - write(0,*)' SPECTR=',SPECTR,' REVLAT=',REVLAT,'** with GICE-07 **' - - IF (SPECTR) THEN - CALL SPLAT(4,JM,COSCLT,WGTCLT) - DO J=1,JM/2 - RCLT(J) = ACOS(COSCLT(J)) - 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 -! -! print *,' cosclt=',cosclt - print *,' RCLT(1)=',RCLT(1) - - 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)) - - write(0,*)' 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)) -! - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -! - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO - - write(0,*)' Before GICE ZAVG(1,2)=',ZAVG(1,2),ZSLM(1,2) - write(0,*)' Before GICE ZAVG(1,12)=',ZAVG(1,12),ZSLM(1,12) - write(0,*)' Before GICE ZAVG(1,52)=',ZAVG(1,52),ZSLM(1,52) - write(0,*)' Before GICE ZAVG(1,112)=',ZAVG(1,JMN-112),ZSLM(1,112) - -! GICE: Grumbine 30" Antarctica orog IMNx3616 from S to N & wraped E-W. -! NB: Zfields are S to N and W-E! - - iosg = 0 - READ(15,iostat=iosg) GICE - if (iosg /= 0 ) then - write(0,*)' *** Err on reading GICE record, iosg=',iosg - write(0,*)' exec continues but NO GICE correction done ' -! stop - else - write(0,*)' GICE 30" Antarctica RAMP orog 43200x3616 read OK' - write(0,*)' Processing! ' - write(0,*)' Processing! ' - write(0,*)' Processing! ' - do j = 1, 3601 - do i = 1, IMN - zsave1 = ZAVG(i,j) - zsave2 = ZSLM(i,j) - if( GICE(i,j) /= -99. .and. GICE(i,j) /= -1.0 ) then - if ( GICE(i,j) > 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 - ALON = float(i-1) * 360./float(IMN) - ALAT = glat(j) - -! if( ZAVG(i,j) .ne. zsave1 .and. i .lt. 3 ) -! & print *,' antarctica change to ZAVG(i=',i,'j=',j,')=', -! & ZAVG(i,j),ZSLM(i,j),' from originally:',zsave1,zsave2 -! &write(6,151)i,j,ZAVG(i,j),ZSLM(i,j),zsave1,zsave2,ALAT,ALON -! 151 format(1x,'antarctica ZAVG(i=',i3,' j=',i3,')=',i5,i3, -! &' orig:',i5,i3,' Lat=',f8.3,f9.3,'E') - - if( ZAVG(i,j) /= zsave1 ) then - if ( i <= 1201 .and. i > 1200 )then - write(6,152) i,j,ZAVG(i,j),ZSLM(i,j),zsave1,zsave2, - & ALAT,ALON,GICE(i,j) - 152 format(1x,' ZAVG(i=',i4,' j=',i4,')=',i5,i3, - & ' orig:',i5,i4,' Lat=',f7.3,f8.2,'E',' GICE=',f8.1) - endif - endif - enddo - enddo - endif - -! print *, -! & ' After GICE ZAVG(1,2)=',ZAVG(1,2),ZSLM(1,2) -! print *, -! & ' After GICE ZAVG(1,12)=',ZAVG(1,12),ZSLM(1,12) -! print *, -! & ' After GICE ZAVG(1,52)=',ZAVG(1,52),ZSLM(1,52) -! print *, -! & ' After GICE ZAVG(1,112)=',ZAVG(1,112),ZSLM(1,112) -! -! COMPUTE MOUNTAIN DATA : ORO SLM VAR (Std Dev) OC -! -! --- 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 == 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 /= 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 - do j=1,jm - do i=1,im - OCLSM(i,j) = 0. - enddo - enddo -! read(25,iostat=ios)OCLSM - -! read(25,iostat=ios)OCLSM - read(25,*,iostat=ios) OCLSM - if (ios /= 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 == 1 ) then - allocate(slmi(im,jm)) - DO J = 1,JM - DO I = 1,numi(j) - if ( notocn == 0 ) then - slmi(i,j) = float(NINT(OCLSM(i,j))) - else - if ( NINT(OCLSM(i,j)) == 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 == 1)then - print *,'LSM:',OCLSM(1,1),OCLSM(50,50),OCLSM(75,75),OCLSM(IM,JM) - endif -! -! --- CALL MAKEMT(ZAVG,ZSLM,ORO,OCLSM,mskocn,SLM,VAR,VAR4,GLAT, - if (numi(1) < im) then - do j=1,jm - do i=numi(j)+1,im - oro(i,j) = 0.0 - slm(i,j) = 0.0 - var(i,j) = 0.0 - var4(i,j) = 0.0 - enddo - enddo - endif -! - CALL MAKEMT(ZAVG,ZSLM,ORO,SLM,VAR,VAR4,GLAT, - & IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - call minmxj(IM,JM,ORO,' ORO') - call minmxj(IM,JM,SLM,' SLM') - call minmxj(IM,JM,VAR,' VAR') - call minmxj(IM,JM,VAR4,' VAR4') - if (check_nans) then ! --- check for nands in above - call nanc(ORO,IM*JM,"MAKEMT_ORO") - call nanc(SLM,IM*JM,"MAKEMT_SLM") - call nanc(VAR,IM*JM,"MAKEMT_VAR") - call nanc(VAR4,IM*JM,"MAKEMT_VAR4") - endif -! -! check antarctic pole -! DO J = 1,JM -! DO I = 1,numi(j) -! 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 - -! write(0,*)' ORO=',oro(:,:) -! -! === Compute mtn principal coord HTENSR: THETA,GAMMA,SIGMA -! - if (numi(1) < im) then - do j=1,jm - do i=numi(j)+1,im - theta(i,j) = 0.0 - gamma(i,j) = 0.0 - sigma(i,j) = 0.0 - enddo - enddo - endif -! - CALL MAKEPC(ZAVG,ZSLM,THETA,GAMMA,SIGMA,GLAT, - 1 IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - call minmxj(IM,JM,THETA,' THETA') - call minmxj(IM,JM,GAMMA,' GAMMA') - call minmxj(IM,JM,SIGMA,' SIGMA') - if (check_nans) then ! --- check for nands in above - call nanc(THETA,IM*JM,"MAKEPC_THETA") - call nanc(GAMMA,IM*JM,"MAKEPC_GAMMA") - call nanc(SIGMA,IM*JM,"MAKEPC_SIGMA") - endif -! -! COMPUTE MOUNTAIN DATA : OA OL -! - if (numi(1) < im) then - do j=1,jm - do i=numi(j)+1,im - oa(i,j,:) = 0.0 - ol(i,j,:) = 0.0 - elvmax(i,j) = 0.0 - enddo - enddo - endif -! - call minmxj(IM,JM,ORO,' ORO') - CALL MAKEOA(ZAVG,VAR,GLAT,OA,OL,IWORK,ELVMAX,ORO, - & WORK1,WORK2,WORK3,WORK4, - & WORK5,WORK6, - & IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - call minmxj(IM,JM,OA,' OA') - call minmxj(IM,JM,OL,' OL') - call minmxj(IM,JM,ELVMAX,' ELVMAX') - call minmxj(IM,JM,ORO,' ORO') - if (check_nans) then ! --- check for nands in above -! --- check for nands in above - call nanc(OA(1,1,1), IM*JM,"MAKEOA_OA(1,1,1)") - call nanc(OA(1,1,2), IM*JM,"MAKEOA_OA(1,1,2)") - call nanc(OA(1,1,3), IM*JM,"MAKEOA_OA(1,1,3)") - call nanc(OA(1,1,4), IM*JM,"MAKEOA_OA(1,1,4)") - call nanc(OL(1,1,1), IM*JM,"MAKEOA_OL(1,1,1)") - call nanc(OL(1,1,2), IM*JM,"MAKEOA_OL(1,1,2)") - call nanc(OL(1,1,3), IM*JM,"MAKEOA_OL(1,1,3)") - call nanc(OL(1,1,4), IM*JM,"MAKEOA_OL(1,1,4)") - call nanc(ELVMAX, IM*JM,"MAKEPC_ELVMAX") - endif - - maxc3 = 0 - maxc4 = 0 - maxc5 = 0 - maxc6 = 0 - maxc7 = 0 - maxc8 = 0 - DO J = 1,JM - DO I = 1,numi(j) - if (ELVMAX(I,J) > 3000.) maxc3 = maxc3 +1 - if (ELVMAX(I,J) > 4000.) maxc4 = maxc4 +1 - if (ELVMAX(I,J) > 5000.) maxc5 = maxc5 +1 - if (ELVMAX(I,J) > 6000.) maxc6 = maxc6 +1 - if (ELVMAX(I,J) > 7000.) maxc7 = maxc7 +1 - if (ELVMAX(I,J) > 8000.) maxc8 = maxc8 +1 - ENDDO - ENDDO - write(0,*)' MAXC3:',maxc3,maxc4,maxc5,maxc6,maxc7,maxc8 -! -! itest = 151 -! jtest = 56 -! - write(0,*)' ===> Replacing ELVMAX with ELVMAX-ORO <=== ' - write(0,*)' ===> if ELVMAX<=ORO replace with proxy <=== ' - write(0,*)' ===> the sum of mean orog (ORO) and std dev <=== ' - DO J = 1,JM - DO I = 1,numi(j) - if (ELVMAX(I,J) < ORO(I,J) ) then -!--- subtracting off ORO leaves std dev (this should never happen) - ELVMAX(I,J) = MAX( 3. * VAR(I,J),0.) - else - ELVMAX(I,J) = MAX( ELVMAX(I,J) - ORO(I,J),0.) - endif - ENDDO - ENDDO - maxc3 = 0 - maxc4 = 0 - maxc5 = 0 - maxc6 = 0 - maxc7 = 0 - maxc8 = 0 - DO J = 1,JM - DO I = 1,numi(j) - if (ELVMAX(I,J) > 3000.) maxc3 = maxc3 +1 - if (ELVMAX(I,J) > 4000.) maxc4 = maxc4 +1 - if (ELVMAX(I,J) > 5000.) maxc5 = maxc5 +1 - if (ELVMAX(I,J) > 6000.) maxc6 = maxc6 +1 - if (ELVMAX(I,J) > 7000.) maxc7 = maxc7 +1 - if (ELVMAX(I,J) > 8000.) maxc8 = maxc8 +1 - ENDDO - ENDDO - write(0,*)' after MAXC 3-6 km:',maxc3,maxc4,maxc5,maxc6 -! - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') -! if (JM .gt. 0) stop - - deallocate (ZAVG) - deallocate (ZSLM) - deallocate (UMD) - deallocate (GICE) - deallocate (work3,work4,work5,work6,iwork) -! -! ZERO OVER OCEAN -! - write(0,*)' Testing at point (itest,jtest)=',itest,jtest - write(0,*)' SLM(itest,jtest)=',slm(itest,jtest),itest,jtest - write(0,*)' ORO(itest,jtest)=',oro(itest,jtest) - - DO J = 1,JM - DO I = 1,numi(j) - IF(SLM(I,J) == 0.0) THEN -! VAR(I,J) = 0. - VAR4(I,J) = 0. - OA(I,J,1) = 0. - OA(I,J,2) = 0. - OA(I,J,3) = 0. - OA(I,J,4) = 0. - OL(I,J,1) = 0. - OL(I,J,2) = 0. - OL(I,J,3) = 0. - OL(I,J,4) = 0. -! THETA(I,J) = 0. -! GAMMA(I,J) = 0. -! SIGMA(I,J) = 0. -! ELVMAX(I,J) = 0. - ENDIF - ENDDO - ENDDO -! -! --- 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 ( mskocn == 1 ) then - - DO j = 1,jm - DO i = 1,numi(j) - if (abs (oro(i,j)) < 1. ) then - slm(i,j) = slmi(i,j) - else - if ( slmi(i,j) == 1. .and. slm(i,j) == 1) slm(i,j) = 1 - if ( slmi(i,j) == 0. .and. slm(i,j) == 0) slm(i,j) = 0 - if ( slmi(i,j) == 0. .and. slm(i,j) == 1) slm(i,j) = 0 - if ( slmi(i,j) == 0. .and. slm(i,j) == 0) slm(i,j) = 0 - endif - enddo - enddo - if (allocated(slmi)) deallocate(slmi) - endif - print *,' SLM(itest,jtest)=',slm(itest,jtest),itest,jtest - print *,' ORO(itest,jtest)=',oro(itest,jtest),itest,jtest -! -! REMOVE ISOLATED POINTS -! - DO J=2,JM-1 - JN = J - 1 - JS = J + 1 - RN = REAL(NUMI(JN)) / REAL(NUMI(J)) - RS = REAL(NUMI(JS)) / REAL(NUMI(J)) - DO I=1,NUMI(J) - 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: August 27, 2012 -! OLA(K) = OA(IW,J,K) + OA(IE,J,K) - OLA(K) = OL(IW,J,K) + OL(IE,J,K) - ENDDO - WGTA = 2 - XN = RN*(I-1) + 1 - IF (ABS(XN-NINT(XN)) < 1.E-2) THEN - IN = MOD(NINT(XN)-1,NUMI(JN)) + 1 - INW = MOD(IN+NUMI(JN)-2,NUMI(JN)) + 1 - INE = MOD(IN,NUMI(JN)) + 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,NUMI(JN)) + 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 = RS*(I-1)+1 - IF(ABS(XS-NINT(XS)) < 1.E-2) THEN - IS = MOD(NINT(XS)-1,NUMI(JS)) + 1 - ISW = MOD(IS+NUMI(JS)-2,NUMI(JS)) + 1 - ISE = MOD(IS,NUMI(JS)) + 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,NUMI(JS)) + 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) == 0..AND.SLMA == 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) == 1. .AND. SLMA == 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 -!--- print for testing after isolated points removed - write(0,*)' after isolated points removed' - - call minmxj(IM,JM,ORO,' ORO') - -! print *,' JM=',JM,' numi=',numi - write(0,*)' ORO(itest,jtest)=',oro(itest,jtest) - write(0,*)' VAR(itest,jtest)=',var(itest,jtest) - write(0,*)' VAR4(itest,jtest)=',var4(itest,jtest) - write(0,*)' OA(itest,jtest,1)=',oa(itest,jtest,1) - write(0,*)' OA(itest,jtest,2)=',oa(itest,jtest,2) - write(0,*)' OA(itest,jtest,3)=',oa(itest,jtest,3) - write(0,*)' OA(itest,jtest,4)=',oa(itest,jtest,4) - write(0,*)' OL(itest,jtest,1)=',ol(itest,jtest,1) - write(0,*)' OL(itest,jtest,2)=',ol(itest,jtest,2) - write(0,*)' OL(itest,jtest,3)=',ol(itest,jtest,3) - write(0,*)' OL(itest,jtest,4)=',ol(itest,jtest,4) - write(0,*)' Testing at point (itest,jtest)=',itest,jtest - write(0,*)' THETA(itest,jtest)=',theta(itest,jtest) - write(0,*)' GAMMA(itest,jtest)=',GAMMA(itest,jtest) - write(0,*)' SIGMA(itest,jtest)=',SIGMA(itest,jtest) - write(0,*)' ELVMAX(itest,jtest)=',ELVMAX(itest,jtest) - write(0,*)' EFAC=',EFAC -! - DO J=1,JM - DO I=1,numi(j) - ORO(I,J) = ORO(I,J) + EFAC*VAR(I,J) - HPRIME(I,J,1) = VAR(I,J) - HPRIME(I,J,2) = VAR4(I,J) - HPRIME(I,J,3) = oa(I,J,1) - HPRIME(I,J,4) = oa(I,J,2) - HPRIME(I,J,5) = oa(I,J,3) - HPRIME(I,J,6) = oa(I,J,4) - HPRIME(I,J,7) = ol(I,J,1) - HPRIME(I,J,8) = ol(I,J,2) - HPRIME(I,J,9) = ol(I,J,3) - HPRIME(I,J,10) = ol(I,J,4) - HPRIME(I,J,11) = THETA(I,J) - HPRIME(I,J,12) = GAMMA(I,J) - HPRIME(I,J,13) = SIGMA(I,J) - HPRIME(I,J,14) = ELVMAX(I,J) - ENDDO - ENDDO -! - deallocate (VAR, VAR4, OA, OL) -! - 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 NF0=jcap+1 -! - oro_s = oro -! - IF ( NF1 - NF0 == 0 ) FILTER = .FALSE. - write(0,*)' NF1, NF0, FILTER=',NF1,NF0,FILTER - - IF (FILTER) THEN ! SPECTRALLY TRUNCATE AND FILTER OROGRAPHY - do j=1,jm - if(numi(j) < im) then - ffj = cmplx(0.,0.) - call spfft1(numi(j),imb2p1,numi(j),1,ffj,oro(1,j),-1) - call spfft1(im, imb2p1,im, 1,ffj,oro(1,j),+1) - endif - enddo - -! write(0,*)' calling sptezj -1 nm=',nm,' nw=',nw,' im=',im -! &,' jm=',jm,' latch=',latch - - CALL SPTEZ(NR,NM,4,IM,JM,ORS,ORO,-1) - -! CALL SPTEZJ(NM,NW,1,4,IM,JM,1,ORS,ORO,latch,-1) -! - FFF = 1./(NF1-NF0)**2 - I = 0 - DO M=0,NM - DO N=M,NM+NR*M - IF(N > 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 -! -! write(0,*),' calling sptezj +1 nm=',nm,' nw=',nw,' im=',im -! &,' jm=',jm,' latch=',latch - - CALL SPTEZ(NR,NM,4,IM,JM,ORS,ORF,+1) -! CALL SPTEZJ(NM,NW,1,4,IM,JM,1,ORS,ORF,latch,+1) - - do j=1,jm - if(numi(j) < im) then - call spfft1(im, imb2p1,im, 1,ffj,orf(1,j),-1) - call spfft1(numi(j),imb2p1,numi(j),1,ffj,orf(1,j),+1) - endif - enddo - - ELSE - IF (REVLAT) THEN - CALL REVERS(IM, JM, numi, SLM, WORK1) - CALL REVERS(IM, JM, numi, ORO, WORK1) - DO IMT=1,NMT - CALL REVERS(IM, JM, numi, HPRIME(1,1,IMT), WORK1) - ENDDO - ENDIF - ORS = 0. - ORF = ORO - ENDIF - oro = oro_s - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') - - write(0,*)' ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) - write(0,*)' after spectral filter is applied' - - call minmxj(IM,JM,ORO,' ORO') - call minmxj(IM,JM,ORF,' ORF') -! -! USE NEAREST NEIGHBOR INTERPOLATION TO FILL FULL GRIDS -! - call rg2gg(im,jm,numi,slm) - call rg2gg(im,jm,numi,oro) - call rg2gg(im,jm,numi,oro_s) - call rg2gg(im,jm,numi,orf) -! --- not apply to new prin coord and ELVMAX (*j*) - do imt=1,nmt - call rg2gg(im,jm,numi,hprime(1,1,imt)) - enddo -! -! write(0,*),' 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') - write(0,*)' ORO,ORF(itest,jtest),itest,jtest:', - & ORO(itest,jtest),ORF(itest,jtest),itest,jtest - write(0,*)' ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) -! check antarctic pole - DO J = 1,JM - DO I = 1,numi(j) - if ( i <= min(numi(j),21) .and. i > 0 )then - if (j == 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 - -! OUTPUT BINARY FIELDS - - WRITE(51) REAL(SLM,4) - WRITE(52) REAL(ORF,4) - WRITE(53) REAL(HPRIME,4) - WRITE(54) REAL(ORS,4) - WRITE(55) REAL(ORO,4) - WRITE(66) REAL(THETA,4) - WRITE(67) REAL(GAMMA,4) - WRITE(68) REAL(SIGMA,4) - -! --- OCLSM is real(4) write only if ocean mask is present - if ( mskocn == 1 ) then - ios = 0 - WRITE(27,iostat=ios) OCLSM - print *,' write OCLSM input:',ios - print *,'LSM:',OCLSM(1,1),OCLSM(50,50),OCLSM(75,75),OCLSM(IM,JM) - endif - print *,' SLM:',SLM(1,1),SLM(50,50),SLM(75,75),SLM(IM,JM) -! - call minmxj(IM,JM,ORO,' ORO') - - write(0,*)' IM=',IM,' JM=',JM,' SPECTR=',SPECTR - -!--- Test binary file output: - WRITE(71) REAL(SLM,4) - DO IMT=1,NMT - WRITE(71) REAL(HPRIME(:,:,IMT),4) - print *,' HPRIME(',itest,jtest,imt,')=',HPRIME(itest,jtest,imt) - ENDDO - WRITE(71) REAL(ORO,4) - IF (SPECTR) THEN - WRITE(71) REAL(ORF,4) ! smoothed spectral orography! - ENDIF - -! OUTPUT GRIB FIELDS - - KPDS = 0 - KPDS(1) = 7 - KPDS(2) = 78 - KPDS(3) = 255 - KPDS(4) = 128 - KPDS(5) = 81 - KPDS(6) = 1 - kpds(8) = 2004 - KPDS(9) = 1 - KPDS(10) = 1 - KPDS(13) = 4 - KPDS(15) = 1 - KPDS(16) = 51 - KPDS(17) = 1 - KPDS(18) = 1 - KPDS(19) = 1 - KPDS(21) = 20 - KPDS(22) = 1 - - KGDS = 0 - KGDS(1) = 4 - KGDS(2) = IM - KGDS(3) = JM - KGDS(4) = 90000-180000/PI*RCLT(1) - KGDS(6) = 128 - KGDS(7) = 180000/PI*RCLT(1)-90000 - KGDS(8) = -NINT(360000./IM) - KGDS(9) = NINT(360000./IM) - KGDS(10) = JM/2 - KGDS(20) = 255 - -! --- SLM - CALL BAOPENwt(56,'fort.56',IRET) - if (iret /= 0) print *,' BAOPEN ERROR UNIT 56: IRET=',IRET - CALL PUTGB(56,IM*JM,KPDS,KGDS,LB,SLM,IRET) - print *,' SLM: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET - if (iret /= 0) print *,' SLM PUTGB ERROR: UNIT 56: IRET=',IRET - - write(0,*)' SLM: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET - -! --- OCLSM if present -! if ( mskocn .eq. 1 ) then -! CALL BAOPEN(27,'fort.27',IRET) -! if (iret .ne. 0) print *,' OCLSM BAOPEN ERROR UNIT 27:IRET=',IRET -! CALL PUTGB(27,IM*JM,KPDS,KGDS,LB,OCLSM,IRET) -! if (iret .ne. 0) print *,' OCLSM PUTGB ERROR: UNIT 27:IRET=',IRET -! print *,' OCLSM: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET -! endif - - KPDS(5) = 8 - IF (SPECTR) THEN - CALL BAOPENwt(57,'fort.57',IRET) - CALL PUTGB(57,IM*JM,KPDS,KGDS,LB,ORF,IRET) - write(0,*)' ORF (ORO): putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5) - & ,IRET - CALL BAOPENwt(72,'fort.72',IRET) - CALL PUTGB(72,IM*JM,KPDS,KGDS,LB,ORO_S,IRET) - write(0,*)' ORO_UF (ORO): putgb-KPDS(22,5),iret:',KPDS(22), - & KPDS(5) - & ,IRET -! else ! grib output for lat/lon grid KPD's need to be defined -! CALL BAOPENwt(57,'fort.57',IRET) -! CALL PUTGB(57,IM*JM,KPDS,KGDS,LB,ORO,IRET) -! print *,' ORO (ORO): putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5) -! & ,IRET - ENDIF -! -! === write out theta (angle of land to East) using #101 (wave dir) -! === [radians] and since < 1 scale adjust kpds(22) -! - KPDS(5) = 101 - CALL BAOPENwt(58,'fort.58',IRET) - CALL PUTGB(58,IM*JM,KPDS,KGDS,LB,THETA,IRET) - - write(0,*)' THETA: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET -! -! === write out (land aspect ratio or anisotropy) using #102 -! === (as in wind wave hgt) -! - KPDS(22) = 2 - KPDS(5) = 102 - CALL BAOPENwt(60,'fort.60',IRET) - CALL PUTGB(60,IM*JM,KPDS,KGDS,LB,SIGMA,IRET) - write(0,*)' SIGMA: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET -! -! === write out (slope parameter sigma) using #9 -! === (as in std hgt) -! - KPDS(22) = 1 - KPDS(5) = 103 - CALL BAOPENwt(59,'fort.59',IRET) - CALL PUTGB(59,IM*JM,KPDS,KGDS,LB,GAMMA,IRET) - - write(0,*)' GAMMA: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET -! - KPDS(22) = 1 - KPDS(5) = 9 - CALL BAOPENwt(61,'fort.61',IRET) - CALL PUTGB(61,IM*JM,KPDS,KGDS,LB,HPRIME,IRET) - - write(0,*)' HPRIME: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET -! -! - KPDS(22) = 1 - KPDS(5) = 8 - CALL BAOPENwt(62,'fort.62',IRET) - CALL PUTGB(62,IM*JM,KPDS,KGDS,LB,ELVMAX,IRET) - - write(0,*)' ELVMAX: putgb-KPDS(22,5),iret:',KPDS(22),KPDS(5),IRET -! - RETURN - END - SUBROUTINE MAKEMT(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, - & GLAT,IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) -! - implicit none -! - integer im, jm, imn, jmn - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - &, IST(IM,jm),IEN(IM,jm),JST(JM),JEN(JM),numi(jm) - real ORO(IM,JM),SLM(IM,JM),VAR(IM,JM),VAR4(IM,JM) - &, GLAT(JMN),XLAT(JM) -! - LOGICAL FLAG, DEBUG -!==== DATA DEBUG/.TRUE./ - DATA DEBUG/.FALSE./ -! - integer i, j, im1, jm1, ii1, i1, j1 - real delx, delxn, faclon, xnsum, xland, xwatr, xl1, xs1 - &, xw1, xw2, xw4, height, xxlat -! - print *,' _____ SUBROUTINE MAKEMT ' -!---- GLOBAL XLAT AND XLON ( DEGREE ) -! - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -! - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO -! -!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -! -! (*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 -! - IF (IST(I,j) <= 0) IST(I,j) = IST(I,j) + IMN - IF (IEN(I,j) < 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))*0.5 - IF(FLAG .AND. GLAT(J1) > XXLAT) THEN - JST(J) = J1 - JEN(J+1) = J1 - 1 - FLAG = .FALSE. - ENDIF - ENDDO -!X 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) -! -!...FIRST, AVERAGED HEIGHT -! - 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 <= 0) I1 = I1 + IMN - IF(I1 > 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)) - IF(HEIGHT < -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 * HEIGHT - -! check antarctic pole -! if ( i .le. 10 .and. i .ge. 1 )then -! if (j .ge. JM-1 )then -! write(6,153)i,j,ORO(i,j),HEIGHT,SLM(i,j) -!=== 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=',i3,')=',2E14.5,3f5.1) -! endif -! endif - - ENDDO - ENDDO - IF(XNSUM > 1.) THEN - SLM(I,J) = FLOAT(NINT(XLAND/XNSUM)) - IF(SLM(I,J) /= 0.) THEN - if (xland > 0.0) ORO(I,J)= XL1 / XLAND - ELSE - if (xwatr > 0.0) 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 <= 0.) I1 = I1 + IMN - IF(I1 > IMN) I1 = I1 - IMN - DO J1=JST(J),JEN(J) - HEIGHT = FLOAT(ZAVG(I1,J1)) - IF(HEIGHT < -990.) HEIGHT = 0.0 - XW4 = XW4 + (HEIGHT-ORO(I,J)) ** 4 - ENDDO - ENDDO - IF(VAR(I,J) > 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" -! - - RETURN - END - SUBROUTINE MAKEPC(ZAVG,ZSLM,THETA,GAMMA,SIGMA, - 1 GLAT,IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) -! -!=== PC: principal coordinates of each Z avg orog box for L&M -! - implicit none -! - real, parameter :: REARTH=6.3712E+6 - integer IM,JM,IMN,JMN - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - &, IST(IM,jm),IEN(IM,jm),JST(JM),JEN(JM),numi(jm) - real GLAT(JMN),XLAT(JM),DELTAX(JMN) - &, ORO(IM,JM),SLM(IM,JM),HL(IM,JM),HK(IM,JM) - real HX2(IM,JM),HY2(IM,JM),HXY(IM,JM),HLPRIM(IM,JM) - &, THETA(IM,JM),GAMMA(IM,JM),SIGMA2(IM,JM),SIGMA(IM,JM) - LOGICAL FLAG, DEBUG -!=== DATA DEBUG/.TRUE./ - DATA DEBUG/.FALSE./ -! - integer i, j, jm1, ii1, i0, i1, j1, ip1, ijax - real pi, certh, delxn, deltay, delx, faclon, xxlat - &, xnsum, xland, xwatr, xl1, xs1, xfp, yfp, xfpyfp, xfp2 - &, yfp2, height, hi0, hi1, hip1, hijax, hi1j1, hj0, hjp1 -! - PI = 4.0 * ATAN(1.0) - CERTH = PI * REARTH -!---- GLOBAL XLAT AND XLON ( DEGREE ) -! - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION - DELTAY = CERTH / FLOAT(JMN) - print *, 'MAKEPC: DELTAY=',DELTAY -! - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - DELTAX(J) = DELTAY * COSD(GLAT(J)) - ENDDO -! -!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -! - 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 - IST(I,j) = IST(I,j) + 1 - IEN(I,j) = FACLON * FLOAT(I) - FACLON * 0.5 - -! if (debug) then -! if ( I < 10 .and. J < 10 ) -! 1 PRINT*, ' I j IST IEN ',I,j,IST(I,j),IEN(I,j) -! endif -! IST(I,j) = FACLON * FLOAT(I-1) + 1.0001 -! IEN(I,j) = FACLON * FLOAT(I) + 0.0001 - - IF (IST(I,j) <= 0) IST(I,j) = IST(I,j) + IMN - IF (IEN(I,j) < IST(I,j)) IEN(I,j) = IEN(I,j) + IMN - if (debug) then - if ( I < 10 .and. J < 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))*0.5 - IF(FLAG .AND. GLAT(J1) > 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 -! -!... DERIVITIVE TENSOR OF HEIGHT -! - 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. -! - 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 -! -!=== set the rest of the indexs for ave: 2pt staggered derivitive -! - i0 = i1 - 1 - if (i1 - 1 <= 0 ) i0 = i0 + imn - if (i1 - 1 > imn) i0 = i0 - imn - - ip1 = i1 + 1 - if (i1 + 1 <= 0 ) ip1 = ip1 + imn - if (i1 + 1 > imn) ip1 = ip1 - imn -! - DO J1=JST(J),JEN(J) - if (debug) then - if ( I1 == IST(I,J) .and. J1 == 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. -! - HEIGHT = FLOAT(ZAVG(I1,J1)) - hi0 = float(zavg(i0,j1)) - hip1 = float(zavg(ip1,j1)) -! - IF(HEIGHT < -990.) HEIGHT = 0.0 - if(hi0 < -990.) hi0 = 0.0 - if(hip1 < -990.) hip1 = 0.0 -!........ xfp = xfp + 0.5 * ( hip1 - hi0 ) / DELTAX(J1) - xfp = 0.5 * ( hip1 - hi0 ) / DELTAX(J1) - xfp2 = xfp2 + 0.25 * ( ( hip1 - hi0 )/DELTAX(J1) )** 2 -! -! --- not at boundaries - if ( J1 /= JST(1) .and. J1 /= JEN(JM) ) then - hj0 = float(zavg(i1,j1-1)) - hjp1 = float(zavg(i1,j1+1)) - if(hj0 < -990.) hj0 = 0.0 - if(hjp1 < -990.) hjp1 = 0.0 -!....... yfp = yfp + 0.5 * ( hjp1 - hj0 ) / DELTAY - yfp = 0.5 * ( hjp1 - hj0 ) / DELTAY - yfp2 = yfp2 + 0.25 * ( ( hjp1 - hj0 )/DELTAY )**2 - -!.............. elseif ( J1 == JST(J) .or. J1 == JEN(JM) ) then -! === the NH pole: NB J1 goes from High at NP to Low toward SP -! - elseif ( J1 == JST(1) ) then - ijax = i1 + imn/2 - if (ijax <= 0 ) ijax = ijax + imn - if (ijax > imn) ijax = ijax - imn -!..... 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 < -990.) hijax = 0.0 - if(hi1j1 < -990.) hi1j1 = 0.0 -!....... 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 -! -! === the SH pole: NB J1 goes from High at NP to Low toward SP -! - elseif ( J1 == JEN(JM) ) then - ijax = i1 + imn/2 - if (ijax <= 0 ) ijax = ijax + imn - if (ijax > imn) ijax = ijax - imn - hijax = float(zavg(ijax,j1)) - hi1j1 = float(zavg(i1,j1)) - if(hijax < -990.) hijax = 0.0 - if(hi1j1 < -990.) hi1j1 = 0.0 - if ( i1 < 5 ) - & print *,' S.Pole i1,j1 :',i1,j1,hijax,hi1j1 -!..... 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 -! -! === The above does an average across the pole for the bndry in j. -!23456789012345678901234567890123456789012345678901234567890123456789012...... -! - xfpyfp = xfpyfp + xfp * yfp - XL1 = XL1 + HEIGHT * FLOAT(ZSLM(I1,J1)) - XS1 = XS1 + HEIGHT * FLOAT(1-ZSLM(I1,J1)) -! -! === average the HX2, HY2 and HXY -! === This will be done over all land -! - ENDDO - ENDDO -! -! === HTENSR -! - IF(XNSUM > 1.) THEN - SLM(I,J) = FLOAT(NINT(XLAND/XNSUM)) - IF(SLM(I,J) /= 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 -!=== 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 -! -! === 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) /= 0. .AND. SLM(I,J) /= 0. ) THEN - THETA(I,J) = 0.5 * ATAN2D(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) >= 0.) then - SIGMA(I,J) = SQRT(SIGMA2(I,J) ) - if (sigma2(i,j) /= 0. .and. HK(I,J) >= 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" -! - RETURN - END - - 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) -! - implicit none -! - integer IM,JM,IMN,JMN - &, IST(IM,jm),IEN(IM,jm),JST(JM),JEN(JM),numi(jm) - &, ioa4(im,jm,4), ZAVG(IMN,JMN) - real GLAT(JMN),XLAT(JM) - &, ORO(IM,JM),ORO1(IM,JM),ELVMAX(IM,JM),ZMAX(IM,JM) - &, OA4(IM,JM,4) - real XNSUM(IM,JM),XNSUM1(IM,JM),XNSUM2(IM,JM) - &, XNSUM3(IM,JM),XNSUM4(IM,JM) - real VAR(IM,JM),OL(IM,JM,4) - LOGICAL FLAG -! - integer i, j, im1, jm1, i1, ii1, j1, kwd, ii, inci, isttt, jsttt - &, ns0, ns1, ns2, ns3, ns4, ns5, ns6, ieddd, jeddd, incj - real delx, delxn, faclon, xxlat, height, xnpu, xnpd, hc, t - &, tem -! -!---- GLOBAL XLAT AND XLON ( DEGREE ) -! -! --- IM1 = IM - 1 removed (not used in this sub) - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -! - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO - - write(0,*)'MAKEOA: IM=',IM,' JM=',JM,' IMN=',IMN,' JMN=',JMN -! -!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -! - DO j=1,jm - DO I=1,numi(j) - DELX = 360./numi(j) ! GAUSSIAN GRID RESOLUTION - FACLON = DELX / DELXN -! --- 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) <= 0) IST(I,j) = IST(I,j) + IMN - IF (IEN(I,j) < IST(I,j)) IEN(I,j) = IEN(I,j) + IMN -!x PRINT*, ' I j IST IEN ',I,j,IST(I,j),IEN(I,j) - if ( I .lt. 3 .and. J .lt. 3 ) - 1 PRINT*,' MAKEOA: I j IST IEN ',I,j,IST(I,j),IEN(I,j) - if ( I .lt. 3 .and. J .ge. JM-1 ) - 1 PRINT*,' MAKEOA: I j IST IEN ',I,j,IST(I,j),IEN(I,j) - ENDDO - ENDDO - write(0,*)'MAKEOA: DELXN,DELX,FACLON',DELXN,DELX,FACLON - write(0,*)' ***** 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) > XXLAT) THEN - JST(J) = J1 -! --- JEN(J+1) = J1 - 1 - FLAG = .FALSE. - if ( J == 1 ) PRINT*,' MAKEOA: XX j JST JEN ',j,JST(j),JEN(j) - ENDIF - ENDDO - if ( J < 3 ) PRINT*,' MAKEOA: j JST JEN ',j,JST(j),JEN(j) - if ( J >= JM-2 ) PRINT*,' MAKEOA: j JST JEN ',j,JST(j),JEN(j) -! FLAG=.TRUE. -! DO J1=JST(J),JMN -! IF(FLAG.AND.GLAT(J1).GT.XLAT(J)) THEN -! JEN(J) = 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) - write(0,*)' ***** JST(1) JEN(1) ',JST(1),JEN(1) - write(0,*)' ***** JST(JM) JEN(JM) ',JST(JM),JEN(JM) -! - 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 -! write(0,*)' J=',j,' in xnsum loop' - 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 <= 0.) I1 = I1 + IMN - IF (I1 > IMN) I1 = I1 - IMN - DO J1=JST(J),JEN(J) - HEIGHT = FLOAT(ZAVG(I1,J1)) - IF(HEIGHT < -990.) HEIGHT = 0.0 - IF ( HEIGHT > ORO(I,J) ) then - if ( HEIGHT > ZMAX(I,J) ) ZMAX(I,J) = HEIGHT - XNSUM(I,J) = XNSUM(I,J) + 1 - ENDIF - ENDDO - ENDDO - if ( I < 5 .and. J >= JM-5 ) then - write(0,*) ' 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 -! -!.... make ELVMAX ORO from MAKEMT sub -! -! --- 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 -!........ -! The MAX elev peak (no averaging) -!........ -! 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 -! - 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) -! - 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 -! - 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 -!x print*,' i j hc var ',i,j,hc,var(i,j) -!x print*,'xnsum12 ',xnsum1(i,j),xnsum2(i,j) -!x print*,'xnsum34 ',xnsum3(i,j),xnsum4(i,j) - ENDDO - ENDDO - write(0,*)' IN MAKEOA After XNSUM4' -! -!---- 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) -! -! - DO KWD = 1, 4 - DO J=1,JM - DO I=1,numi(j) - OA4(I,J,KWD) = 0.0 - ENDDO - 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(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.) - tem = XNSUM4(I,J+1) + XNSUM4(II,J+1) - if (tem > 0.0) then - OL(II,J+1,1) = (XNSUM3(I,J+1) + XNSUM3(II,J+1)) / tem - endif - if ( I .lt. 20 .and. J .ge. JM-19 ) then - write(0,*)' 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 - write(0,*)' MAKEOA: after OL loop1' - 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 - write(0,*)' MAKEOA: after OL loop2' - 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 - write(0,*)' MAKEOA: after OL loop3' - 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 - write(0,*)' MAKEOA: after OL loop4' -! - 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 -! - write(0,*)' IN MAKEOA Bef OA4' - 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 -! - 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 -! - WRITE(6,*) "! MAKEOA EXIT" -! - RETURN - END - SUBROUTINE REVERS(IM, JM, numi, F, WRK) -! - implicit none -! - integer im, jm - REAL F(IM,JM), WRK(IM,JM) - integer numi(jm), i, j, ir, jr, imb2 - real tem -! -! reverse east-west and north-south -!...... fix this routine up to take numi (*j*) -!..... at least have 5 variables ....and keep REVLAT .FALSE. - - imb2 = im / 2 - do j=1,jm - do i=1,im - WRK(i,j) = F(i,j) - enddo - enddo - do j=1,jm - jr = jm - j + 1 - do i=1,im - ir = i + imb2 - if (ir > im) ir = ir - im - f(ir,jr) = WRK(i,j) - enddo - enddo -! - tem = 0.0 - do i=1,im - tem= tem + F(I,1) - enddo - tem = tem / im - do i=1,im - F(I,1) = tem - enddo -! - RETURN - END - - subroutine rg2gg(im,jm,numi,a) -! - implicit none -! - integer,intent(in):: im,jm,numi(jm) - real,intent(inout):: a(im,jm) - integer j,ir,ig - real r,t(im) - do j=1,jm - r = real(numi(j))/real(im) - do ig=1,im - ir = mod(nint((ig-1)*r),numi(j)) + 1 - t(ig) = a(ir,j) - enddo - do ig=1,im - a(ig,j) = t(ig) - enddo - enddo - end subroutine - subroutine gg2rg(im,jm,numi,a) -! - implicit none -! - integer,intent(in):: im,jm,numi(jm) - real,intent(inout):: a(im,jm) - integer j,ir,ig - real r,t(im) - do j=1,jm - r = real(numi(j))/real(im) - do ir=1,numi(j) - ig = nint((ir-1)/r) + 1 - t(ir) = a(ig,j) - enddo - do ir=1,numi(j) - a(ir,j) = t(ir) - enddo - enddo - end subroutine - SUBROUTINE minmxj(IM,JM,A,title) - -! this routine is using real*4 on the sp - - implicit none - - integer im, jm - real A(IM,JM),rmin,rmax - integer i,j - character*8 title - - rmin = 1.e+10 - rmax = -rmin -!sela.................................................... -!sela if(rmin.eq.1.e+10)return -!sela.................................................... - DO j=1,JM - DO i=1,IM - if (A(i,j) >= rmax) rmax = A(i,j) - if (A(i,j) <= rmin) rmin = A(i,j) - ENDDO - ENDDO - write(0,150)rmin,rmax,title -150 format('rmin=',e13.4,2x,'rmax=',e13.4,2x,a8,' ') -! - RETURN - END - SUBROUTINE mnmxja(IM,JM,A,imax,jmax,title) - -! this routine is using real*4 on the sp - - implicit none - - integer im, jm - real A(IM,JM),rmin,rmax - integer i,j,imax,jmax - character*8 title - - rmin = 1.e+10 - rmax = -rmin -!sela.................................................... -!sela if(rmin.eq.1.e+10)return -!sela.................................................... - DO j=1,JM - DO i=1,IM - if (A(i,j) >= rmax) then - rmax = A(i,j) - imax = i - jmax = j - endif - if (A(i,j) <= rmin) rmin = A(i,j) - ENDDO - ENDDO - write(6,150)rmin,rmax,title -150 format('rmin=',e13.4,2x,'rmax=',e13.4,2x,a8,' ') -! - RETURN - END - -!----------------------------------------------------------------------- - SUBROUTINE SPFFT1(IMAX,INCW,INCG,KMAX,W,G,IDIR) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: SPFFT1 PERFORM MULTIPLE FAST FOURIER TRANSFORMS -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -! -! ABSTRACT: THIS SUBPROGRAM PERFORMS MULTIPLE FAST FOURIER TRANSFORMS -! BETWEEN COMPLEX AMPLITUDES IN FOURIER SPACE AND REAL VALUES -! IN CYCLIC PHYSICAL SPACE. -! SUBPROGRAM SPFFT1 INITIALIZES TRIGONOMETRIC DATA EACH CALL. -! USE SUBPROGRAM SPFFT TO SAVE TIME AND INITIALIZE ONCE. -! THIS VERSION INVOKES THE IBM ESSL FFT. -! -! PROGRAM HISTORY LOG: -! 1998-12-18 IREDELL -! -! USAGE: CALL SPFFT1(IMAX,INCW,INCG,KMAX,W,G,IDIR) -! -! INPUT ARGUMENT LIST: -! IMAX - INTEGER NUMBER OF VALUES IN THE CYCLIC PHYSICAL SPACE -! (SEE LIMITATIONS ON IMAX IN REMARKS BELOW.) -! INCW - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY -! (INCW >= IMAX/2+1) -! INCG - INTEGER FIRST DIMENSION OF THE REAL VALUE ARRAY -! (INCG >= IMAX) -! KMAX - INTEGER NUMBER OF TRANSFORMS TO PERFORM -! W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR>0 -! G - REAL(INCG,KMAX) REAL VALUES IF IDIR<0 -! IDIR - INTEGER DIRECTION FLAG -! IDIR>0 TO TRANSFORM FROM FOURIER TO PHYSICAL SPACE -! IDIR<0 TO TRANSFORM FROM PHYSICAL TO FOURIER SPACE -! -! OUTPUT ARGUMENT LIST: -! W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR<0 -! G - REAL(INCG,KMAX) REAL VALUES IF IDIR>0 -! -! SUBPROGRAMS CALLED: -! SCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -! DCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -! SRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -! DRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -! REMARKS: -! THE RESTRICTIONS ON IMAX ARE THAT IT MUST BE A MULTIPLE -! OF 1 TO 25 FACTORS OF TWO, UP TO 2 FACTORS OF THREE, -! AND UP TO 1 FACTOR OF FIVE, SEVEN AND ELEVEN. -! -! THIS SUBPROGRAM IS THREAD-SAFE. -! -!$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR - COMPLEX,INTENT(INOUT):: W(INCW,KMAX) - REAL,INTENT(INOUT):: G(INCG,KMAX) - REAL:: AUX1(25000+INT(0.82*IMAX)) - REAL:: AUX2(20000+INT(0.57*IMAX)) - INTEGER:: NAUX1,NAUX2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NAUX1=25000+INT(0.82*IMAX) - NAUX2=20000+INT(0.57*IMAX) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! FOURIER TO PHYSICAL TRANSFORM. - SELECT CASE(IDIR) - CASE(1:) - SELECT CASE(DIGITS(1.)) - CASE(DIGITS(1._4)) - CALL SCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL SCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CASE(DIGITS(1._8)) - CALL DCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL DCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - END SELECT -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! PHYSICAL TO FOURIER TRANSFORM. - CASE(:-1) - SELECT CASE(DIGITS(1.)) - CASE(DIGITS(1._4)) - CALL SRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL SRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CASE(DIGITS(1._8)) - CALL DRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL DRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - END SELECT - END SELECT - END SUBROUTINE - subroutine read_g(glob,ITOPO) -! -! --- if ITOPO = 1 then read gtopo30_gg.fine 43200X21600 30" file -! --- if ITOPO = 2 then read topo 30" .DEM tile files -! --- in either case, glob will be n Interger*2 array. -! --- This routine write out a grads ctl file for displaying the -! --- tiles in the output working dir. The glob array can not be -! --- acted on with grads, but the tiles can be if lat/lon are reduced slightly -!! - implicit none -!! - integer*2 glob(360*120,180*120) -!! - integer, parameter :: ix=40*120, jx=50*120 - &, ia=60*120, ja=30*120 -!! - integer*2 idat(ix,jx),itopo -!! -!!mr integer*2 m9999 -!!mr data m9999 / -9999 / -!! -!!mr integer i_count(360*120) -!!mr integer j_max_y(360*120) -!! - integer i,j,inttyp -!! - real(kind=8) dloin,dlain,rlon,rlat -!! - read(235) glob - rewind(235) -!! -!! - print*,' ' - call maxmin (glob,360*120*180*120,'global0') -!! -!! - dloin = 1.d0/120.d0 - dlain = 1.d0/120.d0 -!! - rlon = -179.995833333333333333333333d0 - rlat = 89.995833333333333333333333d0 -!! - inttyp =-1 ! average rectangular subset -!!mr inttyp = 1 ! take closest grid point value -!!mr inttyp = 0 ! interpolate from four closest grid point values -!! -! call la2ga_gtopo30(glob,360*120,180*120, -! & dloin,dlain,rlon,rlat,inttyp, -! & .true.,glob, -! & 0,lonf,latg) -!! - return - end - subroutine maxmin(ia,len,tile) -!!mr - implicit none -!!mr - integer len - integer*2 ia(len) - character*7 tile - integer iaamax, iaamin, j, m, ja, kount - integer(8) sum2,std,mean,isum - integer i_count_notset,kount_9 - -! --- missing is -9999 -! - isum = 0 - sum2 = 0 - kount = 0 - kount_9 = 0 - iaamax = -9999999 -!!mr iaamin = 1 - iaamin = 9999999 - i_count_notset = 0 - - do m=1,len - ja=ia(m) -!!mr if ( ja .lt. 0 ) print *,' ja < 0:',ja -!!mr if ( ja .eq. -9999 ) goto 10 - if ( ja .eq. -9999 ) then - kount_9 = kount_9 + 1 - cycle - endif - if ( ja == -12345 ) i_count_notset = i_count_notset + 1 -!!mr 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 -!!mr sum2 = sum2 + ifix( float(ja) * float(ja) ) - sum2 = sum2 + ja*ja - enddo -! - 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 minmaxj(IM,JM,A,title) - -! this routine is using real*4 on the sp - - implicit none - - integer im, jm - real(kind=4) A(IM,JM),rmin,rmax,undef - integer i,j,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. -!sela.................................................... -!sela if(rmin.eq.1.e+10)return -!sela.................................................... - DO j=1,JM - DO i=1,IM - if (A(i,j) >= rmax)then - rmax = A(i,j) - imax = i - jmax = j - endif - if (A(i,j) <= 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) -! - RETURN - END - subroutine nanc(a,l,c) -! compiler opt TRAPS= -qinitauto=FF911299 -qflttrap=ov:zero:inv:en -qsig trap -! or call subroutine below -! subroutine to report NaNS and NaNQ within an address -! range for real*8 words. -! as written the routine prints a single line for each call -! and prints a message and returns to the caller on detection of the FIRST -! NaN in the range. The message is passed in the third -! argument. If no NaN values are found it returns silently. -! A real*4 version can be created by making A real*4 - -! arguments (all are input only) -! -! A real*8 variable or array -! L number of words to scan (length of array) -! C distinctive message set in caller to indicate where -! the routine was called. -! - integer inan1,inan2,inan3,inan4,inaq1,inaq2,inaq3,inaq4 - real word - integer itest - equivalence (itest,word) -! -! signaling NaN - data inan1/x'7F800001'/ - data inan2/x'7FBFFFFF'/ - data inan3/x'FF800001'/ - data inan4/x'FFBFFFFF'/ -! -! quiet NaN -! - data inaq1/x'7FC00000'/ - data inaq2/x'7FFFFFFF'/ - data inaq3/x'FFC00000'/ - data inaq4/x'FFFFFFFF'/ -! - real(kind=8)a(l),rtc,t1,t2 - character*24 cn - character*(*) c - t1=rtc() -!gwv print *, ' nanc call ',c - do k=1,l - word = a(k) - if( (itest .GE. inan1 .AND. itest .LE. inan2) .OR. - * (itest .GE. inan3 .AND. itest .LE. inan4) ) then - print *,' NaNs detected at word',k,' ',c - return - endif - if( (itest .GE. inaq1 .AND. itest .LE. inaq2) .OR. - * (itest .GE. inaq3 .AND. itest .LE. inaq4) ) then - print *,' NaNq detected at word',k,' ',c - return - endif - - 101 format(e20.10) - end do - t2=rtc() -!gwv print 102,l,t2-t1,c - 102 format(' time to check ',i9,' words is ',f10.4,' ',a24) - return - end -C----------------------------------------------------------------------- - - SUBROUTINE SPTEZJ(JCAP,NC,KM,IDRT,LONB,LATB,JC,WAVE,GRID - &, latch,idir) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: SPTEZJ TRANSFORM A SINGLE SPECTRAL FIELD TO GRID -! PRGMMR: MOORTHI ORG: W/NMC23 DATE: 13-02-20 -! -! ABSTRACT: TRANSFORMS A SINGLE SPECTRAL FIELDS TO GRID -! -! PROGRAM HISTORY LOG: -! 13-02-20 S. MOORTHI -! -! USAGE: CALL SPTEZJ(JCAP,NC,KM,IDRT,LONB,LATB,JC,WAVE,GRID,IDIR) -! INPUT ARGUMENT LIST: -! JCAP INTEGER SPECTRAL TRUNCATION -! NC INTEGER FIRST DIMENSION (NC>=(JCAP+1)*(JCAP+2)) -! KM INTEGER NUMBER OF LEVELS -! IDRT INTEGER DATA REPRESENTATION TYPE -! (IDRT=4 FOR GAUSSIAN GRID, -! IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -! IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -! LONB INTEGER NUMBER OF LONGITUDES -! LATB INTEGER NUMBER OF LATITUDES -! JC INTEGER NUMBER OF CPUS -! WAVE REAL (NC) WAVE FIELD if IDIR>0 -! OUTPUT ARGUMENT LIST: -! GRID REAL (cwLONB,LATB,I,KM) GRID FIELD (E->W, N->S) IF IDIR<0 -! -! IDIR - INTEGER TRANSFORM FLAG -! (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -! LATCH - Latitude chunk used in the transform loop -! SUBPROGRAMS CALLED: -! SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!$$$ - implicit none -! - integer jcap, nc, km, idrt, lonb, latb, jc, latch, idir - REAL wave(NC,KM) - REAL GRID(LONB,LATB,KM) -! - real, allocatable :: gridl(:,:) -! - integer lonb2m, i, j, in, is, latbb2, lonb2, j1, j2, jl, ijl, ijn - &, ij, js, jn, ja, jb -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! SPECTRAL TRANSFORMS -! - LATBB2 = (LATB+1)/2 - LONB2 = LONB + LONB - ijn = LONB2 * LATCH - allocate (gridl(ijn,km)) - IN = 1 - IS = 1 + LONB -! -! write(0,*)' lonb=',lonb,' lonb2=',lonb2,' latbb2=',latbb2 -! &, ' latch=',latch,' ijn=',ijn,' idir=',idir,' km=',km -! - if (idir < 0) wave = 0.0 -! - DO J1=1,LATBB2,LATCH - J2 = MIN(J1+LATCH-1,LATBB2) - -! JL = 2*(J2-J1+1) -! IJL = LONB*JL -! IJ = LONB2 * (J2-J1+1) - - if (idir > 0) then -! write(0,*)' waveb=',wave(1:5,1) - CALL SPTRAN(0,JCAP,IDRT,LONB,LATB,KM,1,1,LONB2,LONB2,NC,IJN - &, J1,J2,JC,WAVE,GRIDL(IN,1),GRIDL(IS,1),1) - do j=j1,j2 - jn = j - js = latb+1-j - ja = (J-J1)*lonb2 - jb = ja + lonb - do i=1,lonb - grid(i,jn,:) = gridl(I+ja,:) - grid(i,js,:) = gridl(I+jb,:) - enddo - enddo -! write(0,*)' grida=',grid(lonb/2,jn,:) - else -! write(0,*)' SPTEZJ: j1=',j1,' j2=',j2 - do j=j1,j2 - jn = j - js = latb+1-j - ja = (J-J1)*lonb2 - jb = ja + lonb - do i=1,lonb - gridl(I+ja,:) = grid(i,jn,:) - gridl(I+jb,:) = grid(i,js,:) - enddo - enddo -! write(0,*)' BEF SPTRAN gridlN=',gridl(ja+1:ja+lonb,1),' j=',j -! write(0,*)' BEF SPTRAN gridlS=',gridl(jb+1:jb+lonb,1),' j=',j - CALL SPTRAN(0,JCAP,IDRT,LONB,LATB,KM,1,1,LONB2,LONB2,NC,IJN - &, J1,J2,JC,WAVE,GRIDL(IN,1),GRIDL(IS,1),-1) -! write(0,*)' wave=',wave(1:10,1) - endif -! - ENDDO ! j - loop - deallocate (gridl) -! - END -C----------------------------------------------------------------------- - SUBROUTINE SPLAT0(IDRT,JMAX,SLAT,WLAT) -C SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLAT COMPUTE LATITUDE FUNCTIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: COMPUTES COSINES OF COLATITUDE AND GAUSSIAN WEIGHTS -C FOR ONE OF THE FOLLOWING SPECIFIC GLOBAL SETS OF LATITUDES. -C GAUSSIAN LATITUDES (IDRT=4) -C EQUALLY-SPACED LATITUDES INCLUDING POLES (IDRT=0) -C EQUALLY-SPACED LATITUDES EXCLUDING POLES (IDRT=256) -C THE GAUSSIAN LATITUDES ARE LOCATED AT THE ZEROES OF THE -C LEGENDRE POLYNOMIAL OF THE GIVEN ORDER. THESE LATITUDES -C ARE EFFICIENT FOR REVERSIBLE TRANSFORMS FROM SPECTRAL SPACE. -C (ABOUT TWICE AS MANY EQUALLY-SPACED LATITUDES ARE NEEDED.) -C THE WEIGHTS FOR THE EQUALLY-SPACED LATITUDES ARE BASED ON -C ELLSAESSER (JAM,1966). (NO WEIGHT IS GIVEN THE POLE POINT.) -C NOTE THAT WHEN ANALYZING GRID TO SPECTRAL IN LATITUDE PAIRS, -C IF AN EQUATOR POINT EXISTS, ITS WEIGHT SHOULD BE HALVED. -C THIS VERSION INVOKES THE IBM ESSL MATRIX SOLVER. -C -C PROGRAM HISTORY LOG: -C 96-02-20 IREDELL -C 97-10-20 IREDELL ADJUST PRECISION -C 98-06-11 IREDELL GENERALIZE PRECISION USING FORTRAN 90 INTRINSIC -C 1998-12-03 IREDELL GENERALIZE PRECISION FURTHER -C 1998-12-03 IREDELL USES AIX ESSL BLAS CALLS -C 2009-12-27 DSTARK updated to switch between ESSL calls on an AIX -C platform, and Numerical Recipies calls elsewise. -C 2010-12-30 SLOVACEK update alignment so preprocessor does not cause -C compilation failure -C 2012-09-01 E.Mirvis & M.Iredell merging & debugging linux errors -C of _d and _8 using generic LU factorization. -C 2012-11-05 E.Mirvis generic FFTPACK and LU lapack were removed -C---------------------------------------------------------------- -C USAGE: CALL SPLAT(IDRT,JMAX,SLAT,WLAT) -C -C INPUT ARGUMENT LIST: -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C JMAX - INTEGER NUMBER OF LATITUDES. -C -C OUTPUT ARGUMENT LIST: -C SLAT - REAL (JMAX) SINES OF LATITUDE. -C WLAT - REAL (JMAX) GAUSSIAN WEIGHTS. -C -C SUBPROGRAMS CALLED: -C DGEF MATRIX FACTORIZATION - ESSL -C DGES MATRIX SOLVER - ESSL -C LUDCMP LU factorization - numerical recipies -C LUBKSB Matrix solver - numerical recipies -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C - REAL SLAT(JMAX),WLAT(JMAX) - INTEGER,PARAMETER:: KD=SELECTED_REAL_KIND(15,45) - REAL(KIND=KD):: PK(JMAX/2),PKM1(JMAX/2),PKM2(JMAX/2) - REAL(KIND=KD):: SLATD(JMAX/2),SP,SPMAX,EPS=10.*EPSILON(SP) - PARAMETER(JZ=50) - REAL BZ(JZ) - DATA BZ / 2.4048255577, 5.5200781103, - $ 8.6537279129, 11.7915344391, 14.9309177086, 18.0710639679, - $ 21.2116366299, 24.3524715308, 27.4934791320, 30.6346064684, - $ 33.7758202136, 36.9170983537, 40.0584257646, 43.1997917132, - $ 46.3411883717, 49.4826098974, 52.6240518411, 55.7655107550, - $ 58.9069839261, 62.0484691902, 65.1899648002, 68.3314693299, - $ 71.4729816036, 74.6145006437, 77.7560256304, 80.8975558711, - $ 84.0390907769, 87.1806298436, 90.3221726372, 93.4637187819, - $ 96.6052679510, 99.7468198587, 102.888374254, 106.029930916, - $ 109.171489649, 112.313050280, 115.454612653, 118.596176630, - $ 121.737742088, 124.879308913, 128.020877005, 131.162446275, - $ 134.304016638, 137.445588020, 140.587160352, 143.728733573, - $ 146.870307625, 150.011882457, 153.153458019, 156.295034268 / - REAL:: DLT,D1=1. - REAL AWORK((JMAX+1)/2,((JMAX+1)/2)),BWORK(((JMAX+1)/2)) - INTEGER:: JHE,JHO,J0=0 - INTEGER IPVT((JMAX+1)/2) - PARAMETER(PI=3.14159265358979,C=(1.-(2./PI)**2)*0.25) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GAUSSIAN LATITUDES - IF(IDRT.EQ.4) THEN - JH=JMAX/2 - JHE=(JMAX+1)/2 - R=1./SQRT((JMAX+0.5)**2+C) - DO J=1,MIN(JH,JZ) - SLATD(J)=COS(BZ(J)*R) - ENDDO - DO J=JZ+1,JH - SLATD(J)=COS((BZ(JZ)+(J-JZ)*PI)*R) - ENDDO - SPMAX=1. - DO WHILE(SPMAX.GT.EPS) - SPMAX=0. - DO J=1,JH - PKM1(J)=1. - PK(J)=SLATD(J) - ENDDO - DO N=2,JMAX - DO J=1,JH - PKM2(J)=PKM1(J) - PKM1(J)=PK(J) - PK(J)=((2*N-1)*SLATD(J)*PKM1(J)-(N-1)*PKM2(J))/N - ENDDO - ENDDO - DO J=1,JH - SP=PK(J)*(1.-SLATD(J)**2)/(JMAX*(PKM1(J)-SLATD(J)*PK(J))) - SLATD(J)=SLATD(J)-SP - SPMAX=MAX(SPMAX,ABS(SP)) - ENDDO - ENDDO -CDIR$ IVDEP - DO J=1,JH - SLAT(J)=SLATD(J) - WLAT(J)=(2.*(1.-SLATD(J)**2))/(JMAX*PKM1(J))**2 - SLAT(JMAX+1-J)=-SLAT(J) - WLAT(JMAX+1-J)=WLAT(J) - ENDDO - IF(JHE.GT.JH) THEN - SLAT(JHE)=0. - WLAT(JHE)=2./JMAX**2 - DO N=2,JMAX,2 - WLAT(JHE)=WLAT(JHE)*N**2/(N-1)**2 - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C EQUALLY-SPACED LATITUDES INCLUDING POLES - ELSEIF(IDRT.EQ.0) THEN - JH=JMAX/2 - JHE=(JMAX+1)/2 - JHO=JHE-1 - DLT=PI/(JMAX-1) - SLAT(1)=1. - DO J=2,JH - SLAT(J)=COS((J-1)*DLT) - ENDDO - DO JS=1,JHO - DO J=1,JHO - AWORK(JS,J)=COS(2*(JS-1)*J*DLT) - ENDDO - ENDDO - DO JS=1,JHO - BWORK(JS)=-D1/(4*(JS-1)**2-1) - ENDDO -!#if IBM4 || IBM8 -! CALL DGEF(AWORK,JHE,JHO,IPVT) -! CALL DGES(AWORK,JHE,JHO,IPVT,BWORK,J0) -!#endif -!#if LINUX - call ludcmp(awork,jho,jhe,ipvt) - call lubksb(awork,jho,jhe,ipvt,bwork) -!#endif - WLAT(1)=0. - DO J=1,JHO - WLAT(J+1)=BWORK(J) - ENDDO -CDIR$ IVDEP - DO J=1,JH - SLAT(JMAX+1-J)=-SLAT(J) - WLAT(JMAX+1-J)=WLAT(J) - ENDDO - IF(JHE.GT.JH) THEN - SLAT(JHE)=0. - WLAT(JHE)=2.*WLAT(JHE) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C EQUALLY-SPACED LATITUDES EXCLUDING POLES - ELSEIF(IDRT.EQ.256) THEN - JH=JMAX/2 - JHE=(JMAX+1)/2 - JHO=JHE - DLT=PI/JMAX - SLAT(1)=1. - DO J=1,JH - SLAT(J)=COS((J-0.5)*DLT) - ENDDO - DO JS=1,JHO - DO J=1,JHO - AWORK(JS,J)=COS(2*(JS-1)*(J-0.5)*DLT) - ENDDO - ENDDO - DO JS=1,JHO - BWORK(JS)=-D1/(4*(JS-1)**2-1) - ENDDO -!#if IBM4 || IBM8 -! CALL DGEF(AWORK,JHE,JHO,IPVT) -! CALL DGES(AWORK,JHE,JHO,IPVT,BWORK,J0) -!#endif -!#if LINUX - call ludcmp(awork,jho,jhe,ipvt,d) - call lubksb(awork,jho,jhe,ipvt,bwork) -!#endif - WLAT(1)=0. - DO J=1,JHO - WLAT(J)=BWORK(J) - ENDDO -CDIR$ IVDEP - DO J=1,JH - SLAT(JMAX+1-J)=-SLAT(J) - WLAT(JMAX+1-J)=WLAT(J) - ENDDO - IF(JHE.GT.JH) THEN - SLAT(JHE)=0. - WLAT(JHE)=2.*WLAT(JHE) - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/util/sorc/webtitle.fd/README b/util/sorc/webtitle.fd/README deleted file mode 100755 index 4f26e568a6..0000000000 --- a/util/sorc/webtitle.fd/README +++ /dev/null @@ -1,9 +0,0 @@ -FF 11/09/12 -no essl library -intel's mkl blas/others are supposed to be compatible: http://en.wikipedia.org/wiki/Basic_Linear_Algebra_Subprograms - -other concerns: - -makefile:39: warning: overriding commands for target `webtitle' -makefile:34: warning: ignoring old commands for target `webtitle' - diff --git a/util/sorc/webtitle.fd/compile_webtitle_wcoss.sh b/util/sorc/webtitle.fd/compile_webtitle_wcoss.sh deleted file mode 100755 index 3d83adb2e2..0000000000 --- a/util/sorc/webtitle.fd/compile_webtitle_wcoss.sh +++ /dev/null @@ -1,43 +0,0 @@ -#!/bin/sh - -###################################################################### -# -# Build executable : GFS utilities -# -###################################################################### - -LMOD_EXACT_MATCH=no -source ../../../sorc/machine-setup.sh > /dev/null 2>&1 -cwd=`pwd` - -if [ "$target" = "wcoss_dell_p3" ] || [ "$target" = "wcoss_cray" ] || [ "$target" = "hera" ] ; then - echo " " - echo " You are on WCOSS: $target " - echo " " -elif [ "$target" = "wcoss" ] ; then - echo " " - echo " " - echo " You are on WCOSS: $target " - echo " You do not need to build GFS utilities for GFS V15.0.0 " - echo " " - echo " " - exit -else - echo " " - echo " Your machine is $target is not recognized as a WCOSS machine." - echo " The script $0 can not continue. Aborting!" - echo " " - exit -fi -echo " " - -# Load required modules -source ../../modulefiles/gfs_util.${target} -module list - -set -x - -mkdir -p ../../exec -make -mv webtitle ../../exec -make clean diff --git a/util/sorc/webtitle.fd/makefile b/util/sorc/webtitle.fd/makefile deleted file mode 100755 index bcad6f8f9f..0000000000 --- a/util/sorc/webtitle.fd/makefile +++ /dev/null @@ -1,37 +0,0 @@ -# Modified BSM for WCOSS build 1/30/2013 -SHELL=/bin/sh - -SRCS= webtitle.f -OBJS= webtitle.o -# Tunable parameters -# -# FC Name of the fortran compiling system to use -# LDFLAGS Flags to the loader -# LIBS List of libraries -# CMD Name of the executable -# PROFLIB Library needed for profiling -# -FC = ifort - -LIBS= ${W3NCO_LIB4} - -CMD = webtitle -FFLAGS = -#FFLAGS = -debug - -# Lines from here on down should not need to be changed. They are the -# actual rules which make uses to build a.out. -# -all: $(CMD) - -$(CMD): $(OBJS) - $(FC) $(FFLAGS) -o $(@) $(OBJS) $(LIBS) - -clean: - -rm -f $(OBJS) - -clobber: clean - -rm -f $(CMD) - -void: clobber - -rm -f $(SRCS) makefile diff --git a/util/sorc/webtitle.fd/webtitle.f b/util/sorc/webtitle.fd/webtitle.f deleted file mode 100755 index b4bfdfa0b0..0000000000 --- a/util/sorc/webtitle.fd/webtitle.f +++ /dev/null @@ -1,147 +0,0 @@ -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C . . . . -C MAIN PROGRAM: WEBTITLE -C PRGMMR: SAGER ORG: NP12 DATE: 2003-10-02 -C -C ABSTRACT: READS A FILE CONTAINING THE CURRENT DATE AND THE FORECAST -C HOUR AND WRITES A FILE CONTAINING A TITLE CONTAINING A REFORMATED -C DATE. THIS FILE IS USED TO CREATE A NEW FORMATED TITLE FOR THE -C NCEP MODEL GRAPHICS WEBSITE -C -C PROGRAM HISTORY LOG: -C -C 03-10-02 L. SAGER ORIGINAL VERSION -C 01-30-13 B. MABE Updated for WCOSS system. Remove Equiv and -C char to integer implied casts -C USAGE: -C INPUT FILES: -C FT05 - CURRENT DATE AND FORECAST HOUR -C -C OUTPUT FILES: -C FT55 - UPDATED TITLE CONTAINING REFORMATTED -C DATE -C -C SUBPROGRAMS CALLED: -C UNIQUE: - -C LIBRARY: - W3AI15 W3FS15 W3DOXDAT -C COMMON - -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM -C -C$$$ -C - INTEGER idat(8) - CHARACTER*4 cout(10) - CHARACTER*3 days(7) - CHARACTER*14 block - CHARACTER*40 line1 - CHARACTER*40 line2 - CHARACTER*4 tb1(2) - CHARACTER*2 tb2(3) - BYTE bsmdate(4) - BYTE retdate(4) - - DATA idat /8*0/ - DATA days /'SUN','MON','TUE','WED','THU','FRI','SAT'/ - - DATA line1 /'09/01/2003 12UTC 24HR FCST VALID TUE 09'/ - - DATA line2 /'/02/2003 12UTC NCEP/NWS/NOAA'/ - - CALL W3TAGB('WEBTITLE',2001,0275,0076,'NP12') -C -C Start by reading in the date/time -C - READ(5,102) block - 102 FORMAT(a14) - READ(block,100) tb1(1), tb1(2), tb2(1), tb2(2), tb2(3) - 100 FORMAT(2a4,4a2) - - read(tb1(1),*) jtau - read(tb1(2),*) iyear - iwork = iyear - 2000 - bsmdate(1)=iwork - read(tb2(1),*) bsmdate(2) - read(tb2(2),*) bsmdate(3) - read(tb2(3),*) bsmdate(4) - -C USAGE: CALL W3FS15 (IDATE, JTAU, NDATE) -C INPUT ARGUMENT LIST: -C IDATE - PACKED BINARY DATE/TIME AS FOLLOWS: -C BYTE 1 IS YEAR OF CENTURY 00-99 -C BYTE 2 IS MONTH 01-12 -C BYTE 3 IS DAY OF MONTH 01-31 -C BYTE 4 IS HOUR 00-23 -C SUBROUTINE TAKES ADVANTAGE OF FORTRAN ADDRESS -C PASSING, IDATE AND NDATE MAY BE -C A CHARACTER*1 ARRAY OF FOUR, THE LEFT 32 -C BITS OF 64 BIT INTEGER WORD. AN OFFICE NOTE 85 -C LABEL CAN BE STORED IN -C 4 INTEGER WORDS. -C IF INTEGER THE 2ND WORD IS USED. OUTPUT -C IS STORED IN LEFT 32 BITS. FOR A OFFICE NOTE 84 -C LABEL THE 7TH WORD IS IN THE 4TH CRAY 64 BIT -C INTEGER, THE LEFT 32 BITS. -C JTAU - INTEGER NUMBER OF HOURS TO UPDATE (IF POSITIVE) -C OR BACKDATE (IF NEGATIVE) -C -C OUTPUT ARGUMENT LIST: -C NDATE - NEW DATE/TIME WORD RETURNED IN THE -C SAME FORMAT AS 'IDATE'. 'NDATE' AND 'IDATE' MAY -C BE THE SAME VARIABLE. - - CALL w3fs15(bsmdate,jtau,retdate) -C -C... w3doxdat returns the day of the week -C -C INPUT VARIABLES: -C IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -C (YEAR, MONTH, DAY, TIME ZONE, -C HOUR, MINUTE, SECOND, MILLISECOND) -C -C OUTPUT VARIABLES: -C JDOW INTEGER DAY OF WEEK (1-7, WHERE 1 IS SUNDAY) -C JDOY INTEGER DAY OF YEAR (1-366, WHERE 1 IS JANUARY 1) -C JDAY INTEGER JULIAN DAY (DAY NUMBER FROM JAN. 1,4713 B.C.) -C - idat(1) = iyear - idat(2) = retdate(2) - idat(3) = retdate(3) - idat(5) = retdate(4) - - CALL w3doxdat(idat,jdow,jdoy,jday) - -C -C Convert the valid date back to character -C - - CALL w3ai15(idat,cout,10,2,' ') - - - line1(1:2) = block(9:10) - line1(4:5) = block(11:12) - line1(9:10) = block(7:8) - line1(12:13) = block(13:14) - line1(18:20) = block(2:4) - line1(35:37) = days(jdow) - line1(39:40) = cout(2)(1:2) - - line2(2:3) = cout(3)(1:2) - line2(7:8) = cout(1)(1:2) - line2(10:11) = cout(5)(1:2) - - - - write(55,105) line1,line2 - 105 FORMAT(2a40) - - CALL W3TAGE('WEBTITLE') - STOP - END diff --git a/util/ush/finddate.sh b/util/ush/finddate.sh deleted file mode 100755 index cd691cec17..0000000000 --- a/util/ush/finddate.sh +++ /dev/null @@ -1,163 +0,0 @@ -# finddate.sh -# author: Luke Lin phone: 457-5047 24 June 1998 -# abstract: This script looks in ether forward or backward in time to -# generate either a variable containing sequential date/time stamps -# for a period up to a month or just the date/time stamp occurring -# at the end of such a period. -# Time stamp is in the form yyyyddmm. The script should be good for many -# years. Leap years are accounted for. Years go 1998, 1999, 2000, 2001, -# 2002, 2003, .... -# etc. -# -# usage: examples assume todays date is 19990929. -# To generate a sequence looking 10 days forward then execute: -# list=`sh /nwprod/util/scripts/finddate.sh 19990929 s+10` -# To generate just the date/time 10 days from now then execute: -# list=`sh /nwprod/util/scripts/finddate.sh 19990929 d+10` -# To generate a sequence looking 10 days backward then execute: -# list=`sh /nwprod/util/scripts/finddate.sh 19990929 s-10` -# To generate just the date/time 10 days ago then execute: -# list=`sh /nwprod/util/scripts/finddate.sh 19990929 d-10` -# list will contain 10 time stamps starting with 19990929. Time stamps -# are separated by blanks. -# -# This script will work for periods up to a month. The number indicating -# the period in question should be two digits. For single digits 1-9 -# use 01, 02, 03, etc. -set +x -unset pdstr -today=$1 -var=$2 -yy=`echo $today | cut -c1-4 ` -mm=`echo $today | cut -c5-6 ` -dd=`echo $today | cut -c7-8 ` -nxtyy=$yy -pyy=$yy -what=`echo $var | cut -c1-1` -up=`echo $var | cut -c2-2` -num=`echo $var | cut -c3-4` -mod=`expr \( $yy / 4 \) \* 4 - $yy ` -leap=0 -if test "$mod" -eq 0 -then -leap=1 -fi -case $mm in -01) mday=31 - pday=31 - pmon=12 - pyy=`expr $yy - 1` - if test $pyy -lt '0' - then - pyy='1999' - fi - nxtmon=02;; -02) mday=`expr "$leap" + 28 ` - pday=31 - pmon=01 - nxtmon=03;; -03) mday=31 - pday=`expr "$leap" + 28 ` - pmon=02 - nxtmon=04;; -04) mday=30 - pday=31 - pmon=03 - nxtmon=05;; -05) mday=31 - pday=30 - pmon=04 - nxtmon=06;; -06) mday=30 - pday=31 - pmon=05 - nxtmon=07;; -07) mday=31 - pday=30 - pmon=06 - nxtmon=08;; -08) mday=31 - pday=31 - pmon=07 - nxtmon=09;; -09) mday=30 - pday=31 - pmon=08 - nxtmon=10;; -10) mday=31 - pday=30 - pmon=09 - nxtmon=11;; -11) mday=30 - pday=31 - pmon=10 - nxtmon=12;; -12) mday=31 - pday=30 - pmon=11 - nxtmon=01 - nxtyy=`expr $yy + 1 ` - if test $yy -eq 1999 - then - nxtyy=2000 - fi ;; -*) echo mon=$mon is illegal - exit 99 ;; -esac - -if test $dd -gt $mday -then - echo "day=$dd is illegal. In month=$mon there are only $mday days." - exit 16 -fi - -i=1 -n=0 -while test $i -le $num -do - if test "$up" = '+' - then - ddn=`expr $dd + $i` - mmn=$mm - yyn=$yy - if test $ddn -gt $mday - then - n=`expr $n + 1` - ddn=$n - mmn=$nxtmon - yyn=$nxtyy - fi - if test $ddn -lt 10 - then - ddn="0$ddn" - fi - elif test "$up" = '-' - then - ddn=`expr $dd - $i` - mmn=$mm - yyn=$yy - if test $ddn -le '0' - then - n=`expr $pday + $ddn` - ddn=$n - mmn=$pmon - yyn=$pyy - fi - if test $ddn -lt 10 - then - ddn="0$ddn" - fi - else - echo '+ or - are allowed for 2nd variable in argument.' - echo "You tried $up, this is illegal." - exit 16 - fi - i=`expr $i + 1 ` - if test "$what" = 's' - then - pdstr=$pdstr"$yyn$mmn$ddn " - else - pdstr=$yyn$mmn$ddn - fi -done -echo $pdstr diff --git a/util/ush/make_NTC_file.pl b/util/ush/make_NTC_file.pl deleted file mode 100755 index 9c838bdebe..0000000000 --- a/util/ush/make_NTC_file.pl +++ /dev/null @@ -1,119 +0,0 @@ -#!/usr/bin/perl -# -#------------------------------------------------------ -# -# This is make_NTC_file.pl -# It attaches the appropriate headers to the input file -# and copies it to a unique name for input to NTC. -# -# The following lines are prepended to the file: -# 1. A Bulletin Flag Field Seperator -# 2. A WMO header line -# 3. An optional subheader, e.g. DIFAX1064 -# -# Input wmoheader Originator datetime path -# where: -# wmoheader - WMO id to use in WMO header. -# subheader - "NONE" if none. -# Originator - Originator to use in WMO header -# datetime - date/time to use in WMO header, yyyymmddhh -# path - name input file -# output_path - name of output file -# -# Author: Paula Freeman based on script by Larry Sager -# -#------------------------------------------------------ - -$NArgs = @ARGV; - -if ($NArgs < 6) { - usage (); - exit; -} - -# -# Get input -# - -$WMOHeader=shift; -$Origin=shift; -$YYYYMMDDHH=shift; -$SubHeader=shift; -$Filename=shift; -$OutputFilename=shift; - -print "Filename is $Filename\n"; -print "Output Filename is $OutputFilename\n"; -$YYYYMMDDHH =~ /\d{4}(\d{2})(\d{4})/; -$MMDDHH = $1 . $2; -$DDHHMM = $2 . "00"; -print "WMOHeader = $WMOHeader\n"; -print "SubHeader = $SubHeader\n"; -print "Origin = $Origin\n"; - - -if ( ($WMOHeader eq "") || ($Origin eq "") || ($YYYYMMDDHH eq "") || ($Filename eq "") || ($OutputFilename eq "") || ($SubHeader eq "") ) { - usage (); - exit; -} - -# -# Create the file for TOC -# - - make_toc (); -# -# - - -sub usage () { - print "Usage: $0 \n"; -} - -sub make_toc { - -# -# Attach WMO header and subheader (if not "NONE"). -# Get the bytecount of file to insert into the Bulletin Flag Field Seperator. -# Add in length of WMO header, plus two carriage returns and line feed. -# If Subheader specified, count that in also, plus line a feed. -# - - $Header = "$WMOHeader $Origin $DDHHMM"; - $ByteCount = `wc -c $Filename | cut -c1-8`; - $ByteCount= $ByteCount + length($Header) + 3; - if ($SubHeader =~ /NONE/) { - print "No Subheader\n"; - } else { - if ($SubHeader =~ /IMAG/){ - $ByteCount = $ByteCount + length($SubHeader); - } else { - $ByteCount = $ByteCount + length($SubHeader) + 3; - } - } - $BulletinFlagFieldSep = sprintf( "****%10.10d****", $ByteCount); - - open(OUTFILE, ">$OutputFilename") or die "Cannot open $OutputFilename for output."; - print OUTFILE "$BulletinFlagFieldSep\n"; - print OUTFILE "$Header\r\r\n"; - if ($SubHeader =~ /NONE/) { - print "No Subheader\n"; - } else { - if ($SubHeader =~ /IMAG/){ - print OUTFILE "$SubHeader"; - } else { - print OUTFILE "$SubHeader\r\r\n"; - } - } - open (INFILE, $Filename) or die "Cannot open $Filename"; - - while ($rec=) { - print OUTFILE $rec; - } - - close INFILE; - close OUTFILE; - - print "$Filename -> $OutputFilename\n"; -} - diff --git a/util/ush/make_ntc_bull.pl b/util/ush/make_ntc_bull.pl deleted file mode 100755 index c6ca287ead..0000000000 --- a/util/ush/make_ntc_bull.pl +++ /dev/null @@ -1,250 +0,0 @@ -#!/usr/bin/perl -# -#------------------------------------------------------ -# -# This is make_ntc_bull.pl -# It attaches the appropriate headers to the input file -# and copies it to a unique name for input to NTC. -# -# A Bulletin Flag Field Separator is prepended to the -# text bulletin. This TOC header contains the total -# number of bytes in the product not counting the -# bulletin flag field separator. -# -# Input: -# File identifier - Output name identier. -# subheader - "NONE" if none. -# Originator - Not used currently -# datetime - Not used currently -# filename - input file name -# output_path - name of output file -# -# Author: Larry Sager based on a script by Paula Freeman -# -# 31 Oct 05 -- new script -# -#------------------------------------------------------ - -if ($ENV{job}) { $job=$ENV{job}; } -if ($ENV{SENDCOM}) { $SENDCOM=$ENV{SENDCOM}; } -if ($ENV{SENDDBN}) { $SENDDBN=$ENV{SENDDBN}; } -$NArgs = @ARGV; - -if ($NArgs < 6) { - usage (); - exit; -} - -# -# Get input -# - -$NAME=shift; -$WMOname=shift; -$ORIGname=shift; -$DATEname=shift; -$Filename=shift; -$OutputFilename=shift; -print " Input : $Filename"; -print " Output: $OutputFilename"; - - -if ( ($Filename eq "") || ($OutputFilename eq "") ) { - usage (); - exit; -} - -# -# Create the file for TOC -# - if ( $NAME eq "plot" ) { - make_tocplot (); - } - elsif ($NAME eq "redb" ) { - make_tocredb (); - } - else { - make_tocbull (); - } -# -# - - -sub usage () { - print "Usage: $0 \n"; -} - -sub make_tocbull { - -# -# Attach WMO header -# Get the bytecount of file to insert into the Bulletin Flag Field Seperator. -# - - $ix = 0; - $under = "_"; - open (INFILE, $Filename) or die "Cannot open $Filename"; - - while ($cho=) { - $rec = $rec . $cho; - } - $cho = $rec; - $cho =~ s/\n//g; - $cho =~ s/<<@@/\r\r\n/g; - $cho =~ s/<<@/\r\r\n/g; - $cho =~ s/<//g; - $cho =~ s/\^//g; - $cho =~ s/\$//g; - $cho =~ s/\|/+/g; - $value = 40; - $Outp="$OutputFilename"; - open(OUTFILE, ">$Outp") or die "Cannot open $OutputFilename for output."; - while ($ix == 0) { - $cho = substr($cho,$value); - $value = 38; - $cho =~ s/'1/\&\&/; - $cho =~ s/'0/\&\&/; -# print "cho is $cho"; - ($cho2,$cho) = split(/\&\&/,$cho); - ($cho2,$cho3) = split(/\%/,$cho2); -# print "cho2 is $cho2"; - $ByteCount = length($cho2); - print " length is $ByteCount "; - $BulletinFlagFieldSep = sprintf( "****%10.10d****", $ByteCount); - if ($SENDCOM eq "YES") { - if ($ByteCount > 50 ) { - print OUTFILE "$BulletinFlagFieldSep\n"; - print OUTFILE $cho2; - } - else { - $ix = 1; - } - } - } - close OUTFILE; - if ($SENDDBN eq "YES" ) { -# Modified 20051205 by wx11rp to ensure the current production machine is used. -# $dbn_alert="/gpfs/w/nco/dbnet/bin/dbn_alert"; - $dbn_alert=$ENV{'DBNROOT'} . "/bin/dbn_alert"; - $type="GRIB_LOW"; - $job2=$job; - $subtype=$ORIGname; - $file_path=$Outp; - @command = ($dbn_alert, $type, $subtype, $job2, $file_path); - if (system (@command) != 0) { - print "Error alerting: @command \n"; - } - } - - close INFILE; - close OUTFILE; - - print "$Filename -> $OutputFilename\n"; -} - -sub make_tocplot { - -# -# Attach WMO header -# Get the bytecount of file to insert into the Bulletin Flag Field Seperator. -# - - $ix = 0; - $under = "_"; - open (INFILE, $Filename) or die "Cannot open $Filename"; - - while ($cho=) { - $rec = $rec . $cho; - } - $cho = $rec; -# $Outp="$OutputFilename$under$job"; - $Outp="$OutputFilename"; - open(OUTFILE, ">$Outp") or die "Cannot open $OutputFilename for output."; - while ($ix == 0) { - $cho =~ s/\$\$/\&\&/; - ($cho2,$cho) = split(/\&\&/,$cho); -# $cho2 =~ s/@/ /g; -# $cho2 = $cho2 . " "; - $ByteCount = length($cho2); - print " length is $ByteCount "; - $BulletinFlagFieldSep = sprintf( "****%10.10d****", $ByteCount); - if ($SENDCOM eq "YES") { - if ($ByteCount > 50 ) { - print OUTFILE "$BulletinFlagFieldSep\n"; - print OUTFILE $cho2; - } - else { - $ix = 1; - } - } - } - close OUTFILE; - if ($SENDDBN eq "YES" ) { -# 20051205 Modified by wx11rp to allow the script to run on any manchine labeled as the production machine -# $dbn_alert="/gpfs/w/nco/dbnet/bin/dbn_alert"; - $dbn_alert=$ENV{'DBNROOT'} . "/bin/dbn_alert"; - $type="GRIB_LOW"; - $subtype=$DATEname; - $job2=$job; - $file_path=$Outp; - @command = ($dbn_alert, $type, $subtype, $job2, $file_path); - if (system (@command) != 0) { - print "Error alerting: @command \n"; - } - } - - close INFILE; - close OUTFILE; - - print "$Filename -> $OutputFilename\n"; -} -sub make_tocredb { - -# -# Prepare the Redbook graphic for transmission to TOC by removing the AWIPS -# header and creating an NTC header. Get the Bytecount of the file to -# insert into the Bulletin Flag Field Seperator. -# - - $ix = 0; - $under = "_"; - open (INFILE, $Filename) or die "Cannot open $Filename"; - - while ($cho=) { - $rec = $rec . $cho; - } - $cho = $rec; - $Outp="$OutputFilename"; - open(OUTFILE, ">$Outp") or die "Cannot open $OutputFilename for output."; - $cho = substr($cho,24); - $ByteCount = length($cho); - print " length is $ByteCount "; - $BulletinFlagFieldSep = sprintf( "****%10.10d****", $ByteCount); - if ($SENDCOM eq "YES") { - if ($ByteCount > 50 ) { - print OUTFILE "$BulletinFlagFieldSep\n"; - print OUTFILE $cho; - - } - } - close OUTFILE; - if ($SENDDBN eq "YES" ) { -# 20051205 Modified by wx11rp to allow the script to run on any manchine labeled as the production machine -# $dbn_alert="/gpfs/w/nco/dbnet/bin/dbn_alert"; - $dbn_alert=$ENV{'DBNROOT'} . "/bin/dbn_alert"; - $type="GRIB_LOW"; - $subtype=$DATEname; - $job2=$job; - $file_path=$Outp; - @command = ($dbn_alert, $type, $subtype, $job2, $file_path); - if (system (@command) != 0) { - print "Error alerting: @command \n"; - } - } - - close INFILE; - close OUTFILE; - - print "$Filename -> $OutputFilename\n"; -} diff --git a/util/ush/make_ntcfile.pl b/util/ush/make_ntcfile.pl deleted file mode 100755 index 814954619c..0000000000 --- a/util/ush/make_ntcfile.pl +++ /dev/null @@ -1,142 +0,0 @@ -#!/usr/bin/perl -# -#------------------------------------------------------ -# -# This is make_NTC_file.pl -# It attaches the appropriate headers to the input file -# and copies it to a unique name for input to NTC. -# -# The following lines are prepended to the file: -# 1. A Bulletin Flag Field Seperator -# 2. A WMO header line -# 3. An optional subheader, e.g. DIFAX1064 -# -# Input wmoheader Originator datetime path -# where: -# wmoheader - WMO id to use in WMO header. -# subheader - "NONE" if none. -# Originator - Originator to use in WMO header -# datetime - date/time to use in WMO header, yyyymmddhh -# path - name input file -# output_path - name of output file -# -# Author: Paula Freeman based on script by Larry Sager -# -# 16 June 02 -- remove LF after subheader -# -#------------------------------------------------------ - -$NArgs = @ARGV; - -if ($NArgs < 6) { - usage (); - exit; -} - -# -# Get input -# - -$WMOHeader=shift; -$Origin=shift; -$YYYYMMDDHH=shift; -$SubHeader=shift; -$Filename=shift; -$OutputFilename=shift; - -# Check the input paramaters - -# WMOHeader must be 6 characters -if ($WMOHeader !~ /^\w{6}$/) { - usage (); - print "Usage: WMOHeader must be 6 characters\n"; - exit; -} -# Origin must be 4 characters -if ($Origin !~ /^\w{4}$/) { - usage (); - print "Usage: Origin must be 4 characters\n"; - exit; -} - -# $YYYYMMDDHH must be 10 digits -if ($YYYYMMDDHH !~ /^\d{10}$/) { - usage (); - print "Usage: YYYYMMDDHH must be 10 digits\n"; - exit; -} - -# SubHeader, Filename, and OutputFilename must all be non-blank -if ($SubHeader =~ /^$/ || $Filename =~ /^$/ || $OutputFilename =~ /^$/) { - usage (); - print "Usage: SubHeader, Filename, and OutputFilename must be non-blank\n"; - exit; -} - -print "Filename is $Filename\n"; -print "Output Filename is $OutputFilename\n"; -$YYYYMMDDHH =~ /\d{4}(\d{2})(\d{4})/; -$MMDDHH = $1 . $2; -$DDHHMM = $2 . "00"; -print "WMOHeader = $WMOHeader\n"; -print "SubHeader = $SubHeader\n"; -print "Origin = $Origin\n"; - - -if ( ($WMOHeader eq "") || ($Origin eq "") || ($YYYYMMDDHH eq "") || ($Filename eq "") || ($OutputFilename eq "") || ($SubHeader eq "") ) { - usage (); - exit; -} - -# -# Create the file for TOC -# - - make_toc (); -# -# - - -sub usage () { - print "Usage: $0 \n"; -} - -sub make_toc { - -# -# Attach WMO header and subheader (if not "NONE"). -# Get the bytecount of file to insert into the Bulletin Flag Field Seperator. -# Add in length of WMO header, plus two carriage returns and line feed. -# If Subheader specified, count that in also, plus line a feed. -# - - $Header = "$WMOHeader $Origin $DDHHMM"; - $ByteCount = `wc -c $Filename | cut -c1-8`; - $ByteCount= $ByteCount + length($Header) + 3; - if ($SubHeader =~ /NONE/) { - print "No Subheader\n"; - } else { - $ByteCount = $ByteCount + length($SubHeader); - } - $BulletinFlagFieldSep = sprintf( "****%10.10d****", $ByteCount); - - open(OUTFILE, ">$OutputFilename") or die "Cannot open $OutputFilename for output."; - print OUTFILE "$BulletinFlagFieldSep\n"; - print OUTFILE "$Header\r\r\n"; - if ($SubHeader =~ /NONE/) { - print "No Subheader\n"; - } else { - print OUTFILE "$SubHeader"; - } - open (INFILE, $Filename) or die "Cannot open $Filename"; - - while ($rec=) { - print OUTFILE $rec; - } - - close INFILE; - close OUTFILE; - - print "$Filename -> $OutputFilename\n"; -} - diff --git a/util/ush/make_tif.sh b/util/ush/make_tif.sh deleted file mode 100755 index 2609d1d797..0000000000 --- a/util/ush/make_tif.sh +++ /dev/null @@ -1,45 +0,0 @@ -#!/bin/sh - -cd $DATA -# -# Use Image Magick to convert the GIF to TIF -# format -# -# module show imagemagick-intel-sandybridge/6.8.3 on CRAY -# export PATH=$PATH:/usrx/local/prod/imagemagick/6.8.3/intel/sandybridge/bin:. -# export LIBPATH="$LIBPATH":/usrx/local/prod/imagemagick/6.8.3/intel/sandybridge/lib -# export DELEGATE_PATH=/usrx/local/prod/imagemagick/6.8.3/intel/sandybridge/share/ImageMagick-6 - -# module show imagemagick/6.9.9-25 on DELL - export PATH=$PATH:/usrx/local/dev/packages/ImageMagick/6.9.9-25/bin:. - export LIBPATH="$LIBPATH":/usrx/local/dev/packages/ImageMagick/6.9.9-25/lib - export DELEGATE_PATH=/usrx/local/dev/packages/ImageMagick/6.9.9-25/share/ImageMagick-6 - - outname=out.tif - - convert gif:$input fax:$outname - -# -# Add the ntc heading: -# - -WMO=QTUA11 -ORIG=KWBC -PDYHH=${PDY}${cyc} - -if [ $HEADER = "YES" ] -then - INPATH=$DATA/$outname - SUB=DFAX1064 -# make_NTC_file.pl $WMO $ORIG $PDYHH $SUB $INPATH $OUTPATH - $UTILgfs/ush/make_NTC_file.pl $WMO $ORIG $PDYHH $SUB $INPATH $OUTPATH -# -# Send the graphic to TOC - - cp $OUTPATH ${COMOUTwmo}/gfs_500_hgt_tmp_nh_anl_${cyc}.tif - if [ $SENDDBN = YES ]; then - - $DBNROOT/bin/dbn_alert GRIB_LOW ${NET} ${job} ${COMOUTwmo}/gfs_500_hgt_tmp_nh_anl_${cyc}.tif - fi -fi - diff --git a/util/ush/mkawpgrb.sh b/util/ush/mkawpgrb.sh deleted file mode 100755 index bdde03553b..0000000000 --- a/util/ush/mkawpgrb.sh +++ /dev/null @@ -1,409 +0,0 @@ -#!/bin/ksh -# UTILITY SCRIPT NAME : mkawpgrb.sh -# AUTHOR : Mary Jacobs -# DATE WRITTEN : 11/06/96 -# -# Abstract: This utility script produces AWIPS GRIB bulletins. -# -# Input: 1 argument are passed to this script. -# 1st argument - Forecast Hour - format of 2I -# -# Usage: mkawpgbl.sh $hour -# (For NAM Products, this script look for env var of $GRID) -# - -echo "History: SEP 1996 - First implementation of this utility script" -echo "Modified: APR 1997 - Added logic for KWBH parm when MRF, default" -echo " KWBC (program default) for GFS products. " -echo " This logic lost when processing converted " -echo " to SMS...field never noticed! (MAF) " -echo "Modified: AUG 1999 - Modified for IBM SP" -echo " Allows interactive use" -echo "Modified: MAY 2003 - Added call to new executable, tocgrib, which" -echo " will send unblocked files with headers to " -echo " the TOC for transmission to AWIPS." -echo "Modified: AUG 2014 - Removed processing GFS in GRIB2" -echo "Modified: MAY 2015 - Updated for WCOSS Phase 2" -# - -set +x -hour_list="$1" -num=$# - -if test "$num" -ge 1 -then - echo " Appropriate number of arguments were passed" - set -x -# export EXECutil=${EXECutil:-${NWROOT}/util/exec} -# export PARMutil=${PARMutil:-${NWROOT}/util/parm} - export envir=${envir:-prod} - export jlogfile=${jlogfile:-jlogfile} - export NET=${NET:-gfs} - export RUN=${RUN:-gfs} - export DBNALERT_TYPE=${DBNALERT_TYPE:-GRIB_LOW} - if [ $NET = "nam" ] - then - if [ -z "$GRID" ] - then - export GRID=207 - fi - fi - export cyc=${cyc:-00} - export cycle=${cycle:-t${cyc}z} - export SENDCOM=${SENDCOM:-NO} - export SENDDBN=${SENDDBN:-NO} - if [ -z "$DATA" ] - then - export DATA=`pwd` - cd $DATA - ${NWROOT}/util/ush/setup.sh - ${NWROOT}/util/ush/setpdy.sh - . PDY - fi - export COMIN=${COMIN:-${COMROOT}/$NET/$envir/$NET.$PDY/${cyc}} - export COMOUTwmo=${COMOUT:-${COMROOT}/${NET}/${envir}/${RUN}.${PDY}/${cyc}/wmo} - export job=${job:-interactive} - export pgmout=${pgmout:-OUTPUT.$$} -else - echo "" - echo "Usage: mkawpgbl.sh \$hour" - echo "" - exit 16 -fi - -set +x -echo " ------------------------------------------" -echo " BEGIN MAKING $NET XTRN/GRIB AWIPS PRODUCTS" -echo " ------------------------------------------" -set -x - -msg="Enter Make AWIP GRIB utility." -postmsg "$jlogfile" "$msg" - -############################################ -# Figure out INPUT/OUTPUT/PARM/EXEC Fields -############################################ -############################################## -# NOTE: STOP process 6-hour output GFS Grids -# in this script remove gfs part. -############################################## - -for hour in $hour_list -do - case $NET in - mrf)input_grb=pgrbf${hour} - input_grbi=pgrbif${hour} - output_grb=xtrn.awp${NET}${hour} - parmcard=grib_awp${NET}${hour} - parm="parm=KWBH" -# executable=mkgfsawps - executable=$MKGFSAWPS - DBNALERT_TYPE=GRIB_LOW - ;; - smoke)case $GRID in - sfc)input_grb=grib2_sfc.1hr_227 - input_grbi="" - output_grb=smoke_sfc.1hr_227.grib2 - parmcard=grib2_smokesfc.227 - parm="parm=KWBP" -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=GRIB_LOW - ;; - pbl)input_grb=grib2_pbl.1hr_227 - input_grbi="" - output_grb=smoke_pbl.1hr_227.grib2 - parmcard=grib2_smokepbl.227 - parm="parm=KWBP" -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=GRIB_LOW - ;; - esac - ;; - nam)case $GRID in - ######################################## - # 6-hour output NAM Grids - ######################################## - 207)input_grb=awp207${hour}.tm00 - input_grbi=awp207i${hour} - output_grb=xtrn.awp${NET}${hour}.207 - parmcard=grib_awp${NET}${hour}.207 - parm="parm=KWBE" -# executable=tocgrib - executable=$TOCGRIB - DBNALERT_TYPE=GRIB_LOW - ;; - 211)input_grb=awp211${hour}.tm00 - input_grbi=awp211i${hour} - output_grb=xtrn.awp${NET}${hour}.211 - parmcard=grib_awp${NET}${hour}.211 - parm="parm=KWBE" -# executable=tocgrib - executable=$TOCGRIB - DBNALERT_TYPE=GRIB_LOW - ;; - 237)input_grb=awp237${hour}.tm00 - input_grbi=awp237i${hour} - output_grb=xtrn.awp${NET}${hour}.237 - parmcard=grib_awp${NET}${hour}.237 - parm="parm=KWBE" -# executable=tocgrib - executable=$TOCGRIB - DBNALERT_TYPE=GRIB_LOW - ;; - icwf)input_grb=awip3d${hour}.tm00_icwf - input_grbi=awip3di${hour}.tm00_icwf - output_grb=xtrn.awp_icwf_${NET}${hour}.212 - parmcard=grib_icwf${NET}${hour} - parm="parm=KWBD" -# executable=tocgrib - executable=$TOCGRIB - DBNALERT_TYPE=GRIB_LOW - ;; - ######################################## - # 3-hour output NAM Grids - ######################################## - 212)input_grb=awip3d${hour}.tm00 - input_grbi=awip3di${hour}.tm00 - output_grb=xtrn.awp${NET}${hour} - parmcard=grib_meso${hour}.40 - parm="parm=KWBE" -# executable=tocgrib - executable=$TOCGRIB - DBNALERT_TYPE=GRIB_LOW - ;; - 215)input_grb=awip20${hour}.tm00 - input_grbi=awip20i${hour}.tm00 - output_grb=xtrn.awp${NET}${hour}.GRIB215 - parmcard=grib_meso${hour}.20 - parm="parm=KWBE" -# executable=tocgrib - executable=$TOCGRIB - DBNALERT_TYPE=GRIB_LOW - ;; - 216)input_grb=awipak${hour}.tm00 - input_grbi=awipaki${hour}.tm00 - output_grb=xtrn.awpak${NET}${hour} - parmcard=grib_mesoak${hour}.40 - parm="parm=KWBE" -# executable=tocgrib - executable=$TOCGRIB - DBNALERT_TYPE=GRIB_LOW - ;; - 217)input_grb=awp217${hour}.tm00 - input_grbi=awp217i${hour}.tm00 - output_grb=xtrn.awp${NET}${hour}.GRIB217 - parmcard=grib_mesoak${hour}.20 - parm="parm=KWBE" -# executable=tocgrib - executable=$TOCGRIB - DBNALERT_TYPE=GRIB_LOW - ;; - 237_off)input_grb=awp237${hour}.tm00 - input_grbi=awp237i${hour} - output_grb=xtrn.awp${NET}${hour}.237 - parmcard=grib_awp${NET}${hour}.237o - parm="parm=KWBE" -# executable=tocgrib - executable=$TOCGRIB - DBNALERT_TYPE=GRIB_LOW - ;; - icwf_off)input_grb=awip20${hour}.tm00_icwf - input_grbi=awip20i${hour}.tm00_icwf - output_grb=xtrn.awp_icwf_${NET}${hour} - parmcard=grib_icwfmeso${hour} - parm="parm=KWBE" -# executable=tocgrib - executable=$TOCGRIB - DBNALERT_TYPE=GRIB_LOW - ;; - 218g2)input_grb=awphys${hour}.grb2.tm00 - input_grbi="" - output_grb=grib2.awp${NET}${hour}.218 - parmcard=grib2_awp${NET}${hour}.218 -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=GRIB_LOW - ;; - 242g2)input_grb=awak3d${hour}.grb2.tm00 - input_grbi="" - output_grb=grib2.awp${NET}${hour}.242 - parmcard=grib2_awp${NET}${hour}.242 -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=GRIB_LOW - ;; - 218_icwf)input_grb=awip12${hour}.grb2.tm00_icwf - input_grbi="" - output_grb=grib2.awp${NET}${hour}.${GRID} - parmcard=grib2_awp${NET}${hour}.${GRID} -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=GRIB_LOW - ;; - 242_icwf)input_grb=awak3d${hour}.grb2.tm00_icwf - input_grbi="" - output_grb=grib2.awp${NET}${hour}.${GRID} - parmcard=grib2_awp${NET}${hour}.${GRID} -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=GRIB_LOW - ;; - esac - ;; - dgex)case $GRID in - 185)RUN=dgex_conus - input_grb=awpgrb2${GRID}${hour}.tm00 - input_grbi="" - output_grb=grib2.awpdgex${hour}.${GRID} - parmcard=grib2_awpdgex${hour}.${GRID} -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=GRIB_LOW - ;; - 186)RUN=dgex_alaska - input_grb=awpgrb2${GRID}${hour}.tm00 - input_grbi="" - output_grb=grib2.awpdgex${hour}.${GRID} - parmcard=grib2_awpdgex${hour}.${GRID} -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=GRIB_LOW - ;; - 185_icwf)RUN=dgex_conus - input_grb=awpgrb2185${hour}.tm00_icwf - input_grbi="" - output_grb=grib2.awpdgex${hour}.${GRID} - parmcard=grib2_awpdgex${hour}.${GRID} -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=GRIB_LOW - ;; - 186_icwf)RUN=dgex_alaska - input_grb=awpgrb2186${hour}.tm00_icwf - input_grbi="" - output_grb=grib2.awpdgex${hour}.${GRID} - parmcard=grib2_awpdgex${hour}.${GRID} -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=GRIB_LOW - ;; - esac - ;; - aqm) - case $GRID in - 227)input_grb=grib2.227 - input_grbi="" - output_grb=grib2.awpaqm.${GRID} - parmcard=grib2_awpaqm.227.${cycle} -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=GRIB_LOW - ;; - 227_3X)input_grb=grib2_3x.227 - input_grbi="" - output_grb=grib2.awpaqm_3x.${GRID} - parmcard=grib2_awpaqm_3x.227.${cycle} -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=GRIB_LOW - ;; - 227_5X)input_grb=grib2_5x.227 - input_grbi="" - output_grb=grib2.awpaqm_5x.${GRID} - parmcard=grib2_awpaqm_5x.227.${cycle} -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=GRIB_LOW - ;; - esac - ;; - sref)input_grb=pgrb${GRID}.${type}_3hrly.grib2 - input_grbi="" - output_grb=grib2.t${cyc}z.awipsref${GRID}.${type} - parmcard=grib2_awpsref${GRID}.${type} -# executable=tocgrib2 - executable=$TOCGRIB2 - DBNALERT_TYPE=NTC_LOW - ;; - ruc)RUN=ruc2 - input_grb=pgrb13f${hour}.grib2 - input_grbi="" - output_grb=grib2.t${cyc}z.awpruc13f${hour} - parmcard=grib2_awpruc13f${hour} -# executable=tocgrib2 - executable=$TOCGRIB2 -# DBNALERT_TYPE=NTC_LOW - DBNALERT_TYPE= - ;; - esac - - executable_name=`basename $executable` - - ############################## - # Copy Input Field to $DATA - ############################## - - if test ! -f $input_grb - then - cp $COMIN/${RUN}.${cycle}.$input_grb $input_grb - fi - - if test ! -f $COMIN/${RUN}.${cycle}.$input_grbi - then -# if test $executable != "tocgrib2" - if test $executable_name != "tocgrib2" - then -# $EXECutil/grbindex $input_grb $input_grbi - $GRBINDEX $input_grb $input_grbi - else - input_grbi="" - fi - else - cp $COMIN/${RUN}.${cycle}.$input_grbi $input_grbi - fi - - ############################## - # Create AWIPS GRIB data - ############################## - - export pgm=$executable - . prep_step - export FORT11="$input_grb" - export FORT31="$input_grbi" - export FORT51="$output_grb" - - startmsg - -# $executable < $PARMshared/$parmcard $parm >> $pgmout 2>errfile - $executable < ${UTILgfs}/parm/$parmcard $parm >> $pgmout 2>errfile -# $EXECutil/$executable < $PARMutil/$parmcard $parm >> $pgmout 2>errfile -# export err=$?;err_chk - - ############################## - # Post Files to COMOUTwmo - ############################## - - if test "$SENDCOM" = 'YES' - then - cp $output_grb $COMOUTwmo/$output_grb.$job - - ############################## - # Distribute Data - ############################## - - if [ "$SENDDBN" = 'YES' -o "$SENDAWIP" = 'YES' ] ; then - $DBNROOT/bin/dbn_alert $DBNALERT_TYPE $NET $job $COMOUTwmo/$output_grb.$job - else - msg="File $output_grb.$job not posted to db_net." - postmsg "$jlogfile" "$msg" - fi - fi - - msg="Awip Processing ${hour} hour completed normally" - postmsg "$jlogfile" "$msg" - -done - -exit diff --git a/util/ush/ml7_slm30g.sh b/util/ush/ml7_slm30g.sh deleted file mode 100755 index 02b2a53a40..0000000000 --- a/util/ush/ml7_slm30g.sh +++ /dev/null @@ -1,241 +0,0 @@ -#!/bin/ksh - -# -# Script history log: -# 1999-05-01 Mark Iredell -# 2000-02-14 S Moorthi -# 2001-12-14 J Alpert (*j*) -# 2004-05-12 J Alpert (*j*) fix for E-W gaussian grid pt shift -# 2004-12-06 J Alpert (*j*) script input settings for spect filter -# 2005-03-21 J Alpert (*j*) Added GrumbineICE to orog/slm... -# 2011-12-xx S Moorthi Added unfiltered orography and linear grids -# 2014-05-20 F YANG reorganized to include in GFS util directory -# -# W/Lott & Miller terrain principal coord. (*j*) -# -#Usage: ml7_slm30g.sh slmgb orogb mtnvar14 nlon nlat jcap filter1 filter2 mtnres -# Normally: filter1~1/3 ((jcap/3)-1)) -# Normally: filter2~jcap+2)) -# Normally: mtnres=8 minute only (do not use =4, =2 except at own risk) -# now =1 is 30" others are turned off. see below -# New run mtnlm7 for mtnres=1 set for 30" -# script changed like ml4b for spect filter input, otherwise same as ml2b -# Input script fortran positional parameters: -# 1 output sea-land mask GRIB file -# 2 output orography GRIB file -# 3 output 14-field mountain variance file -# 4 number of Gaussian longitudes -# 5 number of Gaussian latitudes -# 6 spectral triangular truncation -# 7 Envelope orography factor -# 8 Begining latitude (used only for nongaussian grid - -# used only for switching north/south) -# 9 Mountain data resolution -# -# Imported Shell Variables: -# WRKDIR working directory -# defaults to a directory that is made, used and deleted -# FIXDIR fix directory -# defaults to /gloptmp/fix -# TERRAINSORC terrain source file -# defaults -# now this defaults to the local dir -# LONSPERLAT input lonsperlat text file (if it exists) -# defaults to $FIXDIR/global_lonsperlat.t$6.txt -# VERBOSE verbose flag (YES or NO) -# defaults to NO -# -# Modules and files referenced: -# scripts : /global/save/wx23ja/bin/mkwrkdir -# -# source : ${TERRAINSORC} or -# ops(20060822)w/GICE -# -# input data : /ptmp/wx23ja/terr05/markr/gtopo30_gg.fine output array -# /global/noscrub/wx23ja/terr05/markr/gtopo30_gg.fine -# about 2GB fort.235 -# /gloptmp/fix/global_lonsperlat.t$6.txt -# -# output data: $1 -# $2 -# $3 -# -# scratch : ${WRKDIR}/terrain00.xd -# ${WRKDIR}/fort.11 -# ${WRKDIR}/fort.12 -# ${WRKDIR}/fort.13 -# ${WRKDIR}/fort.14 -# ${WRKDIR}/fort.20 -# ${WRKDIR}/fort.51 -# ${WRKDIR}/fort.52 -# ${WRKDIR}/fort.53 -# ${WRKDIR}/fort.54 -# ${WRKDIR}/fort.55 -# ${WRKDIR}/fort.56 -# ${WRKDIR}/fort.57 -# ${WRKDIR}/fort.71 -# -# Remarks: -# -# Condition codes -# 0 - no problem encountered -# >0 - some problem encountered -# -# Attributes: -# Language: POSIX shell -# Machine: IBM SP -# -#### - -################################################################################ -# Check arguments -if [[ $# -ne 13 ]] ; then - echo Usage: $0 slmgb orogb mtnvar14 IM JM NM filter1 filter2 MTNRES orogb_uf oro_bin oro_bin oro_bin_uf slm_bin >&2 - exit 1 -fi -# -# VERBOSE = YES means debug mode -# -# export VERBOSE=${VERBOSE:-"NO"} -export VERBOSE=${VERBOSE:-"YES"} -if [[ "$VERBOSE" = "YES" ]];then - echo $(date) EXECUTING $0 $* >&2 - set -x -fi -pwd=$(pwd) -echo $pwd -typeset -L1 l1 -slmgb=$1 -l1=$slmgb ; [[ $l1 = / || $l1 = ~ ]] || slmgb=$pwd/$slmgb -orogb=$2 -l1=$orogb ; [[ $l1 = / || $l1 = ~ ]] || orogb=$pwd/$orogb -mtnvar14=$3 -l1=$mtnvar14 ; [[ $l1 = / || $l1 = ~ ]] || mtnvar14=$pwd/$mtnvar14 -nlon=$4 -nlat=$5 -jcap=$6 -#### efac=$7 -#### blat=$8 -efac=0 -blat=0 -#### export NF1=${NF1:-$(($jcap+1))} -#### export NF2=${NF2:-$(($jcap+2))} -export NF1=${7:-$(($jcap+1))} -export NF2=${8:-$(($jcap+2))} -export mtnres=${9:-"8"} -orogb_uf=${10:-""} -oro_bin=${11:-""} -oro_bin_uf=${12:-""} -slm_bin=${13:-""} -l1=$orogb_uf ; [[ $l1 = / || $l1 = ~ ]] || orogb_uf=$pwd/$orogb_uf -l1=$oro_bin ; [[ $l1 = / || $l1 = ~ ]] || oro_bin=$pwd/$oro_bin -l1=$oro_bin_uf ; [[ $l1 = / || $l1 = ~ ]] || oro_bin_uf=$pwd/$oro_bin_uf -l1=$slm_bin ; [[ $l1 = / || $l1 = ~ ]] || slm_bin=$pwd/$slm_bin -NR=0 - -echo "Usage: $0 $slmgb $orogb $mtnvar14 $nlon $nlat $jcap $NF1 $NF2 $MTNRES $orogb_uf" -echo " efac=$efac blat=$blat NF1=$NF1 NF2=$NF2 " -echo " _______________________________________________ " - -# -# file names for Prin Coord dataset grib output -# -thetagb=thetagb -l1=$thetagb ; [[ $l1 = / || $l1 = ~ ]] || thetagb=$pwd/$thetagb -gammagb=gammagb -l1=$gammagb ; [[ $l1 = / || $l1 = ~ ]] || gammagb=$pwd/$gammagb -sigmagb=sigmagb -l1=$sigmagb ; [[ $l1 = / || $l1 = ~ ]] || sigmagb=$pwd/$sigmagb -vargb=vargb -l1=$vargb ; [[ $l1 = / || $l1 = ~ ]] || vargb=$pwd/$vargb -elvmaxgb=elvmaxgb -l1=$elvmaxgb;[[ $l1 = / || $l1 = ~ ]] || elvmaxgb=$pwd/$elvmaxgb - -# -export WRKDIR=${WRKDIR:-${PTMP:-/ptmpp2}/$LOGNAME/terr_wrkdir$$} - -export lin=${lin:-""} -export BASEDIR=${UTILDIR:-/global/save/emc.glopara/svn/gfs/trunk/para/util} -export NWPROD=${NWPROD:-/nwprod} -export FIXDIR=${FIXDIR:-$NWPROD/fix} -export LONSPERLAT=${LONSPERLAT:-$FIXDIR/global_lonsperlat.t${jcap}$lin.txt} -export TERRAINEXEC=${TERRAINEXEC:-$BASEDIR/exec/terrain.x} -################################################################################ - -if [ ! -d $WRKDIR ] ; then - export MKWRKDIR=YES - mkdir -p $WRKDIR -fi -cd $WRKDIR - -FIX_TERR=${FIX_TERR:-$BASEDIR/fix} -MTNDIR=${MTNDIR:-$FIX_TERR} -MTN_SLM=${MTN_SLM:-TOP8M_slm.80I1.asc} -HIRES_TERR=${HIRES_TERR:-$FIX_TERR/thirty.second.antarctic.new.bin} -FINE_TERR=${FINE_TERR:-$FIX_TERR/gtopo30_gg.fine} -LANDCOVER30=${LANDCOVER30:-$FIX_TERR/landcover30.fixed} -slm_bin=${slm_bin:-SLM.T$jcap} -oro_bin=${oro_bin:-ORO.T$jcap} -oro_bin_uf=${oro_bin_uf:-ORU.T$jcap} - -ln -fs $MTNDIR/$MTN_SLM fort.14 -ln -fs $HIRES_TERR fort.15 -ln -fs $LONSPERLAT fort.20 -ln -fs $slm_bin fort.51 -ln -fs $oro_bin fort.52 -ln -sf $mtnvar14 fort.53 -ln -fs ORS.T$jcap fort.54 -ln -fs $oro_bin_uf fort.55 -ln -sf $slmgb fort.56 -ln -sf $orogb fort.57 -ln -sf $thetagb fort.58 -ln -sf $gammagb fort.59 -ln -sf $sigmagb fort.60 -ln -sf $vargb fort.61 -ln -sf $elvmaxgb fort.62 -ln -sf THETA.T$jcap fort.66 -ln -sf GAMMA.T$jcap fort.67 -ln -sf SIGMA.T$jcap fort.68 -ln -sf mtn.T$jcap.ieee fort.71 -ln -fs $orogb_uf fort.72 -ln -fs $FINE_TERR fort.235 -ln -fs $LANDCOVER30 landcover30.fixed -ln -fs $a_ocean_mask fort.25 - -#export OMP_NUM_THREADS=1 -export MP_COREFILE_FORMAT=lite - -echo " mtnres nlon nlat jcap NR NF1 NF2 efac blat" -echo $mtnres $nlon $nlat $jcap $NR $NF1 $NF2 $efac $blat -echo " exec located: $x " -echo " EXECUTION BEGINS " -echo $mtnres $nlon $nlat $jcap $NR $NF1 $NF2 $efac $blat | $TERRAINEXEC - -ret=$? -if [[ "$VERBOSE" = "YES" ]] ; then - echo ret=$ret -fi - -# copy files from working dir to present -#cp -p $WRKDIR/m* $local_dir/. - -# this will get the mtnvar_14 and mtn.ieee file for grads use -# the ...gb files are present directly - from starting local dir. -# the other files working files are left to be copied by the user. -# Remove working directory - -if [[ "$VERBOSE" = "YES" ]] ; then - echo $pwd - ls -l - echo " ml7_slm30g.sh: setting MKWRKDIR = NO " - echo " - not deleting working dir $WRKDIR " - MKWRKDIR=NO -fi -# -cd $pwd -[[ $MKWRKDIR = YES ]] && rm -rf $WRKDIR -set +x -if [[ "$VERBOSE" = "YES" ]];then - echo " $(date) EXITING $0 with return code $ret >&2 " -fi -exit $ret diff --git a/util/ush/month_name.sh b/util/ush/month_name.sh deleted file mode 100755 index 48437e21d5..0000000000 --- a/util/ush/month_name.sh +++ /dev/null @@ -1,112 +0,0 @@ -#!/bin/ksh - -#################################################################### -# -# SCRIPT: month_name.sh -# -# This script returns the name/abreviation of a month -# in a small text file, month_name.txt. It also echos the -# name/abreviation to stdout. The form of the returned -# name/abreviation is specified by the script arguments. -# -# USAGE: ./month_name.sh < month > < monthspec> -# -# EXAMPLE: ./month_name.sh 5 MON -# -# month spec contents of month_name.txt -# ----------- ------ ---------------------------- -# -# 6/06 Mon Jun -# 8/08 Month August -# 9/09 MON SEP -# 11 MONTH NOVEMBER -# -# -# Note: Variables may be assigned the value of the returned name -# by either of the following methods: -# -# MM=`cat month_name.txt` after executing month_name.sh -# - OR - -# MM=`month_name.sh 5 MON` (for example) -# -# -# -# HISTORY: 07/08/2005 - Original script -# -# -#################################################################### - - - typeset -Z2 month_num - - - month_num=$1 - month_spec=$2 - - case ${month_num} in - - 01) Mon=Jan - Month=January ;; - - 02) Mon=Feb - Month=February ;; - - 03) Mon=Mar - Month=March ;; - - 04) Mon=Apr - Month=April ;; - - 05) Mon=May - Month=May ;; - - 06) Mon=Jun - Month=June ;; - - 07) Mon=Jul - Month=July ;; - - 08) Mon=Aug - Month=August ;; - - 09) Mon=Sep - Month=September ;; - - 10) Mon=Oct - Month=October ;; - - 11) Mon=Nov - Month=November ;; - - 12) Mon=Dec - Month=December ;; - - esac - - - if [ ${month_spec} = Mon ]; then - - echo ${Mon} - echo ${Mon} > month_name.txt - - elif [ ${month_spec} = Month ]; then - - echo ${Month} - echo ${Month} > month_name.txt - - elif [ ${month_spec} = MON ]; then - - MON=`echo ${Mon} | tr [a-z] [A-Z]` - echo ${MON} - echo ${MON} > month_name.txt - - elif [ ${month_spec} = MONTH ]; then - - MONTH=`echo ${Month} | tr [a-z] [A-Z]` - echo ${MONTH} - echo ${MONTH} > month_name.txt - - fi - - - diff --git a/util/ush/overdate.sigma.sh b/util/ush/overdate.sigma.sh deleted file mode 100755 index fdc8e35052..0000000000 --- a/util/ush/overdate.sigma.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/bin/sh -# This script changes the date of a sigma or surface file -if [[ $# -lt 2 ]];then - echo Usage: $0 yyyymmddhh sigma.in [sigma.out] - exit 1 -fi -d=$1 -[[ $d > 0000000000 && $d < 9999999999 ]]||exit 2 -i=$2 -[[ -s $i ]]||exit 2 -o=${3:-$i} -if [ "$DATA" != "" ] -then - t=$DATA/tmp$$ -else - t=/ptmpp1/tmp$$ -fi -export XLFRTEOPTS="unit_vars=yes" -export XLFUNIT_11="$i" -export XLFUNIT_51="$t" -echo $d|/nwprod/util/exec/overdate.sigma ||exit 3 -mv $t $o ||exit 3 diff --git a/util/ush/reduced_gaussian_grid.sh b/util/ush/reduced_gaussian_grid.sh deleted file mode 100755 index ee4d42c836..0000000000 --- a/util/ush/reduced_gaussian_grid.sh +++ /dev/null @@ -1,43 +0,0 @@ -#!/bin/sh -# --------------------------------------------------------------------- -# author: Henry Juang date: Feb 14, 2013 -# purpose: Use to create Gaussian latitudes and reduced grid number for -# all latitudes. The ouput is only north hemisphere, for the -# Gaussian latitudes over south hemisphere are mirror image the -# values of north hemisphere except with negative sign. For -# the reduced grid number for south hemisphere is mirror -# image of north hemisphere. -# usage: to run this script, provide following -# export UTIL=/nwprod/util -# export JCAP=1148 -# export LONF=2304 -# export LATG=1152 -# export OUTD=/tmp/reduce -# then run script -# $UTIL/ush/reduced_gaussian_grid.sh -# note: make sure you have FFTable LONF, which you can refer to -# Acceptable_Lengths_for_the_Transforms.pdf -# in $UTIL/sorc/reduced_gaussian_grid.fd -# --------------------------------------------------------------------- - -set -ex - -JCAP=${JCAP:-1148} -LONF=${LONF:-2304} -LATG=${LATG:-1152} -NUMREDUCE=4 -echo "$JCAP $LONF $LATG $NUMREDUCE" >inp.$$ - -UTIL=${UTIL:-/gpfs/t3/global/save/wx23hh/2013/gfs/ticket48/util} -OUTD=${OUTD:-/gpfs/t3/global/save/wx23hh/2013/gfs/ticket48/util/fix} -pgm=reduced_gaussian_grid.exec -$UTIL/exec/$pgm /dev/null 2>&1 - mkdir -m 775 -p $COMOUTwmo >/dev/null 2>&1 - jlogfile=$DATA/snd2forgn_log - reqid=${$} - PID=$$ - JOB=$LOGNAME - model=test - export PID - pgmout=output.$PID - jobid="${JOB}.o${reqid}" - USHutil=${NWROOT}/util/ush - UTILhome="$5" - if test $# -eq 6 - then - SENDDBN=NO - else - SENDDBN=NO - fi - export model jlogfile jobid reqid COMOUTwmo pgmout - export JOB DATA PID - cd $DATA - - - # run setup to initialize working directory and utility scripts - - # sh $USHutil/setup.sh - - PATH=$PATH:. - export PATH - -# !!!!!!!!!!!!! ____________ END CHECK OUT SECTION __________ !!!!!!!! -else - -# check to see if $SENDDBN is missing - - - if [ -z "$SENDDBN" ] ; then - SENDDBN=NO - export SENDDBN - fi - set +x -fi -set -x - -export DBNROOT=${DBNROOT:-/gpfs/a/nco/dbnet} -# load input args - -TYPE="$1" -ttype=$TYPE - -outfil="$2" -flg="$3" -INFILE="$4" -set -x -export filename=`basename ${INFILE}` -export FLG=`echo $flg | tr '[a-z]' '[A-Z]' ` -export CONCARD=card$flg{$$} - -# get the number of characters in TYPE ! - -NUM=${#TYPE} - -# get the number of sub types in TYPE! - -numprt=`echo $TYPE | awk -F_ '{print NF}'` - -if [ $numprt -gt 1 ] -then - WASNCDC=NO - WASPWWB=NO - -# remove the under score separators from $TYPE. - - newstr="" - group=`echo $TYPE \ | awk -F_ '{for(i=1;i<=NF;i++) \ - {if(i$DATA/sndfrc - fi - else - set -x - msg="snd2forgn testing, $SUBTYP $filename not sent!" - set +x - - fi - fi - snd=NO - done - -# have removed all the special cases ! - - echo "WASNCDC=$WASNCDC !" - echo "WASPWWB=$WASPWWB !" - - - if [ -z "$newstr" ] ; then - echo " newstr > is empty < will exit!" - postmsg "$jlogfile" "$msg" - exit - fi - ttype=${newstr} - echo "$ttype is the remaining TYPE flag!" - -elif [ $numprt -eq 1 ] -then - echo "There is only one type= ${TYPE}!" - -# check for the special cases: -# NCDC and PWWB ! - - - case $TYPE in - "NCDC") - WASNCDC=YES - -# THIS file is to go to NCDC - - $USHutil/sndncdc ${outfil} ${INFILE} - - echo "$TYPE was only NCDC so EXIT!" - exit 0 - ;; - "PWWB") - -# This file is to be printed at the WWB - - WASPWWB=YES - smember=sndfaxwwb - export smember - $smember ${INFILE} - - echo "$TYPE was only PWWB so EXIT!" - exit 0 - ;; - "AFOS") - snd=NO - ;; - "AWIP") - snd=YES - ;; - "FAXX") - snd=YES - ;; - "TRAN") - snd=YES - ;; - "XTRAN") - snd=YES - ;; - *) - esac - if test "$snd" = 'YES' - then - - if test "$SENDDBN" = 'YES' - then - $DBNROOT/bin/dbn_alert $TYPE $2 $3 ${INFILE} - export istat=$? - echo dbn_alert: Ended with return code = $istat - if test "$istat" = 0 - then - msg="Posting $filename with $TYPE!" - else - msg="ERROR FROM dbn_alert = $istat, Posting $filename with ${TYPE}!" - sndfrc=1 - echo $sndfrc >$DATA/sndfrc - fi - else - msg="snd2forgn testing, ${TYPE} $filename not sent!" - fi - postmsg "$jlogfile" "$msg" - snd=NO - exit 0 - fi -else - msg "ERROR TYPE MISSING BECAUSE $numprt is ZERO!" - postmsg "$jlogfile" "$msg" - exit -fi - - -JAG=${ttype} - echo "${JAG} is the TYPE flag" -export JAG - - -cat < $CONCARD -${JAG} is the TYPE flag -strt1EOH - cat $CONCARD - actn="Copying" - -#______________________________________________________________ -# -# check to see if this a nmc 6bit file or is to go to -# nhc-hp13. -# -#______________________________________________________________ - - -istat=`egrep -c "NHC_6BIT" ${CONCARD}` - if test "$istat" -ne 0 - then - - -# this a nmc6bit file that is only to be sent to nhc-hp13. -# - actn="Sending" - echo "$actn a nmc6bit file with $JAG." - - base=`basename ${outfil}` - FORFIL=/dbnet/data/nmc6bit/$base - - else - istat=`egrep -c "AWPS_RB|OSO" ${CONCARD}` - if test "$istat" -ne 0 - then - FORFIL=$outfil - actn="Posting" - if test "$JAG" = "AWPS_RB" - then - JAG="GRIB" - fi - - else - actn="Copying" - FORFIL=$outfil - fi - fi - -#echo I should now calldbn_alert! -istat=0 - -export INFILE -export FORFIL -export JAG - -#______________________________________________________________ -# call dbn_alert to move file to foreign host -#______________________________________________________________ - -if test "$SENDDBN" = 'YES' -then - $DBNROOT/bin/dbn_alert $JAG $FORFIL $FLG $INFILE - - istat=$? - export istat - export actn - echo dbn_alert: Ended with return code = $istat -# -#______________________________________________________________ -# make message for jlogfile. -#_______________________________________________________________ -# - if test "$istat" = 0 - then - if [ "$actn" = "Posting" ] - then - msg="$actn $filename with $JAG !" - - elif [ "$actn" = "Posting-copying" ] - then - msg="POSTING file to OSO and COPYING into $FORFIL!" - elif [ "$actn" = "Copying" ] - then - msg="COPYING into file: $FORFIL!" - elif [ "$actn" = "Sending" ] - then - msg="$actn a nmc6bit file with $JAG." - else - msg="COPYING into file: $FORFIL!" - fi - else - msg="ERROR FROM dbn_alert = $istat, trying to $actn with $JAG ! " - sndfrc=1 - echo $sndfrc >$DATA/sndfrc - fi -else - msg="snd2forgn testing, $JAG $FORFIL $FLG $INFILE not sent!" -fi - postmsg "$jlogfile" "$msg" - -rm ${CONCARD} -exit 0 diff --git a/util/ush/snd2forgntbl.sh b/util/ush/snd2forgntbl.sh deleted file mode 100755 index 6f04631e08..0000000000 --- a/util/ush/snd2forgntbl.sh +++ /dev/null @@ -1,70 +0,0 @@ -# UTILITY SCRIPT NAME : snd2forgntbl.sh -#______________________________________________________________________________ -# NAME : snd2forgntbl.sh -# History : 1997-03-04 Paula Stone -# MODIFIED : 1997-03-04 Paula Stone Remove -i from grep. Because -# sometimes gets more than one record. -# : 1999-12-02 Peter Henrichsen modified to run on the IBM SP. -# : 2000-01-20 Peter Henrichsen modify to pass sndfrc to script -# snd2forgn and to use USHutil -# -# Abstract: This utility script sends a file via snd2forgn -# using the ftype and foreign fields defined in the -# graph_snd2forgn.names table. -# Variables to be exported to this script: -# FIXgraph - where graph_snd2forgn.names resides) -# JOB - name of this job. -# -# Location : This script is found on hp36 as: -# : /tmp_mnt/export/sgi73/peterhen/util/scripts/ibm/snd2forgntbl.sh -# : on ncosp as: -# : /nfsuser/g02/wx12ph/util/ush/snd2forgntbl.sh or -# /nwprod/util/ush/snd2forgntbl.sh -# -# Input: three variables are passed through the call -# 1 ... sendkey -- key used in snd2forgn.names table. -# 2 ... filename -- name of file on local host. -# 3 ... dirname -- name of directory where file resides. -# - -set -x - -if test $# -ne 3 -then - echo "Error: usage snd2table.sh " - exit -fi - -sendkey=$1 -filename=$2 -dirname=$3 -echo Search snd2forgn table for $sendkey -# grep $sendkey $FIXshared/graph_snd2forgn.names >> sendline -grep $sendkey ${UTILgfs}/fix/graph_snd2forgn.names >> sendline -if [ -s sendline ] -then - ftype=`awk '{print $2}' sendline` - foreign=`awk '{print $3}' sendline` - sndfrc=0 - echo $sndfrc >$DATA/sndfrc - - - snd2forgn $ftype $foreign $job $dirname/$filename - read sndfrc < $DATA/sndfrc - - if test $sndfrc -eq '0' - then - msg="snd2forgntbl.sh successfully ended!" - postmsg "$jlogfile" "$msg" - else - msg="ERROR $filename NOT POSTED!" - postmsg "$jlogfile" "$msg" - msg="snd2forgn: ABNORMAL STOP = $sndfrc!:" - postmsg "$jlogfile" "$msg" - fi -else - echo Sendkey $sendkey is not in the snd2forgn.names table - exit -1 -fi -rm sendline -exit diff --git a/util/ush/sndncdc b/util/ush/sndncdc deleted file mode 100755 index 26eb3304e3..0000000000 --- a/util/ush/sndncdc +++ /dev/null @@ -1,135 +0,0 @@ -#!/bin/ksh -USAGE="usage: sndncdc " -SMEMBER=sndncdc -VERS="version: ${SMEMBER} 2000-02-02 09:40L " -#______________________________________________________________________________ -# NAME : sndncdc -# Author : Peter Henrichsen -# Purpose : This script calls dbn_alert to post a nmc6bit file for NCDC -# : -# : -# History : 1999-12-03 Peter Henrichsen -# 2000-01-21 Peter Henrichsen modified to change "job" arg -# to lower case. -# 2000-01-21 Peter Henrichsen modified to put all nmc6bit files -# into ${COMROOT}/foreign/ncdc -# -# -# Location : This script is found on hp36 as: -# : /tmp_mnt/export/sgi73/peterhen/util/scripts/ibm/sndncdc -# : & on ncosp as -# : ${NWROOT}/util/ush/sndncdc or -# : /nfsuser/g02/wx12ph/util/ush/sndncdc -# -# Remarks : This script assumes that the following values have been -# exported by the parent shell: -# job JOBID SENDDBN jlogfile model COMOUTwmo. -# -# : Arg1 ncdcbasename this is the ncdc base name to which -# the extenion of CCYYMMDDHH will be added. -# -# : Arg2 (local-file) -# This is the full path of the local file to be sent -# to NCDC. -# -#_______________________________________________________________________________ -# -#_______________________________________________________________________________ -# -cd $DATA -print "$VERS" -integer istat - -if test $# -ge 2 -then - echo "sndncdc has $# args!" - -else - echo "Error sndncdc needs 2 args!" - echo "Error: $USAGE" - exit -fi -outfil="$1" -INFILE="$2" - set -x -export subdir=`basename ${COMOUTwmo}` -if test "$subdir" = 'faxx' -then - export dir=${COMROOT}/foreign/ncdc -else - export dirn=`dirname ${HOMEutil}` - if test "$dirn" = '${NWROOT}' - then - export dir=${COMROOT}/foreign/ncdc - else - export dir=$HOMEutil${COMROOT}/foreign/ncdc - fi - set +x - -fi - - -# get the year month day and z time to append to end of the file that is to -# go to NCDC $outfil - - YMDZ=`date -u +"%Y%m%d%H"` - -# this makes sure that the new file is copied into ${COMROOT}/foreign/faxx ! - - - ncdcfil=`echo ${outfil} | awk 'BEGIN{FS="."} {print $1}'` - - if [ -z "${dir}" ] ; then - cp ${INFILE} ${dir}/${ncdcfil}.${YMDZ} - else - set -x - mkdir -m 775 -p $dir - cp ${INFILE} ${dir}/${ncdcfil}.${YMDZ} - set +x - fi - - -istat=0 - -# check to see if $job is missing - - if [ -z "$job" ] ; then - job=missgn - export job - fi - # check to see if $model is missing - - - if [ -z "$model" ] ; then - model=unkown - export model - fi -#set -x -#______________________________________________________________ -# call dbn_alert to send file to NCDC -#______________________________________________________________ - set -x - if test "$SENDDBN" = 'YES' - then - - $DBNROOT/bin/dbn_alert \ - NCDC ${model} ${job} ${dir}/${ncdcfil}.${YMDZ} - istat=$? - echo dbn_alert: Ended with return code = $istat - if test "$istat" = 0 - then - if test "$dir" = '${COMROOT}/foreign/ncdc' - then - msg="SENT ${dir}/${ncdcfil}.${YMDZ} to NCDC !" - else - msg="SENT ${ncdcfil}.${YMDZ} to NCDC !" - fi - else - msg="ERROR FROM dbn_alert = $istat, trying to send to NCDC!" - fi - else - msg="sndncdc testing, ${dir}/${ncdcfil}.${YMDZ} not sent!" - fi - postmsg "$jlogfile" "$msg" - set +x -exit diff --git a/util/ush/terrain.sh b/util/ush/terrain.sh deleted file mode 100755 index 9eecc991db..0000000000 --- a/util/ush/terrain.sh +++ /dev/null @@ -1,176 +0,0 @@ -#!/bin/ksh -set -x - -#-------------------------------------------------------------------------------- -# Create GFS orography, land-sea mask, mountain variance and other terrain features -# 2014.05 -- Source from .svnemc./projects/gfs/branches/moorthi/para/util/oro_etc -# 2014.05 -- F. YANG merged two scripts into one, reorganized for including this -# tool in GFS util directory. Currently only works on WCOSS. -# 2016.01 -- Shrivinas Moorthi, added output in binary format; added Cubic and -# Quadratic grid. -#-------------------------------------------------------------------------------- -# to execute the script, run either interactively or submit as a batch job -# /u/Fanglin.Yang/bin/sub_wcoss -a GFS-T2O -q dev2 -p 1/1/N -r 27000/1 -t 06:00:00 -o terrain.out terrain.sh -#-------------------------------------------------------------------------------- - -export WORKFLOW=${WORKFLOW:-/global/noscrub/emc.glopara/svn/gfs/q3fy17/gfs_workflow.v14.1.0/para} -export UTILDIR=$WORKFLOW/util -export GLOBAL_SHARED=${GLOBAL_SHARED:-/global/noscrub/emc.glopara/svn/gfs/q3fy17/global_shared.v14.0.0} -export FIXDIR=$GLOBAL_SHARED/fix/fix_am #lonsperlat dir - -export TERRAINSH=$UTILDIR/ush/ml7_slm30g.sh -export TERRAINEXEC=$UTILDIR/exec/terrain.x - -#export OCLSM=oclsm #use ocean land/sea mask option, must have txt file from ocean -#export TERRAINEXEC=$UTILDIR/exec/terrain_oclsm.x - -export ptmp=/ptmpp1 -export RUNDIR=$ptmp/$LOGNAME/terrain -export SAVEDIR=$ptmp/$LOGNAME/terrain/save -mkdir -p $RUNDIR $SAVEDIR - -#--examples of quadratic grids -# jcap="62 126 170 190 254 382 574 878" -#--examples of linear grids -# jcap="L92 L126 L254 L382 L574 L878 L1148 L1534" -#--examples of Cubic Gris -# jcap="C1150 C1534" - -#---------------------------- -export jcaplist="L92 L126 L254 L382 L574 L670 L1534" -for jcapl in $jcaplist ; do -#---------------------------- - nc=$(echo $jcapl | wc -c) - fc=$(echo $jcapl | cut -c1-1) - if [ $fc == L ] ; then - export jcap=$(echo $jcapl | cut -c2-$((nc-1))) - echo ' Using linear grid for JCAP=' $jcap - elif [ $fc == Q ] ; then - export jcap=$(echo $jcapl | cut -c2-$((nc-1))) - echo ' Using quadratic grid for JCAP=' $jcap - elif [ $fc == C ] ; then - export jcap=$(echo $jcapl | cut -c2-$((nc-1))) - echo ' Using cubic grid for JCAP=' $jcap - else - export jcap=$jcapl - fi - echo $jcap - -export red_grd=YES #compute stats on reduced grid? -if [ $red_grd = YES ] ; then - export SUFIN='.rg' -else - export LONSPERLAT=/dev/null - export SUFIN="" -fi -# -#for no filter, set filt1=jcap+1 and filt2=filt1+1 - -#...................... -if [ $fc = L ] ; then -#...................... - if [ $jcap -eq 92 ] ; then - export lonb=192 ; export latb=94 ; export filt1=42 ; export filt2=64 - - elif [ $jcap -eq 126 ] ; then - export lonb=384 ; export latb=190 ; export filt1=84 ; export filt2=128 - - elif [ $jcap -eq 254 ] ; then - export lonb=512 ; export latb=256 ; export filt1=128 ; export filt2=172 - - elif [ $jcap -eq 382 ] ; then - export lonb=768 ; export latb=384 ; export filt1=256 ; export filt2=384 - - elif [ $jcap -eq 510 ] ; then - export lonb=1024 ; export latb=512 ; export filt1=384 ; export filt2=512 - - elif [ $jcap -eq 670 ] ; then - export lonb=1344 ; export latb=672 ; export filt1=384 ; export filt2=672 - - elif [ $jcap -eq 574 ] ; then - export lonb=1152 ; export latb=576 ; export filt1=384 ; export filt2=576 - - elif [ $jcap -eq 878 ] ; then - export lonb=1760 ; export latb=880 ; export filt1=384 ; export filt2=880 - - elif [ $jcap -eq 1148 ] ; then - export lonb=2304 ; export latb=1152 ; export filt1=384 ; export filt2=1148 - - elif [ $jcap -eq 1500 ] ; then - export lonb=3072 ; export latb=1536 ; export filt1=576 ; export filt2=$jcap - - elif [ $jcap -eq 1534 ] ; then - export lonb=3072 ; export latb=1536 ; export filt1=576 ; export filt2=$jcap - fi -#...................... -else -#...................... - if [ $jcap -eq 62 ] ; then - export lonb=192 ; export latb=94 ; export filt1=42 ; export filt2=64 -# export lonb=192 ; export latb=94 ; export filt1=64 ; export filt2=64 - - elif [ $jcap -eq 126 ] ; then - export lonb=384 ; export latb=190 ; export filt1=84 ; export filt2=128 - - elif [ $jcap -eq 170 ] ; then - export lonb=512 ; export latb=256 ; export filt1=128 ; export filt2=172 - - elif [ $jcap -eq 190 ] ; then - export lonb=576 ; export latb=288 ; export filt1=128 ; export filt2=192 - - elif [ $jcap -eq 254 ] ; then - export lonb=768 ; export latb=384 ; export filt1=192 ; export filt2=256 - - elif [ $jcap -eq 382 ] ; then - #export lonb=1152 ; export latb=576 ; export filt1=0 ; export filt2=0 - export lonb=1152 ; export latb=576 ; export filt1=256 ; export filt2=384 - - elif [ $jcap -eq 510 ] ; then - export lonb=1536 ; export latb=766 ; export filt1=384 ; export filt2=512 - - elif [ $jcap -eq 574 ] ; then - export lonb=1760 ; export latb=880 ; export filt1=384 ; export filt2=576 - - elif [ $jcap -eq 878 ] ; then - export lonb=2640 ; export latb=1320 ; export filt1=384 ; export filt2=880 - - elif [ $jcap -eq 1148 ] ; then - export lonb=3456 ; export latb=1728 ; export filt1=384 ; export filt2=1148 - fi -#...................... -fi -#...................... - -export lin=".$lonb.$latb" -export WRKDIR=$RUNDIR/terr_$jcap.$lonb.${latb} -mkdir -p $WRKDIR -cd $WRKDIR || exit 8 - -string=t$jcap.$lonb.${latb}$SUFIN -export slmgb=global_slmask.$string.grb -export orogb=global_orography.$string.grb -export orogb_uf=global_orography_uf.$string.grb -export mtnvar14=global_mtnvar.$string.f77 -export oro_bin=global_orography.$string.f77 -export oro_bin_uf=global_orography_uf.$string.f77 -export slm_bin=global_slmask.$string.f77 - - -#export FIX_TERR=$UTILDIR/fix -export FIX_TERR=/gpfs/hps/emc/global/noscrub/emc.glopara/svn/fv3gfs/fix/fix_orog -export MTNDIR=$FIX_TERR -export MTN_SLM=TOP8M_slm.80I1.asc -export HIRES_TERR=$FIX_TERR/thirty.second.antarctic.new.bin -export FINE_TERR=$FIX_TERR/gtopo30_gg.fine -export LANDCOVER30=$FIX_TERR/landcover30.fixed -export a_ocean_mask=$FIX_TERR/a_ocean_mask${lonb}x${latb}.txt - -$TERRAINSH $slmgb $orogb $mtnvar14 $lonb $latb $jcap $filt1 $filt2 14 $orogb_uf $oro_bin $oro_bin_uf $slm_bin> $WRKDIR/out_$jcap.out - -cp -p $WRKDIR/global_* $SAVEDIR/. -cp -p $FIXDIR/global_lonsperlat.t${jcap}.${lonb}.${latb}.txt $SAVEDIR/. -#---------------------------- -done -#---------------------------- -exit - diff --git a/util/ush/verfdate.sh b/util/ush/verfdate.sh deleted file mode 100755 index 414e4e0b96..0000000000 --- a/util/ush/verfdate.sh +++ /dev/null @@ -1,180 +0,0 @@ -#!/bin/ksh - -###################################################################### -# -# Script verfdate.sh takes a user specified PDY, time and forecast -# hour and computes a valid time. The valid time is passed to the -# program in a local file, verfdate.txt . -# -# USAGE: ${NWROOT}/util/ush/verfdate.sh -# -# EXAMPLE: ${NWROOT}/util/ush/verfdate.sh 20050807 12 48 -# -# -# The result can be accessed by: -# -# cat verfdate.txt | read fy fm fd valid dayvrf monvrf -# -# Where fy = 4-digit year ( eg. 2005 ) -# fm = 2-digit month ( eg. 03 ) -# fd = 2-digit day-of-month ( eg. 27 ) -# valid = 2-digit time of day ( eg. 06 ) -# dayvrf = name of valid day ( eg. FRI ) -# monvrf = name of valid month ( eg. JUN ) -# -# NOTE: This routine uses script ${NWROOT}/util/ush/finddate.sh -# -# -# History: 29 AUG 2005 Ralph Jones - Original version -# -# -####################################################################### - - - typeset -Z2 hr - -# Collect arguments - - PDY=$1 - hh=$2 - fhour=$3 - - -# Parse PDY - - yyyy=`echo $PDY | cut -c1-4` - mm=`echo $PDY | cut -c5-6` - dd=`echo $PDY | cut -c7-8` - - -# Check for invalid day - - case $mm in - 01|03|05|07|08|10|12) ndays=31 ;; - 02) ndays=28 - let mod4=yyyy%4 - if [ $mod4 -eq 0 ]; then - ndays=29 - fi ;; - 04|06|09|11) ndays=30 ;; - esac - - if [ $dd -gt $ndays ]; then - echo "\n\n The specified day, $dd, exceeds the number of days in month $mm \n" - echo " EXITING verfdate.sh \n" - exit - fi - - -# Compute number of days and verifying hour - - let term=fhour+hh - - let days=term/24 - if [ $term -lt 0 ]; then - let "days=-1+(term+1)/24" - fi - - - if [ $days -eq 0 ]; then - verfdate=$PDY - hour=$term - elif [ $days -gt 0 ]; then - verfdate=`finddate.sh $PDY d+$days` - let "hour=term-(days*24)" - else - let negdays=-1*days - verfdate=`finddate.sh $PDY d-$negdays` - let "hour=(negdays*24)+term" - fi - - hr=$hour - - - - fy=`echo $verfdate | cut -c1-4` - fm=`echo $verfdate | cut -c5-6` - fd=`echo $verfdate | cut -c7-8` - fday=$fd - if [ $fday -lt 10 ]; then - fday=`echo $fday | cut -c2` - fi - - - -# Find name of verification month - - case $fm in - 01) monvrf=JAN - pdays=0 ;; - 02) monvrf=FEB - pdays=31 ;; - 03) monvrf=MAR - pdays=59 ;; - 04) monvrf=APR - pdays=90 ;; - 05) monvrf=MAY - pdays=120 ;; - 06) monvrf=JUN - pdays=151 ;; - 07) monvrf=JUL - pdays=181 ;; - 08) monvrf=AUG - pdays=212 ;; - 09) monvrf=SEP - pdays=243 ;; - 10) monvrf=OCT - pdays=273 ;; - 11) monvrf=NOV - pdays=304 ;; - 12) monvrf=DEC - pdays=334 ;; - *) monvrf=UND - pdays=999 - echo "\n\n UNDEFINED MONTH-OF-YEAR: fm = $fm ABORTING \n\n" - exit ;; - esac - - let mod4=fy%4 - if [ $mod4 -eq 0 -a $fm -gt 2 ]; then - let pdays=pdays+1 - fi - - - case $fy in - 2006|2012|2017|2023|2034|2040|2045) day1=0 ;; - 2007|2018|2024|2029|2035|2046) day1=1 ;; - 2008|2013|2019|2030|2036|2041|2047) day1=2 ;; - 2014|2020|2025|2031|2042|2048) day1=3 ;; - 2009|2015|2026|2032|2037|2043) day1=4 ;; - 2010|2016|2021|2027|2038|2044|2049) day1=5 ;; - 2005|2011|2022|2028|2033|2039|2050) day1=6 ;; - esac - - -# Find day-of-week and day name of verification date - - let doy=pdays+fday-1 - let "dow=(doy+day1)%7" - - - case $dow in - 0) dayvrf=SUN ;; - 1) dayvrf=MON ;; - 2) dayvrf=TUE ;; - 3) dayvrf=WED ;; - 4) dayvrf=THU ;; - 5) dayvrf=FRI ;; - 6) dayvrf=SAT ;; - esac - - -# Create valid time label - - echo "$fy $fm $fd $hr $dayvrf $monvrf" | tee verfdate.txt - - echo "VALID ${hr}Z $dayvrf $fd $monvrf $fy" >> verfdate.txt - - - exit - diff --git a/util/ush/xlf_links.sh b/util/ush/xlf_links.sh deleted file mode 100755 index 6e37a2cf81..0000000000 --- a/util/ush/xlf_links.sh +++ /dev/null @@ -1,13 +0,0 @@ -set -a - -num=1;>xlflnk - -while [ $num -le 99 ] -do -echo "[ -n \"\$XLFUNIT_$num\" ] && ln -sf \$XLFUNIT_$num fort.$num" >>xlflnk -num=`expr $num + 1` -done - -chmod +x xlflnk; ./xlflnk; rm xlflnk -echo; echo `date` links.sh produced the following soft links: -echo; ls -ln fort.*; echo