diff --git a/CMakeLists.txt b/CMakeLists.txt index 372ecd09..9f010c9f 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -11,33 +11,17 @@ list(APPEND _stoch_phys_srcs kinddef.F90 mpi_wrapper.F90 halo_exchange.fv3.F90 - plumes.f90 - four_to_grid_stochy.F - fftpack_stochy.f - glats_stochy.f - sumfln_stochy.f - gozrineo_stochy.f - num_parthds_stochy.f - get_ls_node_stochy.f - get_lats_node_a_stochy.f - setlats_a_stochy.f - setlats_lag_stochy.f - epslon_stochy.f - getcon_lag_stochy.f - pln2eo_stochy.f - dozeuv_stochy.f - dezouv_stochy.f - mersenne_twister.F - spectral_layout.F90 - getcon_spectral.F90 + plumes.F90 + mersenne_twister.F90 + random_numbers.F90 stochy_namelist_def.F90 compns_stochy.F90 stochy_internal_state_mod.F90 + spectral_transforms.F90 stochastic_physics.F90 stochy_patterngenerator.F90 stochy_data_mod.F90 get_stochy_pattern.F90 - initialize_spectral_mod.F90 cellular_automata_global.F90 cellular_automata_sgs.F90 update_ca.F90 diff --git a/atmosphere_stub.F90 b/atmosphere_stub.F90 deleted file mode 100644 index c9aa37a7..00000000 --- a/atmosphere_stub.F90 +++ /dev/null @@ -1,780 +0,0 @@ -module atmosphere_stub_mod - -#include - -!----------------- -! FMS modules: -!----------------- -use time_manager_mod, only: time_type, get_time, set_time, operator(+), & - operator(-), operator(/), time_type_to_real -use fms_mod, only: file_exist, open_namelist_file, & - close_file, error_mesg, FATAL, & - check_nml_error, stdlog, & - write_version_number, & - set_domain, & - read_data, & - mpp_clock_id, mpp_clock_begin, & - mpp_clock_end, CLOCK_SUBCOMPONENT, & - clock_flag_default, nullify_domain -use mpp_mod, only: mpp_error, stdout, FATAL, NOTE, & - input_nml_file, mpp_root_pe, & - mpp_npes, mpp_pe, mpp_chksum, & - mpp_get_current_pelist, & - mpp_set_current_pelist -use mpp_parameter_mod, only: EUPDATE, WUPDATE, SUPDATE, NUPDATE -use mpp_domains_mod, only: domain2d, mpp_update_domains -use xgrid_mod, only: grid_box_type - -!----------------- -! FV core modules: -!----------------- -use fv_arrays_mod, only: fv_atmos_type,fv_grid_bounds_type,fv_grid_type -use fv_control_stub_mod, only: fv_init, ngrids -use fv_timing_mod, only: timing_on, timing_off -use fv_sg_mod, only: fv_subgrid_z -use fv_update_phys_mod, only: fv_update_phys -use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_compute_domain -use tp_core_mod, only: copy_corners -use a2b_edge_mod, only: a2b_ord4 - -implicit none -private - -!--- driver routines -public :: atmosphere_init_stub - -!--- utility routines -!public :: atmosphere_return_winds, atmosphere_smooth_noise -public :: atmosphere_resolution,atmosphere_domain,& - atmosphere_scalar_field_halo,atmosphere_control_data - -!--- physics/radiation data exchange routines - -!----------------------------------------------------------------------- -! version number of this module -! Include variable "version" to be written to log file. -#include -character(len=20) :: mod_name = 'fvGFS/atmosphere_mod' - -!---- private data ---- - public Atm, mytile - - !These are convenience variables for local use only, and are set to values in Atm% - real :: dt_atmos - integer :: npx, npy, npz, ncnst, pnats - integer :: isc, iec, jsc, jec - integer :: isd, ied, jsd, jed - integer :: sec, seconds, days - integer :: id_dynam, id_fv_diag, id_subgridz - - - integer :: mytile = 1 - integer :: p_split = 1 - integer, allocatable :: pelist(:) - logical, allocatable :: grids_on_this_pe(:) - type(fv_atmos_type), allocatable, target :: Atm(:) - - integer :: id_udt_dyn, id_vdt_dyn - - -!---dynamics tendencies for use in fv_subgrid_z and during fv_update_phys - real, allocatable, dimension(:,:,:) :: u_dt, v_dt, t_dt - real, allocatable :: pref(:,:), dum1d(:) - - logical :: first_diag = .true. - -contains - - -!>@brief The subroutine 'atmosphere_init' is an API to initialize the FV3 dynamical core, -!! including the grid structures, memory, initial state (self-initialization or restart), -!! and diagnostics. - subroutine atmosphere_init_stub (Grid_box, area) - type(grid_box_type), intent(inout) :: Grid_box - real*8, pointer, dimension(:,:), intent(inout) :: area -!--- local variables --- - integer :: i, n - - call timing_on('ATMOS_INIT') - allocate(pelist(mpp_npes())) - call mpp_get_current_pelist(pelist) - - -!---- compute physics/atmos time step in seconds ---- - - dt_atmos = real(sec) - - call fv_init( Atm, dt_atmos, grids_on_this_pe, p_split ) ! allocates Atm components - - do n=1,ngrids - if (grids_on_this_pe(n)) mytile = n - enddo - - npx = Atm(mytile)%npx - npy = Atm(mytile)%npy - npz = Atm(mytile)%npz - ncnst = Atm(mytile)%ncnst - pnats = Atm(mytile)%flagstruct%pnats - - isc = Atm(mytile)%bd%isc - iec = Atm(mytile)%bd%iec - jsc = Atm(mytile)%bd%jsc - jec = Atm(mytile)%bd%jec - - isd = isc - Atm(mytile)%bd%ng - ied = iec + Atm(mytile)%bd%ng - jsd = jsc - Atm(mytile)%bd%ng - jed = jec + Atm(mytile)%bd%ng - - - - ! Allocate grid variables to be used to calculate gradient in 2nd order flux exchange - ! This data is only needed for the COARSEST grid. - - allocate(Grid_box%dx ( isc:iec , jsc:jec+1)) - allocate(Grid_box%dy ( isc:iec+1, jsc:jec )) - allocate(Grid_box%area ( isc:iec , jsc:jec )) - allocate(Grid_box%edge_w( jsc:jec+1)) - allocate(Grid_box%edge_e( jsc:jec+1)) - allocate(Grid_box%edge_s( isc:iec+1 )) - allocate(Grid_box%edge_n( isc:iec+1 )) - allocate(Grid_box%en1 (3, isc:iec , jsc:jec+1)) - allocate(Grid_box%en2 (3, isc:iec+1, jsc:jec )) - allocate(Grid_box%vlon (3, isc:iec , jsc:jec )) - allocate(Grid_box%vlat (3, isc:iec , jsc:jec )) - Grid_box%dx ( isc:iec , jsc:jec+1) = Atm(mytile)%gridstruct%dx ( isc:iec, jsc:jec+1) - Grid_box%dy ( isc:iec+1, jsc:jec ) = Atm(mytile)%gridstruct%dy ( isc:iec+1, jsc:jec ) - Grid_box%area ( isc:iec , jsc:jec ) = Atm(mytile)%gridstruct%area ( isc:iec , jsc:jec ) - Grid_box%edge_w( jsc:jec+1) = Atm(mytile)%gridstruct%edge_w( jsc:jec+1) - Grid_box%edge_e( jsc:jec+1) = Atm(mytile)%gridstruct%edge_e( jsc:jec+1) - Grid_box%edge_s( isc:iec+1 ) = Atm(mytile)%gridstruct%edge_s( isc:iec+1) - Grid_box%edge_n( isc:iec+1 ) = Atm(mytile)%gridstruct%edge_n( isc:iec+1) - Grid_box%en1 (:, isc:iec , jsc:jec+1) = Atm(mytile)%gridstruct%en1 (:, isc:iec , jsc:jec+1) - Grid_box%en2 (:, isc:iec+1, jsc:jec ) = Atm(mytile)%gridstruct%en2 (:, isc:iec+1, jsc:jec ) - do i = 1,3 - Grid_box%vlon(i, isc:iec , jsc:jec ) = Atm(mytile)%gridstruct%vlon (isc:iec , jsc:jec, i ) - Grid_box%vlat(i, isc:iec , jsc:jec ) = Atm(mytile)%gridstruct%vlat (isc:iec , jsc:jec, i ) - enddo - allocate (area(isc:iec , jsc:jec )) - area(isc:iec,jsc:jec) = Atm(mytile)%gridstruct%area_64(isc:iec,jsc:jec) - - - call set_domain ( Atm(mytile)%domain ) - -!----- initialize atmos_axes and fv_dynamics diagnostics - !I've had trouble getting this to work with multiple grids at a time; worth revisiting? -! --- initialize clocks for dynamics, physics_down and physics_up - id_dynam = mpp_clock_id ('FV dy-core', flags = clock_flag_default, grain=CLOCK_SUBCOMPONENT ) - id_fv_diag = mpp_clock_id ('FV Diag', flags = clock_flag_default, grain=CLOCK_SUBCOMPONENT ) - - call timing_off('ATMOS_INIT') - - - end subroutine atmosphere_init_stub - -! subroutine atmosphere_smooth_noise (wnoise,npass,ns_type,renorm_type) -! -! !--- interface variables --- -! real,intent(inout) :: wnoise(isd:ied,jsd:jed,1) -! integer, intent(in) :: npass,ns_type,renorm_type -! !--- local variables -! integer:: i,j,nloops,nlast -! real ::inflation(isc:iec,jsc:jec),inflation2 -! ! scale factor for restoring inflation -! ! logic: -! ! if box mean: scalar get basic scaling, vector gets 1/grid dependent scaling 0-0 ; 0 - 1 -! ! if box mean2: no scaling -! ! if del2 : scalar gets grid dependent scaling,vector get basic scaling 1 0; 1 1 -! if(npass.GT.0) then -! if (ns_type.NE.2) then -! if (ns_type.EQ. 0) then -! !inflation2=1.0/sqrt(1.0/(4.0*npass)) -! inflation2=1.0/sqrt(1.0/(9.0*npass)) -! else -! inflation2=1.0/sqrt(1.0/(11.0/3.0*npass)) -! endif -! if ( ns_type.EQ.1) then ! del2 smoothing needs to be scaled by grid-size -! do j=jsc,jec -! do i=isc,iec -! inflation(i,j)=inflation2*Atm(mytile)%gridstruct%dxAV/(0.5*(Atm(mytile)%gridstruct%dx(i,j)+Atm(mytile)%gridstruct%dy(i,j))) -! enddo -! enddo -! else -! if ( renorm_type.EQ.1) then ! box smooth does not need scaling for scalar -! do j=jsc,jec -! do i=isc,iec -! inflation(i,j)=inflation2 -! enddo -! enddo -! else -! ! box mean needs inversize grid-size scaling for vector -! do j=jsc,jec -! do i=isc,iec -! inflation(i,j)=inflation2*(0.5*(Atm(mytile)%gridstruct%dx(i,j)+Atm(mytile)%gridstruct%dy(i,j)))/Atm(mytile)%gridstruct%dxAV -! enddo -! enddo -! endif -! endif -! endif -! nloops=npass/3 -! nlast=mod(npass,3) -! do j=1,nloops -! if (ns_type.EQ.1) then -! !call del2_cubed(wnoise , 0.25*Atm(mytile)%gridstruct%da_min, Atm(mytile)%gridstruct, & -! call del2_cubed(wnoise , 0.20*Atm(mytile)%gridstruct%da_min, Atm(mytile)%gridstruct, & -! Atm(mytile)%domain, npx, npy, 1, 3, Atm(mytile)%bd) -! else if (ns_type .EQ. 0) then -! call box_mean(wnoise , Atm(mytile)%gridstruct, Atm(mytile)%domain, Atm(mytile)%npx, Atm(mytile)%npy, 1, 3, Atm(mytile)%bd) -! else if (ns_type .EQ. 2) then -! call box_mean2(wnoise , Atm(mytile)%gridstruct, Atm(mytile)%domain, Atm(mytile)%npx, Atm(mytile)%npy, 1, 3, Atm(mytile)%bd) -! endif -! enddo -! if(nlast>0) then -! if (ns_type.EQ.1) then -! !call del2_cubed(wnoise , 0.25*Atm(mytile)%gridstruct%da_min, Atm(mytile)%gridstruct, & -! call del2_cubed(wnoise , 0.20*Atm(mytile)%gridstruct%da_min, Atm(mytile)%gridstruct, & -! Atm(mytile)%domain, npx, npy, 1, nlast, Atm(mytile)%bd) -! else if (ns_type .EQ. 0) then -! call box_mean(wnoise , Atm(mytile)%gridstruct, Atm(mytile)%domain, Atm(mytile)%npx, Atm(mytile)%npy, 1, nlast, Atm(mytile)%bd) -! else if (ns_type .EQ. 2) then -! call box_mean2(wnoise , Atm(mytile)%gridstruct, Atm(mytile)%domain, Atm(mytile)%npx, Atm(mytile)%npy, 1, nlast, Atm(mytile)%bd) -! endif -! endif -! ! restore amplitude -! if (ns_type.NE.2) then -! do j=jsc,jec -! do i=isc,iec -! wnoise(i,j,1)=wnoise(i,j,1)*inflation(i,j) -! enddo -! enddo -! endif -! endif -! end subroutine atmosphere_smooth_noise - -! subroutine atmosphere_return_winds (psi,ua,va,edge,km,vwts) -! integer,intent(in) :: edge -! real,intent(inout) :: psi(isd:ied,jsd:jed) -! real,intent(inout) :: ua(isc:iec+edge,jsc:jec) -! real,intent(inout) :: va(isc:iec,jsc:jec+edge) -! integer, optional,intent(in):: km -! real, optional,intent(in):: vwts(:) -! integer :: k -! call timing_on('COMM_TOTAL') -! call mpp_update_domains(psi, Atm(mytile)%domain, complete=.true.) -! call timing_off('COMM_TOTAL') -! if (edge.EQ.0) then -! call make_a_winds(ua, va, psi,Atm(mytile)%ng,Atm(mytile)%gridstruct,Atm(mytile)%bd,Atm(mytile)%npx,Atm(mytile)%npy) -! endif -! if (edge.EQ.1) then -! call make_c_winds(ua, va, psi,Atm(mytile)%ng,Atm(mytile)%gridstruct,Atm(mytile)%bd,Atm(mytile)%npx,Atm(mytile)%npy) -!! populate wind perturbations right here -! do k=1,km -! Atm(mytile)%urandom_c(isc:iec+edge,jsc:jec ,k)=ua*vwts(k) -! Atm(mytile)%vrandom_c(isc:iec ,jsc:jec+edge,k)=va*vwts(k) -! enddo -! !call mpp_update_domains(Atm(mytile)%urandom_c, Atm(mytile)%domain, complete=.true.) -! !call mpp_update_domains(Atm(mytile)%vrandom_c, Atm(mytile)%domain, complete=.true.) -! endif -! end subroutine atmosphere_return_winds -! - subroutine del2_cubed(q, cd, gridstruct, domain, npx, npy, km, nmax, bd) - !--------------------------------------------------------------- - ! This routine is for filtering the omega field for the physics - !--------------------------------------------------------------- - integer, intent(in):: npx, npy, km, nmax - real(kind=8), intent(in):: cd !< cd = K * da_min; 0 < K < 0.25 - type(fv_grid_bounds_type), intent(IN) :: bd - real, intent(inout):: q(bd%isd:bd%ied,bd%jsd:bd%jed,km) - type(fv_grid_type), intent(IN), target :: gridstruct - type(domain2d), intent(INOUT) :: domain - real, parameter:: r3 = 1./3. - real :: fx(bd%isd:bd%ied+1,bd%jsd:bd%jed), fy(bd%isd:bd%ied,bd%jsd:bd%jed+1) - real :: q2(bd%isd:bd%ied,bd%jsd:bd%jed) - integer i,j,k, n, nt, ntimes - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - !Local routine pointers -! real, pointer, dimension(:,:) :: rarea -! real, pointer, dimension(:,:) :: del6_u, del6_v -! logical, pointer :: sw_corner, se_corner, ne_corner, nw_corner - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - ntimes = min(3, nmax) - - call timing_on('COMM_TOTAL') - call mpp_update_domains(q, domain, complete=.true.) - call timing_off('COMM_TOTAL') - - - do n=1,ntimes - nt = ntimes - n - -!$OMP parallel do default(none) shared(km,q,is,ie,js,je,npx,npy, & -!$OMP nt,isd,jsd,gridstruct,bd, & -!$OMP cd) & -!$OMP private(fx, fy) - do k=1,km - - if ( gridstruct%sw_corner ) then - q(1,1,k) = (q(1,1,k)+q(0,1,k)+q(1,0,k)) * r3 - q(0,1,k) = q(1,1,k) - q(1,0,k) = q(1,1,k) - endif - if ( gridstruct%se_corner ) then - q(ie, 1,k) = (q(ie,1,k)+q(npx,1,k)+q(ie,0,k)) * r3 - q(npx,1,k) = q(ie,1,k) - q(ie, 0,k) = q(ie,1,k) - endif - if ( gridstruct%ne_corner ) then - q(ie, je,k) = (q(ie,je,k)+q(npx,je,k)+q(ie,npy,k)) * r3 - q(npx,je,k) = q(ie,je,k) - q(ie,npy,k) = q(ie,je,k) - endif - if ( gridstruct%nw_corner ) then - q(1, je,k) = (q(1,je,k)+q(0,je,k)+q(1,npy,k)) * r3 - q(0, je,k) = q(1,je,k) - q(1,npy,k) = q(1,je,k) - endif - - if(nt>0 .and. (.not. gridstruct%regional)) call copy_corners(q(isd,jsd,k), npx, npy, 1, gridstruct%nested, bd, & - gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner ) - do j=js-nt,je+nt - do i=is-nt,ie+1+nt -#ifdef USE_SG - fx(i,j) = gridstruct%dy(i,j)*gridstruct%sina_u(i,j)*(q(i-1,j,k)-q(i,j,k))*gridstruct%rdxc(i,j) -#else - fx(i,j) = gridstruct%del6_v(i,j)*(q(i-1,j,k)-q(i,j,k)) -#endif - enddo - enddo - - if(nt>0 .and. (.not. gridstruct%regional)) call copy_corners(q(isd,jsd,k), npx, npy, 2, gridstruct%nested, bd, & - gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) - do j=js-nt,je+1+nt - do i=is-nt,ie+nt -#ifdef USE_SG - fy(i,j) = gridstruct%dx(i,j)*gridstruct%sina_v(i,j)*(q(i,j-1,k)-q(i,j,k))*gridstruct%rdyc(i,j) -#else - fy(i,j) = gridstruct%del6_u(i,j)*(q(i,j-1,k)-q(i,j,k)) -#endif - enddo - enddo - - do j=js-nt,je+nt - do i=is-nt,ie+nt - q(i,j,k) = q(i,j,k) + cd*gridstruct%rarea(i,j)*(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1)) - enddo - enddo - enddo - enddo - - end subroutine del2_cubed - -!>@brief The subroutine 'box_mean' filters a field with a 9-point mean stencil - - subroutine box_mean(q, gridstruct, domain, npx, npy, km, nmax, bd) - !--------------------------------------------------------------- - ! This routine is for filtering the omega field for the physics - !--------------------------------------------------------------- - integer, intent(in):: npx, npy, km, nmax - type(fv_grid_bounds_type), intent(IN) :: bd - real, intent(inout):: q(bd%isd:bd%ied,bd%jsd:bd%jed,km) - type(fv_grid_type), intent(IN), target :: gridstruct - type(domain2d), intent(INOUT) :: domain - real, parameter:: r3 = 1./3.,r9=1./9. - real :: q2(bd%isd:bd%ied,bd%jsd:bd%jed) - integer i,j,k, n, nt, ntimes - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - !Local routine pointers -! real, pointer, dimension(:,:) :: rarea -! real, pointer, dimension(:,:) :: del6_u, del6_v -! logical, pointer :: sw_corner, se_corner, ne_corner, nw_corner - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - ntimes = min(3, nmax) - - call timing_on('COMM_TOTAL') - call mpp_update_domains(q, domain, complete=.true.) - call timing_off('COMM_TOTAL') - - - do n=1,ntimes - nt = ntimes !- n - -!$OMP parallel do default(none) shared(km,is,ie,js,je,npx,npy, & -!$OMP q,nt,isd,jsd,gridstruct,bd) & -!$OMP private(q2) - do k=1,km - - if ( gridstruct%sw_corner ) then - q(1,1,k) = (q(1,1,k)+q(0,1,k)+q(1,0,k)) * r3 - q(0,1,k) = q(1,1,k) - q(1,0,k) = q(1,1,k) - endif - if ( gridstruct%se_corner ) then - q(ie, 1,k) = (q(ie,1,k)+q(npx,1,k)+q(ie,0,k)) * r3 - q(npx,1,k) = q(ie,1,k) - q(ie, 0,k) = q(ie,1,k) - endif - if ( gridstruct%ne_corner ) then - q(ie, je,k) = (q(ie,je,k)+q(npx,je,k)+q(ie,npy,k)) * r3 - q(npx,je,k) = q(ie,je,k) - q(ie,npy,k) = q(ie,je,k) - endif - if ( gridstruct%nw_corner ) then - q(1, je,k) = (q(1,je,k)+q(0,je,k)+q(1,npy,k)) * r3 - q(0, je,k) = q(1,je,k) - q(1,npy,k) = q(1,je,k) - endif - - if(nt>0) call copy_corners(q(isd,jsd,k), npx, npy, 1, gridstruct%nested, bd, & - gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner ) - - if(nt>0) call copy_corners(q(isd,jsd,k), npx, npy, 2, gridstruct%nested, bd, & - gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) - - !do j=js-nt,je+nt - ! do i=is-nt,ie+nt - do j=jsd+1,jed-1 - do i=isd+1,ied-1 - !q2(i,j) = (gridstruct%area(i-1,j+1)*q(i-1,j+1,k) + gridstruct%area(i,j+1)*q(i,j+1,k) + gridstruct%area(i+1,j+1)*q(i+1,j+1,k) +& - ! gridstruct%area(i-1,j )*q(i-1,j,k) + gridstruct%area(i,j )*q(i,j ,k) + gridstruct%area(i+1,j )*q(i+1,j ,k) +& - ! gridstruct%area(i-1,j-1)*q(i-1,j-1,k) + gridstruct%area(i,j-1)*q(i,j-1,k) + gridstruct%area(i+1,j-1)*q(i+1,j-1,k))/SUM(gridstruct%area(i-1:i+1,j-1:j+1)) - q2(i,j) = r9*(q(i-1,j+1,k)+q(i,j+1,k)+q(i+1,j+1,k)+q(i-1,j,k)+q(i,j,k)+q(i+1,j,k)+q(i-1,j-1,k)+q(i,j-1,k)+q(i+1,j-1,k)) - !if (j.GE. je .AND. i.GE. ie) print*,'area +1=',gridstruct%area(i-1:i+1,j+1) - !if (j.GE. je .AND. i.GE. ie) print*,'area =',gridstruct%area(i-1:i+1,j) - !if (j.GE. je .AND. i.GE. ie) print*,'area -1=',gridstruct%area(i-1:i+1,j-1) - !if (j.GE. je .AND. i.GE. ie) print*,'q +1=',q(i-1:i+1,j+1,k) - !if (j.GE. je .AND. i.GE. ie) print*,'q =',q(i-1:i+1,j,k) - !if (j.GE. je .AND. i.GE. ie) print*,'q -1=',q(i-1:i+1,j-1,k) - enddo - enddo - do j=js-nt,je+nt - do i=is-nt,ie+nt - q(i,j,k)=q2(i,j) - enddo - enddo - enddo - enddo - end subroutine box_mean - - subroutine box_mean2(q, gridstruct, domain, npx, npy, km, nmax, bd) - !--------------------------------------------------------------- - ! This routine is for filtering the omega field for the physics - !--------------------------------------------------------------- - integer, intent(in):: npx, npy, km, nmax - type(fv_grid_bounds_type), intent(IN) :: bd - real, intent(inout):: q(bd%isd:bd%ied,bd%jsd:bd%jed,km) - type(fv_grid_type), intent(IN), target :: gridstruct - type(domain2d), intent(INOUT) :: domain - real, parameter:: r3 = 1./3.,r10=0.1 - real :: q2(bd%isd:bd%ied,bd%jsd:bd%jed) - integer i,j,k, n, nt, ntimes - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - - !Local routine pointers -! real, pointer, dimension(:,:) :: rarea -! real, pointer, dimension(:,:) :: del6_u, del6_v -! logical, pointer :: sw_corner, se_corner, ne_corner, nw_corner - - is = bd%is - ie = bd%ie - js = bd%js - je = bd%je - isd = bd%isd - ied = bd%ied - jsd = bd%jsd - jed = bd%jed - - ntimes = min(3, nmax) - - call timing_on('COMM_TOTAL') - call mpp_update_domains(q, domain, complete=.true.) - call timing_off('COMM_TOTAL') - - - do n=1,ntimes - nt = ntimes !- n - -!$OMP parallel do default(none) shared(km,is,ie,js,je,npx,npy, & -!$OMP q,nt,isd,jsd,gridstruct,bd) & -!$OMP private(q2) - do k=1,km - - if ( gridstruct%sw_corner ) then - q(1,1,k) = (q(1,1,k)+q(0,1,k)+q(1,0,k)) * r3 - q(0,1,k) = q(1,1,k) - q(1,0,k) = q(1,1,k) - endif - if ( gridstruct%se_corner ) then - q(ie, 1,k) = (q(ie,1,k)+q(npx,1,k)+q(ie,0,k)) * r3 - q(npx,1,k) = q(ie,1,k) - q(ie, 0,k) = q(ie,1,k) - endif - if ( gridstruct%ne_corner ) then - q(ie, je,k) = (q(ie,je,k)+q(npx,je,k)+q(ie,npy,k)) * r3 - q(npx,je,k) = q(ie,je,k) - q(ie,npy,k) = q(ie,je,k) - endif - if ( gridstruct%nw_corner ) then - q(1, je,k) = (q(1,je,k)+q(0,je,k)+q(1,npy,k)) * r3 - q(0, je,k) = q(1,je,k) - q(1,npy,k) = q(1,je,k) - endif - - if(nt>0) call copy_corners(q(isd,jsd,k), npx, npy, 1, gridstruct%nested, bd, & - gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner ) - - if(nt>0) call copy_corners(q(isd,jsd,k), npx, npy, 2, gridstruct%nested, bd, & - gridstruct%sw_corner, gridstruct%se_corner, gridstruct%nw_corner, gridstruct%ne_corner) - - do j=jsd+1,jed-1 - do i=isd+1,ied-1 - q2(i,j) = r10*(q(i-1,j+1,k)+q(i,j+1,k)+q(i+1,j+1,k)+q(i-1,j,k)+2*q(i,j,k)+q(i+1,j,k)+q(i-1,j-1,k)+q(i,j-1,k)+q(i+1,j-1,k)) - enddo - enddo - do j=js-nt,je+nt - do i=is-nt,ie+nt - q(i,j,k)=q2(i,j) - enddo - enddo - enddo - enddo - - end subroutine box_mean2 -subroutine make_a_winds(ua, va, psi, ng, gridstruct, bd, npx, npy) - -integer, intent(IN) :: ng, npx, npy -type(fv_grid_bounds_type), intent(IN) :: bd -real, intent(inout) :: psi(bd%isd:bd%ied,bd%jsd:bd%jed) -real, intent(inout) :: ua(bd%isc:bd%iec ,bd%jsc:bd%jec ) -real, intent(inout) :: va(bd%isc:bd%iec ,bd%jsc:bd%jec ) -type(fv_grid_type), intent(IN), target :: gridstruct -! Local: -real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed) :: wk -real, dimension(bd%isc:bd%iec,bd%jsc:bd%jec) :: u,v -integer i,j - -integer :: is, ie, js, je -is = bd%is -ie = bd%ie -js = bd%js -je = bd%je - -call a2b_ord4( psi, wk, gridstruct, npx, npy, is, ie, js, je, ng, .false.) -do j=js,je - do i=is,ie - u(i,j) = gridstruct%rdy(i,j)*0.5*(wk(i,j+1)+wk(i+1,j+1)-(wk(i,j)+wk(i+1,j))) - enddo -enddo -do j=js,je - do i=is,ie - v(i,j) = gridstruct%rdx(i,j)*0.5*(wk(i,j)+wk(i,j+1)-(wk(i+1,j)+wk(i+1,j+1))) - enddo -enddo -do j=js,je - do i=is,ie - ua(i,j) = 0.5*(gridstruct%a11(i,j)+gridstruct%a11(i,j+1))*u(i,j) + 0.5*(gridstruct%a12(i,j)+gridstruct%a12(i,j+1))*v(i,j) - va(i,j) = 0.5*(gridstruct%a21(i,j)+gridstruct%a21(i+1,j))*u(i,j) + 0.5*(gridstruct%a22(i,j)+gridstruct%a22(i+1,j))*v(i,j) - enddo -enddo - -end subroutine make_a_winds - -subroutine make_c_winds(uc, vc, psi, ng, gridstruct, bd, npx, npy) - -integer, intent(IN) :: ng, npx, npy -type(fv_grid_bounds_type), intent(IN) :: bd -real, intent(inout) :: psi(bd%isd:bd%ied,bd%jsd:bd%jed) -real, intent(inout) :: uc(bd%isc:bd%iec+1 ,bd%jsc:bd%jec ) -real, intent(inout) :: vc(bd%isc:bd%iec ,bd%jsc:bd%jec+1) -type(fv_grid_type), intent(IN), target :: gridstruct -! Local: -real, dimension(bd%isd:bd%ied,bd%jsd:bd%jed) :: wk -real, dimension(bd%isc:bd%iec,bd%jsc:bd%jec) :: u,v -integer i,j - -integer :: is, ie, js, je -is = bd%is -ie = bd%ie -js = bd%js -je = bd%je - -call a2b_ord4( psi, wk, gridstruct, npx, npy, is, ie, js, je, ng, .false.) -do j=js,je - do i=is,ie+1 - uc(i,j) = gridstruct%rdy(i,j)*(wk(i,j+1)-wk(i,j)) - enddo -enddo -do j=js,je+1 - do i=is,ie - vc(i,j) = gridstruct%rdx(i,j)*(wk(i,j)-wk(i+1,j)) - enddo -enddo - -end subroutine make_c_winds - -!>@brief The subroutine 'atmospehre_resolution' is an API to return the local -!! extents of the current MPI-rank or the global extents of the current -!! cubed-sphere tile. - subroutine atmosphere_resolution (i_size, j_size, global) - integer, intent(out) :: i_size, j_size - logical, intent(in), optional :: global - logical :: local - - local = .true. - if( PRESENT(global) ) local = .NOT.global - - if( local ) then - i_size = iec - isc + 1 - j_size = jec - jsc + 1 - else - i_size = npx - 1 - j_size = npy - 1 - end if - end subroutine atmosphere_resolution -!>@brief The subroutine 'atmosphere_domain' is an API to return -!! the "domain2d" variable associated with the coupling grid and the -!! decomposition for the current cubed-sphere tile. -!>@detail Coupling is done using the mass/temperature grid with no halos. - subroutine atmosphere_domain ( fv_domain, layout, regional, nested, pelist ) - type(domain2d), intent(out) :: fv_domain - integer, intent(out) :: layout(2) - logical, intent(out) :: regional - logical, intent(out) :: nested - integer, pointer, intent(out) :: pelist(:) -! returns the domain2d variable associated with the coupling grid -! note: coupling is done using the mass/temperature grid with no halos - - fv_domain = Atm(mytile)%domain_for_coupler - layout(1:2) = Atm(mytile)%layout(1:2) - regional = Atm(mytile)%flagstruct%regional - nested = ngrids > 1 - call set_atmosphere_pelist() - pelist => Atm(mytile)%pelist - - end subroutine atmosphere_domain - - subroutine set_atmosphere_pelist () - call mpp_set_current_pelist(Atm(mytile)%pelist, no_sync=.TRUE.) - end subroutine set_atmosphere_pelist - - -!>@brief The subroutine 'atmosphere_scalar_field_halo' is an API to return halo information -!! of the current MPI_rank for an input scalar field. -!>@detail Up to three point haloes can be returned by this API which includes special handling for -!! the cubed-sphere tile corners. Output will be in (i,j,k) while input can be in (i,j,k) or -!! horizontally-packed form (ix,k). - subroutine atmosphere_scalar_field_halo (data, halo, isize, jsize, ksize, data_p) - !-------------------------------------------------------------------- - ! data - output array to return the field with halo (i,j,k) - ! optionally input for field already in (i,j,k) form - ! sized to include the halo of the field (+ 2*halo) - ! halo - size of the halo (must be less than 3) - ! ied - horizontal resolution in i-dir with haloes - ! jed - horizontal resolution in j-dir with haloes - ! ksize - vertical resolution - ! data_p - optional input field in packed format (ix,k) - !-------------------------------------------------------------------- - !--- interface variables --- - real*8, dimension(1:isize,1:jsize,ksize), intent(inout) :: data !< output array to return the field with halo (i,j,k) - !< optionally input for field already in (i,j,k) form - !< sized to include the halo of the field (+ 2*halo) - integer, intent(in) :: halo !< size of the halo (must be less than 3) - integer, intent(in) :: isize !< horizontal resolution in i-dir with haloes - integer, intent(in) :: jsize !< horizontal resolution in j-dir with haloes - integer, intent(in) :: ksize !< vertical resolution - real*8, dimension(:,:), optional, intent(in) :: data_p !< optional input field in packed format (ix,k) - !--- local variables --- - integer :: i, j, k - integer :: ic, jc - character(len=44) :: modname = 'atmosphere_mod::atmosphere_scalar_field_halo' - integer :: mpp_flags - - !--- perform error checking - if (halo .gt. 3) call mpp_error(FATAL, modname//' - halo.gt.3 requires extending the MPP domain to support') - ic = isize - 2 * halo - jc = jsize - 2 * halo - - !--- if packed data is present, unpack it into the two-dimensional data array - if (present(data_p)) then - if (ic*jc .ne. size(data_p,1)) call mpp_error(FATAL, modname//' - incorrect sizes for incoming & - &variables data and data_p') - data = 0. -!$OMP parallel do default (none) & -!$OMP shared (data, data_p, halo, ic, jc, ksize) & -!$OMP private (i, j, k) - do k = 1, ksize - do j = 1, jc - do i = 1, ic - data(i+halo, j+halo, k) = data_p(i + (j-1)*ic, k) - enddo - enddo - enddo - endif - - mpp_flags = EUPDATE + WUPDATE + SUPDATE + NUPDATE - if (halo == 1) then - call mpp_update_domains(data, Atm(mytile)%domain_for_coupler, flags=mpp_flags, complete=.true.) - elseif (halo == 3) then - call mpp_update_domains(data, Atm(mytile)%domain, flags=mpp_flags, complete=.true.) - else - call mpp_error(FATAL, modname//' - unsupported halo size') - endif - - !--- fill the halo points when at a corner of the cubed-sphere tile - !--- interior domain corners are handled correctly - if ( (isc==1) .or. (jsc==1) .or. (iec==npx-1) .or. (jec==npy-1) ) then - do k = 1, ksize - do j=1,halo - do i=1,halo - if ((isc== 1) .and. (jsc== 1)) data(halo+1-j ,halo+1-i ,k) = data(halo+i ,halo+1-j ,k) !SW Corner - if ((isc== 1) .and. (jec==npy-1)) data(halo+1-j ,halo+jc+i,k) = data(halo+i ,halo+jc+j,k) !NW Corner - if ((iec==npx-1) .and. (jsc== 1)) data(halo+ic+j,halo+1-i ,k) = data(halo+ic-i+1,halo+1-j ,k) !SE Corner - if ((iec==npx-1) .and. (jec==npy-1)) data(halo+ic+j,halo+jc+i,k) = data(halo+ic-i+1,halo+jc+j,k) !NE Corner - enddo - enddo - enddo - endif - - return - end subroutine atmosphere_scalar_field_halo - - - subroutine atmosphere_control_data (i1, i2, j1, j2, kt, p_hydro, hydro, tile_num) - integer, intent(out) :: i1, i2, j1, j2, kt - logical, intent(out), optional :: p_hydro, hydro - integer, intent(out), optional :: tile_num - i1 = Atm(mytile)%bd%isc - i2 = Atm(mytile)%bd%iec - j1 = Atm(mytile)%bd%jsc - j2 = Atm(mytile)%bd%jec - kt = Atm(mytile)%npz - - if (present(tile_num)) tile_num = Atm(mytile)%tile - if (present(p_hydro)) p_hydro = Atm(mytile)%flagstruct%phys_hydrostatic - if (present( hydro)) hydro = Atm(mytile)%flagstruct%hydrostatic - - end subroutine atmosphere_control_data - -end module atmosphere_stub_mod diff --git a/cellular_automata_global.F90 b/cellular_automata_global.F90 index bbc28d0e..a815aaef 100644 --- a/cellular_automata_global.F90 +++ b/cellular_automata_global.F90 @@ -1,72 +1,73 @@ module cellular_automata_global_mod +use update_ca, only : domain_global,iscnx_g,iecnx_g,jscnx_g,jecnx_g,isdnx_g,iednx_g,jsdnx_g,jednx_g, & + nxncells_g,nyncells_g,csum implicit none contains -subroutine cellular_automata_global(kstep,first_time_step,ca1_cpl,ca2_cpl,ca3_cpl,ca1_diag,ca2_diag,ca3_diag, & - domain_for_coupler,nblks,isc,iec,jsc,jec,npx,npy,nlev, & - nca,ncells,nlives,nfracseed,nseed,ca_global,ca_sgs,iseed_ca, & +subroutine cellular_automata_global(kstep,restart,first_time_step,ca1_cpl,ca2_cpl,ca3_cpl, & + domain_in,nblks,isc,iec,jsc,jec,npx,npy,nlev, & + nca,ncells,nlives,nfracseed,nseed,iseed_ca, mytile, & ca_smooth,nspinup,blocksize,nsmooth,ca_amplitude,mpiroot,mpicomm) -use kinddef, only: kind_phys -use update_ca, only: update_cells_sgs, update_cells_global,define_ca_domain +use kinddef, only: kind_dbl_prec +use update_ca, only: update_cells_global,define_ca_domain use halo_exchange, only: atmosphere_scalar_field_halo -use mersenne_twister, only: random_setseed,random_gauss,random_stat,random_number -use mpp_domains_mod, only: domain2D +use random_numbers, only: random_01_CB +use mpp_domains_mod, only: domain2D,mpp_get_global_domain,CENTER, mpp_get_data_domain, mpp_get_compute_domain,mpp_global_sum, & + BITWISE_EFP_SUM, BITWISE_EXACT_SUM use block_control_mod, only: block_control_type, define_blocks_packed -use mpi_wrapper, only: mype,mp_reduce_sum,mp_bcst,mp_reduce_max,mp_reduce_min, & - mpi_wrapper_initialize -use mpp_domains_mod -use mpp_mod +use mpi_wrapper, only: mp_reduce_sum,mp_reduce_max,mp_reduce_min, & + mpi_wrapper_initialize,mype,is_rootpe implicit none !L.Bengtsson, 2017-06 +!P.Pegion, 2021-09 +! swtich to new random number generator and improve computational efficiency +! and remove unsued code. Also add restart capability ca_global -!This program evolves a cellular automaton uniform over the globe given -!the flag ca_global +!This program evolves a cellular automaton uniform over the globe integer, intent(in) :: kstep,ncells,nca,nlives,nseed,nspinup,nsmooth,mpiroot,mpicomm -integer, intent(in) :: iseed_ca -real(kind=kind_phys), intent(in) :: nfracseed,ca_amplitude -logical, intent(in) :: ca_global, ca_sgs, ca_smooth,first_time_step +integer(kind=kind_dbl_prec), intent(in) :: iseed_ca +integer, intent(in) :: mytile +real(kind=kind_dbl_prec), intent(in) :: nfracseed,ca_amplitude +logical, intent(in) :: ca_smooth,first_time_step, restart integer, intent(in) :: nblks,isc,iec,jsc,jec,npx,npy,nlev,blocksize -real(kind=kind_phys), intent(out) :: ca1_cpl(:,:),ca2_cpl(:,:),ca3_cpl(:,:) -real(kind=kind_phys), intent(out) :: ca1_diag(:,:),ca2_diag(:,:),ca3_diag(:,:) -type(domain2D), intent(inout) :: domain_for_coupler -type(domain2D) :: domain_ncellx +real(kind=kind_dbl_prec), intent(out) :: ca1_cpl(:,:),ca2_cpl(:,:),ca3_cpl(:,:) +type(domain2D), intent(inout) :: domain_in type(block_control_type) :: Atm_block -type(random_stat) :: rstate integer :: nlon, nlat, isize,jsize,nf,nn integer :: inci, incj, nxc, nyc, nxch, nych integer :: halo, k_in, i, j, k integer :: seed, ierr7,blk, ix, iix, count4,ih,jh integer :: blocksz,levs -integer :: isdnx,iednx,jsdnx,jednx -integer :: iscnx,iecnx,jscnx,jecnx +integer,save :: isdnx,iednx,jsdnx,jednx +integer,save :: iscnx,iecnx,jscnx,jecnx integer :: nxncells, nyncells -integer(8) :: count, count_rate, count_max, count_trunc +integer(8) :: count, count_rate, count_max, count_trunc,nx_full integer(8) :: iscale = 10000000000 integer, allocatable :: iini_g(:,:,:),ilives_g(:,:) -real(kind=kind_phys), allocatable :: field_out(:,:,:), field_smooth(:,:) -real(kind=kind_phys), allocatable :: CA(:,:),CA1(:,:),CA2(:,:),CA3(:,:) -real(kind=kind_phys), allocatable :: noise1D(:),noise(:,:,:) -real(kind=kind_phys) :: psum,csum,CAmean,sq_diff,CAstdv -real(kind=kind_phys) :: Detmax(nca),Detmin(nca),Detmean(nca) +real(kind=kind_dbl_prec), allocatable :: field_out(:,:,:), field_smooth(:,:) +real(kind=kind_dbl_prec), allocatable :: CA(:,:),CA1(:,:),CA2(:,:),CA3(:,:),CAprime(:,:) +real*8 , allocatable :: noise(:,:,:) +real*8 :: psum,CAmean,sq_diff,CAstdv,inv9 +real*8 :: Detmax,Detmin logical,save :: block_message=.true. +integer*8 :: i1,j1 +integer :: ct !nca :: switch for number of cellular automata to be used. -!ca_global :: switch for global cellular automata -!ca_sgs :: switch for cellular automata conditioned on physics. !nfracseed :: switch for number of random cells initially seeded !nlives :: switch for maximum number of lives a cell can have !nspinup :: switch for number of itterations to spin up the ca !ncells :: switch for higher resolution grid e.g ncells=4 ! gives 4x4 times the FV3 model grid resolution. !ca_smooth :: switch to smooth the cellular automata - +if (nca .LT. 1) return ! Initialize MPI and OpenMP if (first_time_step) then call mpi_wrapper_initialize(mpiroot,mpicomm) @@ -83,19 +84,10 @@ subroutine cellular_automata_global(kstep,first_time_step,ca1_cpl,ca2_cpl,ca3_cp ! Some security checks for namelist combinations: if(nca > 3)then - write(0,*)'Namelist option nca cannot be larger than 3 - exiting' - stop + write(0,*)'Namelist option nca cannot be larger than 3 - exiting' + stop endif -! if(ca_global == .true. .and. ca_sgs == .true.)then -! write(0,*)'Namelist options ca_global and ca_sgs cannot both be true - exiting' -! stop -! endif - -! if(ca_sgs == .true. .and. ca_smooth == .true.)then -! write(0,*)'Currently ca_smooth does not work with ca_sgs - exiting' -! stop -! endif nlon=iec-isc+1 nlat=jec-jsc+1 @@ -105,18 +97,23 @@ subroutine cellular_automata_global(kstep,first_time_step,ca1_cpl,ca2_cpl,ca3_cp inci=ncells incj=ncells - + !--- get params from domain_ncellx for building board and board_halo !Get CA domain - - call define_ca_domain(domain_for_coupler,domain_ncellx,ncells,nxncells,nyncells) - call mpp_get_data_domain (domain_ncellx,isdnx,iednx,jsdnx,jednx) - call mpp_get_compute_domain (domain_ncellx,iscnx,iecnx,jscnx,jecnx) - nxc = iecnx-iscnx+1 - nyc = jecnx-jscnx+1 - nxch = iednx-isdnx+1 - nych = jednx-jsdnx+1 + if(first_time_step)then +! if (.not. restart) call define_ca_domain(domain_in,domain_global,ncells,nxncells_g,nyncells_g) + domain_global=domain_in + call mpp_get_data_domain (domain_global,isdnx_g,iednx_g,jsdnx_g,jednx_g) + call mpp_get_compute_domain (domain_global,iscnx_g,iecnx_g,jscnx_g,jecnx_g) + endif + + nxc = iecnx_g-iscnx_g+1 + nyc = jecnx_g-jscnx_g+1 + nxch = iednx_g-isdnx_g+1 + nych = jednx_g-jsdnx_g+1 + inv9=1.0/9.0 + if(first_time_step) csum=int(6*(npx-1),kind=8)*int((npx-1),kind=8) !Allocate fields: @@ -125,16 +122,16 @@ subroutine cellular_automata_global(kstep,first_time_step,ca1_cpl,ca2_cpl,ca3_cp allocate(iini_g(nxc,nyc,nca)) allocate(ilives_g(nxc,nyc)) allocate(CA(nlon,nlat)) + allocate(CAprime(nlon,nlat)) allocate(CA1(nlon,nlat)) allocate(CA2(nlon,nlat)) allocate(CA3(nlon,nlat)) allocate(noise(nxc,nyc,nca)) - allocate(noise1D(nxc*nyc)) + nx_full=int(npx-1,kind=8) !Initialize: noise(:,:,:) = 0.0 - noise1D(:) = 0.0 iini_g(:,:,:) = 0 ilives_g(:,:) = 0 CA1(:,:) = 0.0 @@ -149,189 +146,150 @@ subroutine cellular_automata_global(kstep,first_time_step,ca1_cpl,ca2_cpl,ca3_cp call define_blocks_packed('cellular_automata', Atm_block, isc, iec, jsc, jec, levs, & blocksz, block_message) -if(first_time_step)then -!Generate random number, following stochastic physics code: - - if (iseed_ca == 0) then - ! generate a random seed from system clock and ens member number - call system_clock(count, count_rate, count_max) - ! iseed is elapsed time since unix epoch began (secs) - ! truncate to 4 byte integer - count_trunc = iscale*(count/iscale) - count4 = count - count_trunc - else if (iseed_ca > 0) then - ! don't rely on compiler to truncate integer(8) to integer(4) on - ! overflow, do wrap around explicitly. - count4 = mod(mype + iseed_ca + 2147483648, 4294967296) - 2147483648 - endif - - call random_setseed(count4,rstate) - do nf=1,nca - !Set seed (to be different) on all tasks. Save random state. - call random_number(noise1D,rstate) - !Put on 2D: - do j=1,nyc - do i=1,nxc - noise(i,j,nf)=noise1D(i+(j-1)*nxc) - enddo + do j=1,nyc + j1=j+(jsc-1)*ncells + do i=1,nxc + i1=i+(isc-1)*ncells + if (iseed_ca <= 0) then + ! generate a random seed from system clock and ens member number + call system_clock(count, count_rate, count_max) + ! iseed is elapsed time since unix epoch began (secs) + ! truncate to 4 byte integer + count_trunc = iscale*(count/iscale) + count4 = count - count_trunc + mytile *( i1+nx_full*(j1-1)) ! no need to multply by 7 since time will be different in sgs + else + ! don't rely on compiler to truncate integer(8) to integer(4) on + ! overflow, do wrap around explicitly. + count4 = mod(((iseed_ca+7)*mytile)*(i1+nx_full*(j1-1))+ 2147483648, 4294967296) - 2147483648 + endif + ct=1 + do nf=1,nca + noise(i,j,nf)=real(random_01_CB(ct*kstep,count4),kind=8) + ct=ct+1 + enddo enddo - enddo + enddo !Initiate the cellular automaton with random numbers larger than nfracseed - do nf=1,nca + do nf=1,nca do j = 1,nyc - do i = 1,nxc - if (noise(i,j,nf) > nfracseed ) then - iini_g(i,j,nf)=1 - else - iini_g(i,j,nf)=0 - endif - enddo + do i = 1,nxc + if (noise(i,j,nf) > nfracseed ) then + iini_g(i,j,nf)=1 + else + iini_g(i,j,nf)=0 + endif + enddo enddo - enddo !nf -endif ! + enddo !nf !In case we want to condition the cellular automaton on a large scale field !we here set the "condition" variable to a different model field depending !on nf. (this is not used if ca_global = .true.) - do nf=1,nca !update each ca - - do j = 1,nyc - do i = 1,nxc - ilives_g(i,j)=int(real(nlives)*1.5*noise(i,j,nf)) + do nf=1,nca !update each ca + do j = 1,nyc + do i = 1,nxc + ilives_g(i,j)=int(real(nlives)*1.5*noise(i,j,nf)) + enddo enddo - enddo - !Calculate neighbours and update the automata !If ca-global is used, then nca independent CAs are called and weighted together to create one field; CA - CA(:,:)=0. - - call update_cells_global(kstep,first_time_step,iseed_ca,nca,nxc,nyc,nxch,nych,nlon,nlat,nxncells,nyncells,isc,iec,jsc,jec, & - npx,npy,iscnx,iecnx,jscnx,jecnx,domain_ncellx,CA,iini_g,ilives_g, & - nlives,ncells,nfracseed,nseed,nspinup,nf) - - -if (ca_smooth) then - -do nn=1,nsmooth !number of iterations for the smoothing. - -field_out=0. -field_out(1+halo:nlon+halo,1+halo:nlat+halo,nf) = real(CA(1:nlon,1:nlat),kind=8) - -call atmosphere_scalar_field_halo(field_out,halo,isize,jsize,k_in,isc,iec,jsc,jec,npx,npy,domain_for_coupler) - -do j=1,nlat - do i=1,nlon - ih=i+halo - jh=j+halo - field_smooth(i,j)=(2.0*field_out(ih,jh,1)+2.0*field_out(ih-1,jh,1)+ & - 2.0*field_out(ih,jh-1,1)+2.0*field_out(ih+1,jh,1)+& - 2.0*field_out(ih,jh+1,1)+2.0*field_out(ih-1,jh-1,1)+& - 2.0*field_out(ih-1,jh+1,1)+2.0*field_out(ih+1,jh+1,1)+& - 2.0*field_out(ih+1,jh-1,1))/18. - enddo -enddo - -do j=1,nlat - do i=1,nlon - CA(i,j)=field_smooth(i,j) - enddo -enddo - -enddo !nn -endif !smooth - -!!!!Post processing, should be made into a separate subroutine - -Detmax(1)=maxval(CA) -call mp_reduce_max(Detmax(1)) -Detmin(1)=minval(CA) -call mp_reduce_min(Detmin(1)) - -do j=1,nlat - do i=1,nlon - CA(i,j) = ((CA(i,j) - Detmin(1))/(Detmax(1)-Detmin(1))) - enddo -enddo - -!mean: -CAmean=0. -psum=0. -csum=0. -do j=1,nlat - do i=1,nlon - psum=psum+(CA(i,j)) - csum=csum+1 - enddo -enddo - -call mp_reduce_sum(psum) -call mp_reduce_sum(csum) - -CAmean=psum/csum - -!std: -CAstdv=0. -sq_diff = 0. -do j=1,nlat - do i=1,nlon - sq_diff = sq_diff + (CA(i,j)-CAmean)**2.0 - enddo -enddo - -call mp_reduce_sum(sq_diff) - -CAstdv = sqrt(sq_diff/csum) + CA(:,:)=0. + + call update_cells_global(kstep,first_time_step,iseed_ca,restart,nca,nxc,nyc,nxch,nych,nlon,nlat,isc,iec,jsc,jec, & + npx,npy,CA,iini_g,ilives_g, & + nlives,ncells,nfracseed,nseed,nspinup,nf,mytile) + + if (ca_smooth) then + + field_out=0. + field_out(1+halo:nlon+halo,1+halo:nlat+halo,1) = real(CA(1:nlon,1:nlat),kind=8) + do nn=1,nsmooth !number of iterations for the smoothing. + + call atmosphere_scalar_field_halo(field_out,halo,isize,jsize,k_in,isc,iec,jsc,jec,npx,npy,domain_global) + + do j=1,nlat + do i=1,nlon + ih=i+halo + jh=j+halo + field_smooth(i,j)=(field_out(ih,jh,1)+field_out(ih-1,jh,1)+ & + field_out(ih,jh-1,1)+field_out(ih+1,jh,1)+& + field_out(ih,jh+1,1)+field_out(ih-1,jh-1,1)+& + field_out(ih-1,jh+1,1)+field_out(ih+1,jh+1,1)+& + field_out(ih+1,jh-1,1))*inv9 + enddo + enddo + field_out(1+halo:nlon+halo,1+halo:nlat+halo,1) = field_smooth(1:nlon,1:nlat) + enddo !nn + do j=1,nlat + do i=1,nlon + CA(i,j)=field_smooth(i,j) + enddo + enddo + endif !smooth + !mean: + !psum=SUM(CA) + !call mp_reduce_sum(psum) + + psum= mpp_global_sum (domain_global, CA, flags=BITWISE_EXACT_SUM) + CAmean=psum/csum + + !std: + !sq_diff = 0. + do j=1,nlat + do i=1,nlon + CAprime(i,j) = (CA(i,j)-CAmean)**2.0 + enddo + enddo + + !call mp_reduce_sum(sq_diff) + sq_diff= mpp_global_sum (domain_global, CAprime, flags=BITWISE_EXACT_SUM) -!Transform to mean of 1 and ca_amplitude standard deviation + CAstdv = sqrt(sq_diff/csum) -do j=1,nlat - do i=1,nlon - CA(i,j)=1.0 + (CA(i,j)-CAmean)*(ca_amplitude/CAstdv) - enddo -enddo + !Transform to mean of 1 and ca_amplitude standard deviation -do j=1,nlat - do i=1,nlon - CA(i,j)=min(max(CA(i,j),0.),2.0) - enddo -enddo + do j=1,nlat + do i=1,nlon + CA(i,j)=1.0 + (CA(i,j)-CAmean)*(ca_amplitude/CAstdv) + enddo + enddo + do j=1,nlat + do i=1,nlon + CA(i,j)=min(max(CA(i,j),0.),2.0) + enddo + enddo !Put back into blocks 1D array to be passed to physics !or diagnostics output -if(first_time_step)then -CA(:,:)=1. -endif if(nf==1)then - CA1(:,:)=CA(:,:) + CA1(:,:)=CA(:,:) elseif(nf==2)then - CA2(:,:)=CA(:,:) + CA2(:,:)=CA(:,:) else - CA3(:,:)=CA(:,:) + CA3(:,:)=CA(:,:) endif -enddo !nf + enddo !nf + + do blk = 1, Atm_block%nblks + do ix = 1,Atm_block%blksz(blk) + i = Atm_block%index(blk)%ii(ix) - isc + 1 + j = Atm_block%index(blk)%jj(ix) - jsc + 1 + ca1_cpl(blk,ix)=CA1(i,j) + ca2_cpl(blk,ix)=CA2(i,j) + ca3_cpl(blk,ix)=CA3(i,j) + enddo + enddo - do blk = 1, Atm_block%nblks - do ix = 1,Atm_block%blksz(blk) - i = Atm_block%index(blk)%ii(ix) - isc + 1 - j = Atm_block%index(blk)%jj(ix) - jsc + 1 - ca1_diag(blk,ix)=CA1(i,j) - ca2_diag(blk,ix)=CA2(i,j) - ca3_diag(blk,ix)=CA3(i,j) - ca1_cpl(blk,ix)=CA1(i,j) - ca2_cpl(blk,ix)=CA2(i,j) - ca3_cpl(blk,ix)=CA3(i,j) - enddo - enddo deallocate(field_out) @@ -339,11 +297,11 @@ subroutine cellular_automata_global(kstep,first_time_step,ca1_cpl,ca2_cpl,ca3_cp deallocate(iini_g) deallocate(ilives_g) deallocate(CA) + deallocate(CAprime) deallocate(CA1) deallocate(CA2) deallocate(CA3) deallocate(noise) - deallocate(noise1D) end subroutine cellular_automata_global diff --git a/cellular_automata_sgs.F90 b/cellular_automata_sgs.F90 index 6693ac98..ba6f87a9 100644 --- a/cellular_automata_sgs.F90 +++ b/cellular_automata_sgs.F90 @@ -1,25 +1,26 @@ module cellular_automata_sgs_mod +use update_ca, only : domain_global,domain_sgs,iscnx,iecnx,jscnx,jecnx,isdnx,iednx,jsdnx,jednx,nxncells,nyncells implicit none + contains subroutine cellular_automata_sgs(kstep,dtf,restart,first_time_step,sst,lsmsk,lake,condition_cpl, & - ca_deep_cpl,ca_turb_cpl,ca_shal_cpl,ca_deep_diag,ca_turb_diag,ca_shal_diag,domain, & - nblks,isc,iec,jsc,jec,npx,npy,nlev,nthresh,rcell, & - nca,scells,tlives,nfracseed,nseed,ca_global,ca_sgs,iseed_ca, & - ca_smooth,nspinup,ca_trigger,blocksize,mpiroot,mpicomm) - -use kinddef, only: kind_phys -use update_ca, only: update_cells_sgs, update_cells_global, define_ca_domain -use mersenne_twister, only: random_setseed,random_gauss,random_stat,random_number -use mpp_domains_mod, only: domain2D + ca_deep_cpl,ca_turb_cpl,ca_shal_cpl,domain_in, & + nblks,isc,iec,jsc,jec,npx,npy,nlev,nthresh,rcell, mytile, & + nca,scells,tlives,nfracseed,nseed,iseed_ca, & + nspinup,ca_trigger,blocksize,mpiroot,mpicomm) + +use kinddef, only: kind_phys,kind_dbl_prec +use update_ca, only: update_cells_sgs, define_ca_domain +use random_numbers, only: random_01_CB +use mpp_domains_mod, only: domain2D,mpp_get_global_domain,CENTER, mpp_get_data_domain, mpp_get_compute_domain,& + mpp_define_io_domain,mpp_get_io_domain_layout use block_control_mod, only: block_control_type, define_blocks_packed use time_manager_mod, only: time_type -use mpi_wrapper, only: mype,mp_reduce_sum,mp_bcst,mp_reduce_max,mp_reduce_min, & +use mpi_wrapper, only: mype,mp_reduce_max, & mpi_wrapper_initialize -use mpp_domains_mod -use mpp_mod @@ -32,13 +33,18 @@ subroutine cellular_automata_sgs(kstep,dtf,restart,first_time_step,sst,lsmsk,lak !Setting control variables as a function of dx and dt !for scale adaptation. +!P.Pegion, 2021-09 +! swtich to new random number generator and improve computational efficiency +! and remove unsued code + !This routine produces an output field CA_DEEP for coupling to convection (saSAS). !CA_DEEP can be either number of plumes in a cluster (nca_plumes=true) or updraft !area fraction (nca_plumes=false) -integer,intent(in) :: kstep,scells,nca,tlives,nseed,iseed_ca,nspinup,mpiroot,mpicomm +integer,intent(in) :: kstep,scells,nca,tlives,nseed,nspinup,mpiroot,mpicomm,mytile +integer(kind=kind_dbl_prec), intent(in) :: iseed_ca real(kind=kind_phys), intent(in) :: nfracseed,dtf,rcell -logical,intent(in) :: ca_global, ca_sgs, ca_smooth, restart,ca_trigger,first_time_step +logical,intent(in) :: restart,ca_trigger,first_time_step integer, intent(in) :: nblks,isc,iec,jsc,jec,npx,npy,nlev,blocksize real , intent(out) :: nthresh real(kind=kind_phys), intent(in) :: sst(:,:),lsmsk(:,:),lake(:,:) @@ -46,47 +52,39 @@ subroutine cellular_automata_sgs(kstep,dtf,restart,first_time_step,sst,lsmsk,lak real(kind=kind_phys), intent(inout) :: ca_deep_cpl(:,:) real(kind=kind_phys), intent(inout) :: ca_turb_cpl(:,:) real(kind=kind_phys), intent(inout) :: ca_shal_cpl(:,:) -real(kind=kind_phys), intent(out) :: ca_deep_diag(:,:) -real(kind=kind_phys), intent(out) :: ca_turb_diag(:,:) -real(kind=kind_phys), intent(out) :: ca_shal_diag(:,:) -type(domain2D), intent(inout) :: domain +type(domain2D), intent(inout) :: domain_in type(block_control_type) :: Atm_block -type(random_stat) :: rstate integer :: nlon, nlat, isize,jsize,nf,nn integer :: inci, incj, nxc, nyc, nxch, nych, nx, ny -integer :: nxncells, nyncells integer :: halo, k_in, i, j, k integer :: seed, ierr7,blk, ix, iix, count4,ih,jh integer :: blocksz,levs -integer,save :: isdnx,iednx,jsdnx,jednx -integer,save :: iscnx,iecnx,jscnx,jecnx integer :: ncells,nlives integer, save :: initialize_ca -integer(8) :: count, count_rate, count_max, count_trunc +integer(8) :: count, count_rate, count_max, count_trunc,nx_full integer(8) :: iscale = 10000000000 -integer, allocatable :: iini(:,:,:),ilives_in(:,:,:),ca_plumes(:,:) +integer, allocatable :: iini(:,:,:),ilives_in(:,:,:),ca_plumes(:,:),io_layout(:) real(kind=kind_phys), allocatable :: ssti(:,:),lsmski(:,:),lakei(:,:) real(kind=kind_phys), allocatable :: CA(:,:),condition(:,:),conditiongrid(:,:) real(kind=kind_phys), allocatable :: CA_DEEP(:,:) -real(kind=kind_phys), allocatable :: noise1D(:),noise(:,:,:) -real(kind=kind_phys) :: condmax,livesmax,factor,dx,pi,re -type(domain2D),save :: domain_ncellx +real*8 , allocatable :: noise(:,:,:) +real(kind=kind_phys) :: condmax,condmaxinv,livesmax,livesmaxinv,factor,dx,pi,re logical,save :: block_message=.true. logical :: nca_plumes logical,save :: first_flag +integer*8 :: i1,j1 +integer :: ct !nca :: switch for number of cellular automata to be used. -! :: for the moment only 1 CA can be used if ca_sgs = true -!ca_global :: switch for global cellular automata -!ca_sgs :: switch for cellular automata for deep convection +! :: for the moment only 1 CA can be used !nfracseed :: switch for number of random cells initially seeded !tlives :: switch for time scale (s) !nspinup :: switch for number of itterations to spin up the ca !scells :: switch for CA cell size (m) -!ca_smooth :: switch to smooth the cellular automata !nca_plumes :: compute number of CA-cells ("plumes") within a NWP gridbox. +if (nca .LT. 1) return ! Initialize MPI and OpenMP if (first_time_step) then call mpi_wrapper_initialize(mpiroot,mpicomm) @@ -118,7 +116,7 @@ subroutine cellular_automata_sgs(kstep,dtf,restart,first_time_step,sst,lsmsk,lak jsize=nlat+2*halo !Set time and length scales: - call mpp_get_global_domain(domain,xsize=nx,ysize=ny,position=CENTER) + call mpp_get_global_domain(domain_in,xsize=nx,ysize=ny,position=CENTER) pi=3.14159 re=6371000. dx=0.5*pi*re/real(nx) @@ -138,17 +136,23 @@ subroutine cellular_automata_sgs(kstep,dtf,restart,first_time_step,sst,lsmsk,lak inci=ncells incj=ncells -!--- get params from domain_ncellx for building board and board_halo +!--- get params from domain_sgs for building board and board_halo if(first_time_step)then !Get CA domain - call define_ca_domain(domain,domain_ncellx,ncells,nxncells,nyncells) - call mpp_get_data_domain (domain_ncellx,isdnx,iednx,jsdnx,jednx) - call mpp_get_compute_domain (domain_ncellx,iscnx,iecnx,jscnx,jecnx) + if (.not.restart) then + allocate(io_layout(2)) + io_layout=mpp_get_io_domain_layout(domain_in) + call define_ca_domain(domain_in,domain_sgs,ncells,nxncells,nyncells) + call mpp_define_io_domain(domain_sgs, io_layout) + endif + call mpp_get_data_domain (domain_sgs,isdnx,iednx,jsdnx,jednx) + call mpp_get_compute_domain (domain_sgs,iscnx,iecnx,jscnx,jecnx) !write(1000+mpp_pe(),*) "nxncells,nyncells: ",nxncells,nyncells !write(1000+mpp_pe(),*) "iscnx,iecnx,jscnx,jecnx: ",iscnx,iecnx,jscnx,jecnx !write(1000+mpp_pe(),*) "isdnx,iednx,jsdnx,jednx: ",isdnx,iednx,jsdnx,jednx - endif +endif + nxc = iecnx-iscnx+1 nyc = jecnx-jscnx+1 nxch = iednx-isdnx+1 @@ -166,18 +170,8 @@ subroutine cellular_automata_sgs(kstep,dtf,restart,first_time_step,sst,lsmsk,lak allocate(CA(nlon,nlat)) allocate(ca_plumes(nlon,nlat)) allocate(CA_DEEP(nlon,nlat)) - allocate(noise(nxc,nyc,nca)) - allocate(noise1D(nxc*nyc)) !Initialize: - condition(:,:)=0. - conditiongrid(:,:)=0. - ca_plumes(:,:) = 0 - noise(:,:,:) = 0.0 - noise1D(:) = 0.0 - iini(:,:,:) = 0 - ilives_in(:,:,:) = 0 - CA_DEEP(:,:) = 0. !Put the blocks of model fields into a 2d array - can't use nlev and blocksize directly, !because the arguments to define_blocks_packed are intent(inout) and not intent(in). @@ -199,7 +193,6 @@ subroutine cellular_automata_sgs(kstep,dtf,restart,first_time_step,sst,lsmsk,lak enddo !Initialize the CA when the condition field is populated - do j=1,nyc do i=1,nxc condition(i,j)=conditiongrid(inci/ncells,incj/ncells) @@ -214,19 +207,21 @@ subroutine cellular_automata_sgs(kstep,dtf,restart,first_time_step,sst,lsmsk,lak enddo condmax=maxval(condition) + condmaxinv=0.0 call mp_reduce_max(condmax) if(condmax > 0.)then if(.not. first_flag)then first_flag = .true. initialize_ca = kstep endif + condmaxinv=1.0/condmax endif if(kstep >=initialize_ca)then do nf=1,nca do j = 1,nyc do i = 1,nxc - ilives_in(i,j,nf)=int(real(nlives)*(condition(i,j)/condmax)) + ilives_in(i,j,nf)=int(real(nlives)*(condition(i,j)*condmaxinv)) enddo enddo enddo @@ -244,53 +239,57 @@ subroutine cellular_automata_sgs(kstep,dtf,restart,first_time_step,sst,lsmsk,lak endif !Generate random number, following stochastic physics code: -if(kstep == initialize_ca) then - if (iseed_ca == 0) then - ! generate a random seed from system clock and ens member number - call system_clock(count, count_rate, count_max) - ! iseed is elapsed time since unix epoch began (secs) - ! truncate to 4 byte integer - count_trunc = iscale*(count/iscale) - count4 = count - count_trunc - else - ! don't rely on compiler to truncate integer(8) to integer(4) on - ! overflow, do wrap around explicitly. - count4 = mod(mype + iseed_ca + 2147483648, 4294967296) - 2147483648 - endif - - call random_setseed(count4) - - do nf=1,nca - call random_number(noise1D) - !Put on 2D: - do j=1,nyc - do i=1,nxc - noise(i,j,nf)=noise1D(i+(j-1)*nxc) - enddo - enddo - enddo - -!Initiate the cellular automaton with random numbers larger than nfracseed - do nf=1,nca - do j = 1,nyc - do i = 1,nxc - if (noise(i,j,nf) > nfracseed ) then - iini(i,j,nf)=1 - else - iini(i,j,nf)=0 - endif +if (.not. restart) then + if(kstep == initialize_ca) then + nx_full=int(ncells,kind=8)*int(npx-1,kind=8) + allocate(noise(nxc,nyc,nca)) + do j=1,nyc + j1=j+(jsc-1)*ncells + do i=1,nxc + i1=i+(isc-1)*ncells + if (iseed_ca <= 0) then + ! generate a random seed from system clock and ens member number + call system_clock(count, count_rate, count_max) + ! iseed is elapsed time since unix epoch began (secs) + ! truncate to 4 byte integer + count_trunc = iscale*(count/iscale) + count4 = count - count_trunc + mytile *( i1+nx_full*(j1-1)) ! no need to multply by 7 since time will be different in sgs + else + ! don't rely on compiler to truncate integer(8) to integer(4) on + ! overflow, do wrap around explicitly. + count4 = mod((iseed_ca+mytile)*(i1+nx_full*(j1-1))+ 2147483648, 4294967296) - 2147483648 + endif + ct=1 + do nf=1,nca + noise(i,j,nf)=real(random_01_CB(ct,count4),kind=8) + ct=ct+1 + enddo + enddo enddo - enddo - enddo !nf - -endif ! + + !Initiate the cellular automaton with random numbers larger than nfracseed + do nf=1,nca + do j = 1,nyc + do i = 1,nxc + if (noise(i,j,nf) > nfracseed ) then + iini(i,j,nf)=1 + else + iini(i,j,nf)=0 + endif + enddo + enddo + enddo !nf + + deallocate(noise) + endif ! +endif ! restart !Calculate neighbours and update the automata do nf=1,nca - call update_cells_sgs(kstep,initialize_ca,first_flag,restart,first_time_step,iseed_ca,nca,nxc,nyc, & - nxch,nych,nlon,nlat,nxncells,nyncells,isc,iec,jsc,jec, & - npx,npy,isdnx,iednx,jsdnx,jednx,iscnx,iecnx,jscnx,jecnx,domain_ncellx,CA,ca_plumes,iini,ilives_in, & - nlives,nfracseed,nseed,nspinup,nf,nca_plumes,ncells) + call update_cells_sgs(kstep,initialize_ca,iseed_ca,first_flag,restart,first_time_step,nca,nxc,nyc, & + nxch,nych,nlon,nlat,isc,iec,jsc,jec, & + npx,npy,CA,ca_plumes,iini,ilives_in, & + nlives,nfracseed,nseed,nspinup,nf,nca_plumes,ncells,mytile) if(nca_plumes)then do j=1,nlat @@ -301,9 +300,10 @@ subroutine cellular_automata_sgs(kstep,dtf,restart,first_time_step,sst,lsmsk,lak else livesmax=maxval(ilives_in) call mp_reduce_max(livesmax) + livesmaxinv=1.0/livesmax do j=1,nlat do i=1,nlon - CA_DEEP(i,j)=CA(i,j)/livesmax + CA_DEEP(i,j)=CA(i,j)*livesmaxinv enddo enddo endif @@ -323,14 +323,13 @@ subroutine cellular_automata_sgs(kstep,dtf,restart,first_time_step,sst,lsmsk,lak !Put back into blocks 1D array to be passed to physics !or diagnostics output - do blk = 1, Atm_block%nblks - do ix = 1,Atm_block%blksz(blk) - i = Atm_block%index(blk)%ii(ix) - isc + 1 - j = Atm_block%index(blk)%jj(ix) - jsc + 1 - ca_deep_diag(blk,ix)=CA_DEEP(i,j) - ca_deep_cpl(blk,ix)=CA_DEEP(i,j) - enddo - enddo + do blk = 1, Atm_block%nblks + do ix = 1,Atm_block%blksz(blk) + i = Atm_block%index(blk)%ii(ix) - isc + 1 + j = Atm_block%index(blk)%jj(ix) - jsc + 1 + ca_deep_cpl(blk,ix)=CA_DEEP(i,j) + enddo + enddo deallocate(conditiongrid) deallocate(ssti) @@ -342,8 +341,6 @@ subroutine cellular_automata_sgs(kstep,dtf,restart,first_time_step,sst,lsmsk,lak deallocate(CA) deallocate(ca_plumes) deallocate(CA_DEEP) - deallocate(noise) - deallocate(noise1D) end subroutine cellular_automata_sgs diff --git a/compile_standalone b/compile_standalone deleted file mode 100755 index 981a2800..00000000 --- a/compile_standalone +++ /dev/null @@ -1,40 +0,0 @@ -#!/bin/sh -x -compile_all=0 -FC=mpif90 -INCS="-I. -I../FV3/gfsphysics/ -I../FMS/include -I../FV3/atmos_cubed_sphere -I../FMS/fv3gfs" -FLAGS64=" -traceback -real-size 64 -DSTOCHY_UNIT_TEST -c "$INCS -FLAGS=" -traceback -DSTOCHY_UNIT_TEST -c "$INCS -if [ $compile_all -eq 1 ];then - rm -f *.i90 *.i *.o *.mod lib*a - $FC ${FLAGS} fv_control_stub.F90 - $FC ${FLAGS} atmosphere_stub.F90 - $FC ${FLAGS64} stochy_namelist_def.F90 - $FC ${FLAGS64} stochy_resol_def.f - $FC ${FLAGS64} stochy_gg_def.f - $FC ${FLAGS64} spectral_layout.F90 - $FC ${FLAGS64} stochy_layout_lag.f - $FC ${FLAGS64} pln2eo_stochy.f - $FC ${FLAGS64} setlats_a_stochy.f - $FC ${FLAGS64} setlats_lag_stochy.f - $FC ${FLAGS64} glats_stochy.f - $FC ${FLAGS64} gozrineo_stochy.f - $FC ${FLAGS64} dezouv_stochy.f - $FC ${FLAGS64} dozeuv_stochy.f - $FC ${FLAGS64} epslon_stochy.f - $FC ${FLAGS64} four_to_grid_stochy.f - $FC ${FLAGS64} sumfln_stochy.f - $FC ${FLAGS64} get_lats_node_a_stochy.f - $FC ${FLAGS64} get_ls_node_stochy.f - $FC ${FLAGS64} compns_stochy.F90 - $FC ${FLAGS64} stochy_internal_state_mod.F90 - $FC ${FLAGS64} getcon_lag_stochy.f - $FC ${FLAGS64} getcon_spectral.F90 - $FC ${FLAGS64} initialize_spectral_mod.F90 - $FC ${FLAGS64} standalone_stochy_module.F90 - $FC ${FLAGS64} stochy_patterngenerator.F90 - $FC ${FLAGS64} stochy_data_mod.F90 - $FC ${FLAGS64} get_stochy_pattern.F90 - $FC ${FLAGS64} stochastic_physics.F90 - ar rv libstochastic_physics.a *.o -fi -$FC -traceback -real-size 64 -qopenmp -o standalone_stochy standalone_stochy.F90 ${INCS} -I/apps/netcdf/4.7.0/intel/18.0.5.274/include -L. -lstochastic_physics -L../FV3/atmos_cubed_sphere -lfv3core -L../FMS/FMS_INSTALL -lfms -L../FV3/gfsphysics -lgfsphys -L/scratch2/NCEPDEV/nwprod/NCEPLIBS/compilers/intel/18.0.5.274/lib -lsp_v2.0.3_d -L/scratch1/NCEPDEV/nems/emc.nemspara/soft/esmf/8.0.0bs48-intel18.0.5.274-impi2018.0.4-netcdf4.6.1/lib -Wl,-rpath,/scratch1/NCEPDEV/nems/emc.nemspara/soft/esmf/8.0.0bs48-intel18.0.5.274-impi2018.0.4-netcdf4.6.1/lib -lesmf -L/apps/netcdf/4.7.0/intel/18.0.5.274/lib -lnetcdff -lnetcdf diff --git a/compile_standalone_ca b/compile_standalone_ca deleted file mode 100755 index cce7e8ce..00000000 --- a/compile_standalone_ca +++ /dev/null @@ -1,17 +0,0 @@ -#!/bin/sh -compile_all=1 -if [ $compile_all -eq 1 ];then - rm -f *.i90 *.i *.o *.mod lib*a - mpif90 -C -traceback -real-size 64 -c ../FV3/gfsphysics/physics/machine.F - mpif90 -C -traceback -real-size 64 -c ../FV3/gfsphysics/physics/mersenne_twister.f - mpif90 -C -traceback -I../FMS/include -c ../FMS/platform/platform.F90 - mpif90 -C -traceback -nowarn -DGFS_PHYS -I../FMS/include -c ../FMS/constants/constants.F90 - mpif90 -C -traceback -I../FV3/atmos_cubed_sphere -I../FMS/include -I../FMS/fv3gfs -c fv_control_stub.F90 - mpif90 -C -traceback -I../FV3/atmos_cubed_sphere -I../FMS/include -I../FMS/fv3gfs -c atmosphere_stub.F90 - mpif90 -C -traceback -c -real-size 64 standalone_stochy_module.F90 - mpif90 -C -traceback -I. -real-size 64 -c plumes.F90 - mpif90 -DSTOCHY_UNIT_TEST -real-size 64 -C -traceback -I../FMS/fv3gfs -I../FMS/FMS_INSTALL -I../FV3/atmos_cubed_sphere -c update_ca.F90 - mpif90 -DSTOCHY_UNIT_TEST -real-size 64 -C -traceback -I../FMS/fv3gfs -I../FMS/FMS_INSTALL -I../FV3/atmos_cubed_sphere -c cellular_automata_global.F90 - ar rv libcellular_automata.a *.o -fi -mpif90 -traceback -real-size 64 -qopenmp -o standalone_ca standalone_ca.F90 -I../FV3/atmos_cubed_sphere -I../FMS/FMS_INSTALL -I/apps/netcdf/4.7.0/intel/18.0.5.274/include -L. -lcellular_automata -L../FV3/atmos_cubed_sphere -lfv3core -L../FMS/FMS_INSTALL -lfms -L../FV3/gfsphysics -lgfsphys -L/scratch2/NCEPDEV/nwprod/NCEPLIBS/compilers/intel/18.0.5.274/lib -lsp_v2.0.3_d -L/scratch1/NCEPDEV/nems/emc.nemspara/soft/esmf/8.0.0bs48-intel18.0.5.274-impi2018.0.4-netcdf4.6.1/lib -Wl,-rpath,/scratch1/NCEPDEV/nems/emc.nemspara/soft/esmf/8.0.0bs48-intel18.0.5.274-impi2018.0.4-netcdf4.6.1/lib -lesmf -L/apps/netcdf/4.7.0/intel/18.0.5.274/lib -lnetcdff -lnetcdf diff --git a/compns_stochy.F90 b/compns_stochy.F90 index 61c7f7cf..194730ed 100644 --- a/compns_stochy.F90 +++ b/compns_stochy.F90 @@ -170,25 +170,13 @@ subroutine compns_stochy (me,sz_nml,input_nml_file,fn_nml,nlunit,deltim,iret) do_skeb=.true. if (skebnorm==0) then ! stream function norm skeb=skeb*1.111e3*sqrt(deltim) - !skeb=skeb*5.0e5/sqrt(deltim) endif if (skebnorm==1) then ! stream function norm skeb=skeb*0.00222*sqrt(deltim) - !skeb=skeb*1/sqrt(deltim) endif if (skebnorm==2) then ! vorticty function norm skeb=skeb*1.111e-9*sqrt(deltim) - !skeb=skeb*5.0e-7/sqrt(deltim) endif -! adjust skeb values for resolution. -! scaling is such that a value of 1.0 at T574 with a 900 second -! timestep produces well-calibrated values of forecast spread. -! DO k=1,5 -! IF (skeb(k) .gt. 0.0) THEN -! skeb(k)=skeb(k)*deltim/(ntrunc*(ntrunc+1))*365765.0 ! 365765 is a scale factor so the base SKEB value in the namelist is 1.0 -! skeb(k)=skeb(k)*deltim/(ntrunc*(ntrunc+1))*2000.0 ! 2000 is new scale factor so the base SKEB value in the namelist is 1.0 -! ENDIF -! ENDDO ENDIF ! compute frequencty to estimate dissipation timescale IF (skebint == 0.) skebint=deltim diff --git a/dezouv_stochy.f b/dezouv_stochy.f deleted file mode 100644 index e01e170b..00000000 --- a/dezouv_stochy.f +++ /dev/null @@ -1,273 +0,0 @@ -!>@brief The module 'dezouv_stochy_mod' contains the subroutine dezouv_stochy -! of divergence and odd harmonics of vorticty - module dezouv_stochy_mod - - implicit none - - contains - -!>@brief The subroutine 'dezouv_stochy' caculates even u and odd v winds harmonics from the even harmonics -! of divergence and odd harmonics of vorticty -!>@details This code is taken from the legacy spectral GFS - subroutine dezouv_stochy(dev,zod,uev,vod,epsedn,epsodn, - & snnp1ev,snnp1od,ls_node) -cc - -cc - use spectral_layout_mod - use kinddef - implicit none -cc - real(kind_dbl_prec) dev(len_trie_ls,2) - real(kind_dbl_prec) zod(len_trio_ls,2) - real(kind_dbl_prec) uev(len_trie_ls,2) - real(kind_dbl_prec) vod(len_trio_ls,2) -cc - real(kind_dbl_prec) epsedn(len_trie_ls) - real(kind_dbl_prec) epsodn(len_trio_ls) -cc - real(kind_dbl_prec) snnp1ev(len_trie_ls) - real(kind_dbl_prec) snnp1od(len_trio_ls) -cc - integer ls_node(ls_dim,3) -cc -!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L -!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev -!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod -cc - integer l,locl,n -cc - integer indev,indev1,indev2 - integer indod,indod1,indod2 - integer inddif -cc - real(kind_dbl_prec) rl -cc - real(kind_dbl_prec) cons0 !constant -cc - integer indlsev,jbasev - integer indlsod,jbasod - real(kind_evod) rerth -cc - include 'function2' -cc -cc -cc...................................................................... -cc -cc - cons0 = 0.d0 !constant - rerth =6.3712e+6 ! radius of earth (m) -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) -cc - uev(indlsev(l,l),1) = cons0 !constant - uev(indlsev(l,l),2) = cons0 !constant -cc -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) + 1 - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - uev(indev,1) = -epsedn(indev) - x * zod(indev-inddif,1) -cc - uev(indev,2) = -epsedn(indev) - x * zod(indev-inddif,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - vod(indev-inddif,1) = epsodn(indev-inddif) - x * dev(indev,1) -cc - vod(indev-inddif,2) = epsodn(indev-inddif) - x * dev(indev,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - if ( l .ge. 1 ) then - rl = l - do indev = indev1 , indev2 -cc u(l,n)=-i*l*d(l,n)/(n*(n+1)) -cc - uev(indev,1) = uev(indev,1) - 1 + rl * dev(indev,2) - 2 / snnp1ev(indev) -cc - uev(indev,2) = uev(indev,2) - 1 - rl * dev(indev,1) - 2 / snnp1ev(indev) -cc - enddo - endif -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasod=ls_node(locl,3) - indod1 = indlsod(L+1,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indod2 = indlsod(jcap ,L) - else - indod2 = indlsod(jcap+1,L) - 1 - endif - if ( l .ge. 1 ) then - rl = l - do indod = indod1 , indod2 -cc u(l,n)=-i*l*d(l,n)/(n*(n+1)) -cc - vod(indod,1) = vod(indod,1) - 1 + rl * zod(indod,2) - 2 / snnp1od(indod) -cc - vod(indod,2) = vod(indod,2) - 1 - rl * zod(indod,1) - 2 / snnp1od(indod) -cc - enddo - endif -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - 1 - else - indev2 = indlsev(jcap ,L) - 1 - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - uev(indev,1) = uev(indev ,1) - 1 + epsodn(indev-inddif) * zod(indev-inddif,1) -cc - uev(indev,2) = uev(indev ,2) - 1 + epsodn(indev-inddif) * zod(indev-inddif,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) + 1 - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - vod(indev-inddif,1) = vod(indev-inddif,1) - 1 - epsedn(indev) * dev(indev ,1) -cc - vod(indev-inddif,2) = vod(indev-inddif,2) - 1 - epsedn(indev) * dev(indev ,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - indod1 = indlsod(L+1,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - indod2 = indlsod(jcap ,L) - else - indev2 = indlsev(jcap ,L) - indod2 = indlsod(jcap+1,L) - endif - do indev = indev1 , indev2 -cc - uev(indev,1) = uev(indev,1) * rerth - uev(indev,2) = uev(indev,2) * rerth -cc - enddo -cc - do indod = indod1 , indod2 -cc - vod(indod,1) = vod(indod,1) * rerth - vod(indod,2) = vod(indod,2) * rerth -cc - enddo -cc - enddo -cc - return - end - - end module dezouv_stochy_mod diff --git a/dozeuv_stochy.f b/dozeuv_stochy.f deleted file mode 100644 index c4a177bd..00000000 --- a/dozeuv_stochy.f +++ /dev/null @@ -1,271 +0,0 @@ -!>@brief The module 'dodeuv_stochy_mod' contains the subroutine dezouv_stochy -! - module dozeuv_stochy_mod - - implicit none - - contains - -!>@brief The subroutine 'dezouv_stochy' caculates odd u and even v winds harmonics from the odd harmonics -! of divergence and even harmonics of vorticty -!>@details This code is taken from the legacy spectral GFS - subroutine dozeuv_stochy(dod,zev,uod,vev,epsedn,epsodn, - & snnp1ev,snnp1od,ls_node) -cc - use spectral_layout_mod - use kinddef - implicit none -cc - real(kind_dbl_prec) dod(len_trio_ls,2) - real(kind_dbl_prec) zev(len_trie_ls,2) - real(kind_dbl_prec) uod(len_trio_ls,2) - real(kind_dbl_prec) vev(len_trie_ls,2) -cc - real(kind_dbl_prec) epsedn(len_trie_ls) - real(kind_dbl_prec) epsodn(len_trio_ls) -cc - real(kind_dbl_prec) snnp1ev(len_trie_ls) - real(kind_dbl_prec) snnp1od(len_trio_ls) -cc - integer ls_node(ls_dim,3) -cc -!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L -!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev -!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod -cc - integer l,locl,n -cc - integer indev,indev1,indev2 - integer indod,indod1,indod2 - integer inddif -cc - real(kind_dbl_prec) rl -cc - real(kind_dbl_prec) cons0 !constant -cc - integer indlsev,jbasev - integer indlsod,jbasod - real(kind_evod) rerth -cc - include 'function2' -cc -cc -cc...................................................................... -cc -cc - cons0 = 0.d0 !constant - rerth =6.3712e+6 ! radius of earth (m) -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) -cc - vev(indlsev(l,l),1) = cons0 !constant - vev(indlsev(l,l),2) = cons0 !constant -cc -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - uod(indev-inddif,1) = -epsodn(indev-inddif) - x * zev(indev,1) -cc - uod(indev-inddif,2) = -epsodn(indev-inddif) - x * zev(indev,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) + 1 - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - vev(indev,1) = epsedn(indev) - x * dod(indev-inddif,1) -cc - vev(indev,2) = epsedn(indev) - x * dod(indev-inddif,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasod=ls_node(locl,3) - indod1 = indlsod(L+1,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indod2 = indlsod(jcap ,L) - else - indod2 = indlsod(jcap+1,L) - 1 - endif - if ( l .ge. 1 ) then - rl = l - do indod = indod1 , indod2 -cc u(l,n)=-i*l*d(l,n)/(n*(n+1)) -cc - uod(indod,1) = uod(indod,1) - 1 + rl * dod(indod,2) - 2 / snnp1od(indod) -cc - uod(indod,2) = uod(indod,2) - 1 - rl * dod(indod,1) - 2 / snnp1od(indod) -cc - enddo - endif -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - if ( l .ge. 1 ) then - rl = l - do indev = indev1 , indev2 -cc u(l,n)=-i*l*d(l,n)/(n*(n+1)) -cc - vev(indev,1) = vev(indev,1) - 1 + rl * zev(indev,2) - 2 / snnp1ev(indev) -cc - vev(indev,2) = vev(indev,2) - 1 - rl * zev(indev,1) - 2 / snnp1ev(indev) -cc - enddo - endif -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) + 1 - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - uod(indev-inddif,1) = uod(indev-inddif,1) - 1 + epsedn(indev) * zev(indev ,1) -cc - uod(indev-inddif,2) = uod(indev-inddif,2) - 1 + epsedn(indev) * zev(indev ,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - 1 - else - indev2 = indlsev(jcap ,L) - 1 - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - do indev = indev1 , indev2 -cc - vev(indev,1) = vev(indev ,1) - 1 - epsodn(indev-inddif) * dod(indev-inddif,1) -cc - vev(indev,2) = vev(indev ,2) - 1 - epsodn(indev-inddif) * dod(indev-inddif,2) -cc - enddo -cc - enddo -cc -cc...................................................................... -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - indod1 = indlsod(L+1,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - indod2 = indlsod(jcap ,L) - else - indev2 = indlsev(jcap ,L) - indod2 = indlsod(jcap+1,L) - endif - do indod = indod1 , indod2 -cc - uod(indod,1) = uod(indod,1) * rerth - uod(indod,2) = uod(indod,2) * rerth -cc - enddo -cc - do indev = indev1 , indev2 -cc - vev(indev,1) = vev(indev,1) * rerth - vev(indev,2) = vev(indev,2) * rerth -cc - enddo -cc - enddo -cc - return - end - - end module dozeuv_stochy_mod diff --git a/epslon_stochy.f b/epslon_stochy.f deleted file mode 100644 index 919a2e19..00000000 --- a/epslon_stochy.f +++ /dev/null @@ -1,95 +0,0 @@ -!>@brief The module 'epslon_stochy_mod' contains the subroute epslon_stochy - module epslon_stochy_mod - - implicit none - - contains - -!>@brief The subroutine 'epslon_stochy' calculate coeffients for use in spectral space -!>@details This code is taken from the legacy spectral GFS - subroutine epslon_stochy(epse,epso,epsedn,epsodn, - & ls_node) -cc - use spectral_layout_mod - use kinddef - implicit none -cc - real(kind_dbl_prec) epse(len_trie_ls) - real(kind_dbl_prec) epso(len_trio_ls) -cc - real(kind_dbl_prec) epsedn(len_trie_ls) - real(kind_dbl_prec) epsodn(len_trio_ls) -cc - integer ls_node(ls_dim,3) -cc -!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L -!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev -!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod -cc - integer l,locl,n -cc - integer indev - integer indod -cc - real(kind_dbl_prec) f1,f2,rn,val -cc - real(kind_dbl_prec) cons0 !constant -cc - integer indlsev,jbasev - integer indlsod,jbasod -cc - include 'function2' -cc -cc - cons0=0.0d0 !constant -cc -cc -cc...................................................................... -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - indev=indlsev(l,l) - epse (indev)=cons0 !constant - epsedn(indev)=cons0 !constant - indev=indev+1 -cc - - do n=l+2,jcap+1,2 - rn=n - f1=n*n-l*l - f2=4*n*n-1 - val=sqrt(f1/f2) - epse (indev)=val - epsedn(indev)=val/rn - indev=indev+1 - enddo -cc - enddo -cc -cc -cc...................................................................... -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasod=ls_node(locl,3) - indod=indlsod(l+1,l) -cc - do n=l+1,jcap+1,2 - rn=n - f1=n*n-l*l - f2=4*n*n-1 - val=sqrt(f1/f2) - epso (indod)=val - epsodn(indod)=val/rn - indod=indod+1 - enddo -cc - enddo -cc - return - end - - end module epslon_stochy_mod diff --git a/fftpack_stochy.f b/fftpack_stochy.f deleted file mode 100644 index 23e36e4e..00000000 --- a/fftpack_stochy.f +++ /dev/null @@ -1,536 +0,0 @@ - SUBROUTINE dcrft_stochy(init,x,ldx,y,ldy,n,m,isign,scale, - & table,n1,wrk,n2,z,nz) - - implicit none - integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j - real x(2*ldx,*),y(ldy,*),scale,table(44002),wrk,z - - IF (init.ne.0) THEN - CALL rffti_stochy(n,table) - ELSE -!OCL NOVREC - DO j=1,m - y(1,j)=x(1,j) - DO i=2,n - y(i,j)=x(i+1,j) - ENDDO - CALL rfftb_stochy(n,y(1,j),table) - DO i=1,n - y(i,j)=scale*y(i,j) - ENDDO - ENDDO - ENDIF - - RETURN - END - -c -c ****************************************************************** -c ****************************************************************** -c ****** ****** -c ****** FFTPACK ****** -c ****** ****** -c ****************************************************************** -c ****************************************************************** -c - SUBROUTINE RFFTB_STOCHY (N,R,WSAVE) - DIMENSION R(*) ,WSAVE(44002) - IF (N .EQ. 1) RETURN - CALL RFFTB1_STOCHY (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END - SUBROUTINE RFFTI_STOCHY (N,WSAVE) -c DIMENSION WSAVE(1) - DIMENSION WSAVE(44002) - IF (N .EQ. 1) RETURN - CALL RFFTI1_STOCHY (N,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END - SUBROUTINE RFFTB1_STOCHY (N,C,CH,WA,IFAC) - DIMENSION CH(44002) ,C(*) ,WA(*) ,IFAC(*) - NF = IFAC(2) - NA = 0 - L1 = 1 - IW = 1 - DO 116 K1=1,NF - IP = IFAC(K1+2) - L2 = IP*L1 - IDO = N/L2 - IDL1 = IDO*L1 - IF (IP .NE. 4) GO TO 103 - IX2 = IW+IDO - IX3 = IX2+IDO - IF (NA .NE. 0) GO TO 101 - CALL RADB4_STOCHY (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 102 - 101 CALL RADB4_STOCHY (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - 102 NA = 1-NA - GO TO 115 - 103 IF (IP .NE. 2) GO TO 106 - IF (NA .NE. 0) GO TO 104 - CALL RADB2_STOCHY (IDO,L1,C,CH,WA(IW)) - GO TO 105 - 104 CALL RADB2_STOCHY (IDO,L1,CH,C,WA(IW)) - 105 NA = 1-NA - GO TO 115 - 106 IF (IP .NE. 3) GO TO 109 - IX2 = IW+IDO - IF (NA .NE. 0) GO TO 107 - CALL RADB3_STOCHY (IDO,L1,C,CH,WA(IW),WA(IX2)) - GO TO 108 - 107 CALL RADB3_STOCHY (IDO,L1,CH,C,WA(IW),WA(IX2)) - 108 NA = 1-NA - GO TO 115 - 109 IF (IP .NE. 5) GO TO 112 - IX2 = IW+IDO - IX3 = IX2+IDO - IX4 = IX3+IDO - IF (NA .NE. 0) GO TO 110 - CALL RADB5_STOCHY (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 111 - 110 CALL RADB5_STOCHY (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - 111 NA = 1-NA - GO TO 115 - 112 IF (NA .NE. 0) GO TO 113 - CALL RADBG_STOCHY (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - GO TO 114 - 113 CALL RADBG_STOCHY (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - 114 IF (IDO .EQ. 1) NA = 1-NA - 115 L1 = L2 - IW = IW+(IP-1)*IDO - 116 CONTINUE - IF (NA .EQ. 0) RETURN - DO 117 I=1,N - C(I) = CH(I) - 117 CONTINUE - RETURN - END - - - - SUBROUTINE RFFTI1_STOCHY (N,WA,IFAC) - DIMENSION WA(*) ,IFAC(*) ,NTRYH(4) - DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ - NL = N - NF = 0 - J = 0 - 101 J = J+1 - IF (J-4) 102,102,103 - 102 NTRY = NTRYH(J) - GO TO 104 - 103 NTRY = NTRY+2 - 104 NQ = NL/NTRY - NR = NL-NTRY*NQ - IF (NR) 101,105,101 - 105 NF = NF+1 - IFAC(NF+2) = NTRY - NL = NQ - IF (NTRY .NE. 2) GO TO 107 - IF (NF .EQ. 1) GO TO 107 - DO 106 I=2,NF - IB = NF-I+2 - IFAC(IB+2) = IFAC(IB+1) - 106 CONTINUE - IFAC(3) = 2 - 107 IF (NL .NE. 1) GO TO 104 - IFAC(1) = N - IFAC(2) = NF - TPI = 6.28318530717959 - ARGH = TPI/FLOAT(N) - IS = 0 - NFM1 = NF-1 - L1 = 1 - IF (NFM1 .EQ. 0) RETURN -!OCL NOVREC - DO 110 K1=1,NFM1 - IP = IFAC(K1+2) - LD = 0 - L2 = L1*IP - IDO = N/L2 - IPM = IP-1 - DO 109 J=1,IPM - LD = LD+L1 - I = IS - ARGLD = FLOAT(LD)*ARGH - FI = 0 -!OCL SCALAR - DO 108 II=3,IDO,2 - I = I+2 - FI = FI+1 - ARG = FI*ARGLD - WA(I-1) = COS(ARG) - WA(I) = SIN(ARG) - 108 CONTINUE - IS = IS+IDO - 109 CONTINUE - L1 = L2 - 110 CONTINUE - RETURN - END - - - SUBROUTINE RADB2_STOCHY (IDO,L1,CC,CH,WA1) - DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , - 1 WA1(*) - DO 101 K=1,L1 - CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) - CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 -!OCL NOVREC - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) - TR2 = CC(I-1,1,K)-CC(IC-1,2,K) - CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) - TI2 = CC(I,1,K)+CC(IC,2,K) - CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 - CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) - CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) - 106 CONTINUE - 107 RETURN - END - - - SUBROUTINE RADB3_STOCHY (IDO,L1,CC,CH,WA1,WA2) - DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , - 1 WA1(*) ,WA2(*) - DATA TAUR,TAUI /-.5,.866025403784439/ - DO 101 K=1,L1 - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - CR2 = CC(1,1,K)+TAUR*TR2 - CH(1,K,1) = CC(1,1,K)+TR2 - CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) - CH(1,K,2) = CR2-CI3 - CH(1,K,3) = CR2+CI3 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 -!OCL NOVREC - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,3,K)-CC(IC,2,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) - CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - 102 CONTINUE - 103 CONTINUE - RETURN - END - - - SUBROUTINE RADB4_STOCHY (IDO,L1,CC,CH,WA1,WA2,WA3) - DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , - 1 WA1(*) ,WA2(*) ,WA3(*) - DATA SQRT2 /1.414213562373095/ - DO 101 K=1,L1 - TR1 = CC(1,1,K)-CC(IDO,4,K) - TR2 = CC(1,1,K)+CC(IDO,4,K) - TR3 = CC(IDO,2,K)+CC(IDO,2,K) - TR4 = CC(1,3,K)+CC(1,3,K) - CH(1,K,1) = TR2+TR3 - CH(1,K,2) = TR1-TR4 - CH(1,K,3) = TR2-TR3 - CH(1,K,4) = TR1+TR4 - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 -!OCL NOVREC - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - TI1 = CC(I,1,K)+CC(IC,4,K) - TI2 = CC(I,1,K)-CC(IC,4,K) - TI3 = CC(I,3,K)-CC(IC,2,K) - TR4 = CC(I,3,K)+CC(IC,2,K) - TR1 = CC(I-1,1,K)-CC(IC-1,4,K) - TR2 = CC(I-1,1,K)+CC(IC-1,4,K) - TI4 = CC(I-1,3,K)-CC(IC-1,2,K) - TR3 = CC(I-1,3,K)+CC(IC-1,2,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1-TR4 - CR4 = TR1+TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 - CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 - CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 - CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 - CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 - CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 CONTINUE - DO 106 K=1,L1 - TI1 = CC(1,2,K)+CC(1,4,K) - TI2 = CC(1,4,K)-CC(1,2,K) - TR1 = CC(IDO,1,K)-CC(IDO,3,K) - TR2 = CC(IDO,1,K)+CC(IDO,3,K) - CH(IDO,K,1) = TR2+TR2 - CH(IDO,K,2) = SQRT2*(TR1-TI1) - CH(IDO,K,3) = TI2+TI2 - CH(IDO,K,4) = -SQRT2*(TR1+TI1) - 106 CONTINUE - 107 RETURN - END - - - SUBROUTINE RADB5_STOCHY (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , - 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) - DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, - 1-.809016994374947,.587785252292473/ - DO 101 K=1,L1 - TI5 = CC(1,3,K)+CC(1,3,K) - TI4 = CC(1,5,K)+CC(1,5,K) - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - TR3 = CC(IDO,4,K)+CC(IDO,4,K) - CH(1,K,1) = CC(1,1,K)+TR2+TR3 - CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 - CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 - CI5 = TI11*TI5+TI12*TI4 - CI4 = TI12*TI5-TI11*TI4 - CH(1,K,2) = CR2-CI5 - CH(1,K,3) = CR3-CI4 - CH(1,K,4) = CR3+CI4 - CH(1,K,5) = CR2+CI5 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - TI5 = CC(I,3,K)+CC(IC,2,K) - TI2 = CC(I,3,K)-CC(IC,2,K) - TI4 = CC(I,5,K)+CC(IC,4,K) - TI3 = CC(I,5,K)-CC(IC,4,K) - TR5 = CC(I-1,3,K)-CC(IC-1,2,K) - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - TR4 = CC(I-1,5,K)-CC(IC-1,4,K) - TR3 = CC(I-1,5,K)+CC(IC-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 - CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 - CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 - CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 - 102 CONTINUE - 103 CONTINUE - RETURN - END - - - SUBROUTINE RADBG_STOCHY (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , - 1 C1(IDO,L1,IP) ,C2(IDL1,IP), - 2 CH2(IDL1,IP) ,WA(*) - DATA TPI/6.28318530717959/ - ARG = TPI/FLOAT(IP) - DCP = COS(ARG) - DSP = SIN(ARG) - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IPP2 = IP+2 - IPPH = (IP+1)/2 - IF (IDO .LT. L1) GO TO 103 - DO 102 K=1,L1 - DO 101 I=1,IDO - CH(I,K,1) = CC(I,1,K) - 101 CONTINUE - 102 CONTINUE - GO TO 106 - 103 DO 105 I=1,IDO - DO 104 K=1,L1 - CH(I,K,1) = CC(I,1,K) - 104 CONTINUE - 105 CONTINUE -!OCL NOVREC - 106 DO 108 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 107 K=1,L1 - CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) - CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) - 107 CONTINUE - 108 CONTINUE - IF (IDO .EQ. 1) GO TO 116 - IF (NBD .LT. L1) GO TO 112 -!OCL NOVREC - DO 111 J=2,IPPH - JC = IPP2-J - DO 110 K=1,L1 - DO 109 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 109 CONTINUE - 110 CONTINUE - 111 CONTINUE - GO TO 116 - 112 DO 115 J=2,IPPH - JC = IPP2-J - DO 114 I=3,IDO,2 - IC = IDP2-I - DO 113 K=1,L1 - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 113 CONTINUE - 114 CONTINUE - 115 CONTINUE - 116 AR1 = 1. - AI1 = 0. -!OCL NOVREC - DO 120 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 117 IK=1,IDL1 - C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) - C2(IK,LC) = AI1*CH2(IK,IP) - 117 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 -!OCL NOVREC - DO 119 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 118 IK=1,IDL1 - C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J) - C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) - 118 CONTINUE - 119 CONTINUE - 120 CONTINUE -!OCL NOVREC - DO 122 J=2,IPPH - DO 121 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+CH2(IK,J) - 121 CONTINUE - 122 CONTINUE -!OCL NOVREC - DO 124 J=2,IPPH - JC = IPP2-J - DO 123 K=1,L1 - CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) - CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) - 123 CONTINUE - 124 CONTINUE - IF (IDO .EQ. 1) GO TO 132 - IF (NBD .LT. L1) GO TO 128 -!OCL NOVREC - DO 127 J=2,IPPH - JC = IPP2-J - DO 126 K=1,L1 - DO 125 I=3,IDO,2 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - GO TO 132 - 128 DO 131 J=2,IPPH - JC = IPP2-J - DO 130 I=3,IDO,2 - DO 129 K=1,L1 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 129 CONTINUE - 130 CONTINUE - 131 CONTINUE - 132 CONTINUE - IF (IDO .EQ. 1) RETURN - DO 133 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 133 CONTINUE - DO 135 J=2,IP - DO 134 K=1,L1 - C1(1,K,J) = CH(1,K,J) - 134 CONTINUE - 135 CONTINUE - IF (NBD .GT. L1) GO TO 139 - IS = -IDO - DO 138 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 137 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 136 K=1,L1 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 136 CONTINUE - 137 CONTINUE - 138 CONTINUE - GO TO 143 - 139 IS = -IDO -!OCL NOVREC - DO 142 J=2,IP - IS = IS+IDO - DO 141 K=1,L1 - IDIJ = IS - DO 140 I=3,IDO,2 - IDIJ = IDIJ+2 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 140 CONTINUE - 141 CONTINUE - 142 CONTINUE - 143 RETURN - END - - diff --git a/four_to_grid_stochy.F b/four_to_grid_stochy.F deleted file mode 100644 index 2b8a2363..00000000 --- a/four_to_grid_stochy.F +++ /dev/null @@ -1,54 +0,0 @@ -!>@brief The module 'four_to_grid_mod' contains the subroute four_to_grid - module four_to_grid_mod - - - implicit none - - contains - -!>@brief The subroutine 'four_to_grd' calculate real values form fourrier coefficients -!>@details This code is taken from the legacy spectral GFS - subroutine four_to_grid(syn_gr_a_1,syn_gr_a_2, - & lon_dim_coef,lon_dim_grid,lons_lat,lot) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - use kinddef - implicit none -!! - real(kind=kind_dbl_prec) syn_gr_a_1(lon_dim_coef,lot) - real(kind=kind_dbl_prec) syn_gr_a_2(lon_dim_grid,lot) - integer lon_dim_coef - integer lon_dim_grid - integer lons_lat - integer lot -!________________________________________________________ - real(kind=kind_dbl_prec) aux1crs(44002) - real(kind=kind_dbl_prec) scale_ibm - integer ibmsign - integer init -!________________________________________________________ - - - init = 1 - ibmsign = -1 - scale_ibm = 1.0d0 - - call dcrft_stochy(init, - & syn_gr_a_1(1,1) ,lon_dim_coef/2, - & syn_gr_a_2(1,1) ,lon_dim_grid, - & lons_lat,lot,ibmsign,scale_ibm, - & aux1crs,22000, - & aux1crs(22001),20000) - - init = 0 - call dcrft_stochy(init, - & syn_gr_a_1(1,1) ,lon_dim_coef/2, - & syn_gr_a_2(1,1) ,lon_dim_grid, - & lons_lat,lot,ibmsign,scale_ibm, - & aux1crs,22000, - & aux1crs(22001),20000) - - return - end - - - end module four_to_grid_mod diff --git a/fv_control_stub.F90 b/fv_control_stub.F90 deleted file mode 100644 index 86d2bf96..00000000 --- a/fv_control_stub.F90 +++ /dev/null @@ -1,1300 +0,0 @@ - -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the FV3 dynamical core. -!* -!* The FV3 dynamical core is free software: you can redistribute it -!* and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. -!* If not, see . -!*********************************************************************** - -!>@brief The module 'FV3_control' is for initialization and termination -!! of the model, and controls namelist parameters in FV3. -!---------------- -! FV control panel -!---------------- - -module fv_control_stub_mod -! Modules Included: -! -! -! -! -! -!
Module NameFunctions Included
-! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -!
constants_modpi=>pi_8, kappa, radius, grav, rdgas
field_manager_modMODEL_ATMOS
fms_modwrite_version_number, open_namelist_file, -! check_nml_error, close_file, file_exist
fv_arrays_modfv_atmos_type, allocate_fv_atmos_type, deallocate_fv_atmos_type, -! R_GRID
fv_diagnostics_modfv_diag_init_gn
fv_eta_modset_eta
fv_grid_tools_modinit_grid
fv_grid_utils_modgrid_utils_init, grid_utils_end, ptop_min
fv_mp_modmp_start, mp_assign_gid, domain_decomp,ng, switch_current_Atm, -! broadcast_domains, mp_barrier, is_master, setup_master
fv_io_modfv_io_exit
fv_restart_modfv_restart_init, fv_restart_end
fv_timing_modtiming_on, timing_off, timing_init, timing_prt
mpp_modmpp_send, mpp_sync, mpp_transmit, mpp_set_current_pelist, mpp_declare_pelist, -! mpp_root_pe, mpp_recv, mpp_sync_self, mpp_broadcast, read_input_nml, -! FATAL, mpp_error, mpp_pe, stdlog, mpp_npes, mpp_get_current_pelist, -! input_nml_file, get_unit, WARNING, read_ascii_file, INPUT_STR_LENGTH
mpp_domains_modmpp_get_data_domain, mpp_get_compute_domain, domain2D, mpp_define_nest_domains, -! nest_domain_type, mpp_get_global_domain, mpp_get_C2F_index, mpp_get_F2C_index, -! mpp_broadcast_domain, CENTER, CORNER, NORTH, EAST, WEST, SOUTH
mpp_parameter_modAGRID_PARAM=>AGRID
test_cases_modtest_case, bubble_do, alpha, nsolitons, soliton_Umax, soliton_size
tracer_manager_modtm_get_number_tracers => get_number_tracers,tm_get_tracer_index => get_tracer_index, -! tm_get_tracer_indices => get_tracer_indices, tm_set_tracer_profile => set_tracer_profile, -! tm_get_tracer_names => get_tracer_names,tm_check_if_prognostic=> check_if_prognostic, -! tm_register_tracers => register_tracers
- - use constants_mod, only: pi=>pi_8, kappa, radius, grav, rdgas - use field_manager_mod, only: MODEL_ATMOS - use fms_mod, only: write_version_number, open_namelist_file, & - check_nml_error, close_file, file_exist - use mpp_mod, only: FATAL, mpp_error, mpp_pe, stdlog, & - mpp_npes, mpp_get_current_pelist, & - input_nml_file, get_unit, WARNING, & - read_ascii_file, INPUT_STR_LENGTH - use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_compute_domain - use tracer_manager_mod, only: tm_get_number_tracers => get_number_tracers, & - tm_get_tracer_index => get_tracer_index, & - tm_get_tracer_indices => get_tracer_indices, & - tm_set_tracer_profile => set_tracer_profile, & - tm_get_tracer_names => get_tracer_names, & - tm_check_if_prognostic=> check_if_prognostic,& - tm_register_tracers => register_tracers - - use fv_io_mod, only: fv_io_exit - use fv_restart_mod, only: fv_restart_init, fv_restart_end - use fv_arrays_mod, only: fv_atmos_type, allocate_fv_atmos_type, deallocate_fv_atmos_type, & - R_GRID - use fv_grid_utils_mod, only: grid_utils_init, grid_utils_end, ptop_min - use fv_eta_mod, only: set_eta - use fv_grid_tools_mod, only: init_grid - use fv_mp_mod, only: mp_start, mp_assign_gid, domain_decomp - use fv_mp_mod, only: ng, switch_current_Atm - use fv_mp_mod, only: broadcast_domains, mp_barrier, is_master, setup_master -!!! CLEANUP: should be replaced by a getter function? - use test_cases_mod, only: test_case, bubble_do, alpha, nsolitons, soliton_Umax, soliton_size - use fv_timing_mod, only: timing_on, timing_off, timing_init, timing_prt - use mpp_domains_mod, only: domain2D - use mpp_domains_mod, only: mpp_define_nest_domains, nest_domain_type, mpp_get_global_domain - use mpp_domains_mod, only: mpp_get_C2F_index, mpp_get_F2C_index, mpp_broadcast_domain - use mpp_domains_mod, only: CENTER, CORNER, NORTH, EAST, WEST, SOUTH - use mpp_mod, only: mpp_send, mpp_sync, mpp_transmit, mpp_set_current_pelist, mpp_declare_pelist, mpp_root_pe, mpp_recv, mpp_sync_self, mpp_broadcast, read_input_nml - use fv_diagnostics_mod, only: fv_diag_init_gn - -#ifdef MULTI_GASES - use constants_mod, only: rvgas, cp_air - use multi_gases_mod, only: multi_gases_init, & - rilist => ri, & - cpilist => cpi -#endif - - implicit none - private - public setup_pointers - -!----------------------------------------------------------------------- -! Grid descriptor file setup -!----------------------------------------------------------------------- -!------------------------------------------ -! Model Domain parameters -! See fv_arrays.F90 for descriptions -!------------------------------------------ -!CLEANUP module pointers - character(len=80) , pointer :: grid_name - character(len=120), pointer :: grid_file - integer, pointer :: grid_type - integer , pointer :: hord_mt - integer , pointer :: kord_mt - integer , pointer :: kord_wz - integer , pointer :: hord_vt - integer , pointer :: hord_tm - integer , pointer :: hord_dp - integer , pointer :: kord_tm - integer , pointer :: hord_tr - integer , pointer :: kord_tr - real , pointer :: scale_z - real , pointer :: w_max - real , pointer :: z_min - real , pointer :: lim_fac - - integer , pointer :: nord - integer , pointer :: nord_tr - real , pointer :: dddmp - real , pointer :: d2_bg - real , pointer :: d4_bg - real , pointer :: vtdm4 - real , pointer :: trdm2 - real , pointer :: d2_bg_k1 - real , pointer :: d2_bg_k2 - real , pointer :: d2_divg_max_k1 - real , pointer :: d2_divg_max_k2 - real , pointer :: damp_k_k1 - real , pointer :: damp_k_k2 - integer , pointer :: n_zs_filter - integer , pointer :: nord_zs_filter - logical , pointer :: full_zs_filter - - logical , pointer :: RF_fast - logical , pointer :: consv_am - logical , pointer :: do_sat_adj - logical , pointer :: do_f3d - logical , pointer :: no_dycore - logical , pointer :: convert_ke - logical , pointer :: do_vort_damp - logical , pointer :: use_old_omega -! PG off centering: - real , pointer :: beta - integer , pointer :: n_sponge - real , pointer :: d_ext - integer , pointer :: nwat - logical , pointer :: warm_start - logical , pointer :: inline_q - real , pointer :: shift_fac - logical , pointer :: do_schmidt - real(kind=R_GRID) , pointer :: stretch_fac - real(kind=R_GRID) , pointer :: target_lat - real(kind=R_GRID) , pointer :: target_lon - - logical , pointer :: reset_eta - real , pointer :: p_fac - real , pointer :: a_imp - integer , pointer :: n_split - - real , pointer :: fac_n_spl - real , pointer :: fhouri - ! Default - integer , pointer :: m_split - integer , pointer :: k_split - logical , pointer :: use_logp - - integer , pointer :: q_split - integer , pointer :: print_freq - logical , pointer :: write_3d_diags - - integer , pointer :: npx - integer , pointer :: npy - integer , pointer :: npz - integer , pointer :: npz_rst - - integer , pointer :: ncnst - integer , pointer :: pnats - integer , pointer :: dnats - integer , pointer :: ntiles - integer , pointer :: nf_omega - integer , pointer :: fv_sg_adj - - integer , pointer :: na_init - logical , pointer :: nudge_dz - real , pointer :: p_ref - real , pointer :: dry_mass - integer , pointer :: nt_prog - integer , pointer :: nt_phys - real , pointer :: tau_h2o - - real , pointer :: delt_max - real , pointer :: d_con - real , pointer :: ke_bg - real , pointer :: consv_te - real , pointer :: tau - real , pointer :: rf_cutoff - logical , pointer :: filter_phys - logical , pointer :: dwind_2d - logical , pointer :: breed_vortex_inline - logical , pointer :: range_warn - logical , pointer :: fill - logical , pointer :: fill_dp - logical , pointer :: fill_wz - logical , pointer :: check_negative - logical , pointer :: non_ortho - logical , pointer :: adiabatic - logical , pointer :: moist_phys - logical , pointer :: do_Held_Suarez - logical , pointer :: do_reed_physics - logical , pointer :: reed_cond_only - logical , pointer :: reproduce_sum - logical , pointer :: adjust_dry_mass - logical , pointer :: fv_debug - logical , pointer :: srf_init - logical , pointer :: mountain - logical , pointer :: remap_t - logical , pointer :: z_tracer - - logical , pointer :: old_divg_damp - logical , pointer :: fv_land - logical , pointer :: nudge - logical , pointer :: nudge_ic - logical , pointer :: ncep_ic - logical , pointer :: nggps_ic - logical , pointer :: ecmwf_ic - logical , pointer :: gfs_phil - logical , pointer :: agrid_vel_rst - logical , pointer :: use_new_ncep - logical , pointer :: use_ncep_phy - logical , pointer :: fv_diag_ic - logical , pointer :: external_ic - logical , pointer :: external_eta - logical , pointer :: read_increment - character(len=128) , pointer :: res_latlon_dynamics - character(len=128) , pointer :: res_latlon_tracers - logical , pointer :: hydrostatic - logical , pointer :: phys_hydrostatic - logical , pointer :: use_hydro_pressure - logical , pointer :: do_uni_zfull !miz - logical , pointer :: adj_mass_vmr ! f1p - logical , pointer :: hybrid_z - logical , pointer :: Make_NH - logical , pointer :: make_hybrid_z - logical , pointer :: nudge_qv - real, pointer :: add_noise - - integer , pointer :: a2b_ord - integer , pointer :: c2l_ord - - integer, pointer :: ndims - - real(kind=R_GRID), pointer :: dx_const - real(kind=R_GRID), pointer :: dy_const - real(kind=R_GRID), pointer :: deglon_start, deglon_stop, & ! boundaries of latlon patch - deglat_start, deglat_stop - real(kind=R_GRID), pointer :: deglat - - logical, pointer :: nested, twowaynest - logical, pointer :: regional - integer, pointer :: bc_update_interval - integer, pointer :: parent_tile, refinement, nestbctype, nestupdate, nsponge, ioffset, joffset - real, pointer :: s_weight, update_blend - - integer, pointer :: layout(:), io_layout(:) - - integer :: ntilesMe ! Number of tiles on this process =1 for now - -#ifdef OVERLOAD_R4 - real :: too_big = 1.E8 -#else - real :: too_big = 1.E35 -#endif - public :: fv_init - - integer, public :: ngrids = 1 - integer, public, allocatable :: pelist_all(:) - integer :: commID, max_refinement_of_global = 1. - integer :: gid - - real :: umax = 350. !< max wave speed for grid_type>3 - integer :: parent_grid_num = -1 - - integer :: halo_update_type = 1 !< 1 for two-interfaces non-block - !< 2 for block - !< 3 for four-interfaces non-block - - - -! version number of this module -! Include variable "version" to be written to log file. -#include - - contains - -!------------------------------------------------------------------------------- -!>@brief The subroutine 'fv_init' initializes FV3. -!>@details It allocates memory, sets up MPI and processor lists, -!! sets up the grid, and controls FV3 namelist parameters. - subroutine fv_init(Atm, dt_atmos, grids_on_this_pe, p_split) - - type(fv_atmos_type), allocatable, intent(inout), target :: Atm(:) - real, intent(in) :: dt_atmos - logical, allocatable, intent(INOUT) :: grids_on_this_pe(:) - integer, intent(INOUT) :: p_split - - integer :: i, j, k, n, p - real :: sdt - -! tracers - integer :: num_family !< output of register_tracers - - integer :: isc_p, iec_p, jsc_p, jec_p, isg, ieg, jsg, jeg, upoff, jind - integer :: ic, jc - - gid = mpp_pe() - call init_nesting(Atm, grids_on_this_pe, p_split) - - !This call is needed to set up the pointers for fv_current_grid, even for a single-grid run - call switch_current_Atm(Atm(1), .false.) - call setup_pointers(Atm(1)) - -! Start up MPI - - !call mp_assign_gid - - ! Initialize timing routines - call timing_init - call timing_on('TOTAL') - - ! Setup the run from namelist - ntilesMe = size(Atm(:)) !Full number of Atm arrays; one less than number of grids, if multiple grids - - call run_setup(Atm,dt_atmos, grids_on_this_pe, p_split) ! initializes domain_decomp - - do n=1,ntilesMe - - !In a single-grid run this will still be needed to correctly set the domain - call switch_current_Atm(Atm(n)) - call setup_pointers(Atm(n)) - - target_lon = target_lon * pi/180. - target_lat = target_lat * pi/180. - - - if (grids_on_this_pe(n)) then - call allocate_fv_atmos_type(Atm(n), Atm(n)%bd%isd, Atm(n)%bd%ied, Atm(n)%bd%jsd, Atm(n)%bd%jed, & - Atm(n)%bd%isc, Atm(n)%bd%iec, Atm(n)%bd%jsc, Atm(n)%bd%jec, & - npx, npy, npz, ndims, ncnst, ncnst-pnats, ng, .false., grids_on_this_pe(n), ngrids) - - if (grids_on_this_pe(n)) then - - call switch_current_Atm(Atm(n)) - call setup_pointers(Atm(n)) - - if ( (Atm(n)%bd%iec-Atm(n)%bd%isc+1).lt.4 .or. (Atm(n)%bd%jec-Atm(n)%bd%jsc+1).lt.4 ) then - if (is_master()) write(*,'(6I6)') Atm(n)%bd%isc, Atm(n)%bd%iec, Atm(n)%bd%jsc, Atm(n)%bd%jec, n - call mpp_error(FATAL,'Domain Decomposition: Cubed Sphere compute domain has a & - &minium requirement of 4 points in X and Y, respectively') - end if - - endif - - !!CLEANUP: Convenience pointers - Atm(n)%gridstruct%nested => Atm(n)%neststruct%nested - Atm(n)%gridstruct%grid_type => Atm(n)%flagstruct%grid_type - Atm(n)%flagstruct%grid_number => Atm(n)%grid_number - Atm(n)%gridstruct%regional => Atm(n)%flagstruct%regional - - call init_grid(Atm(n), grid_name, grid_file, npx, npy, npz, ndims, ntiles, ng) - - ! Initialize the SW (2D) part of the model - !!!CLEANUP: this call could definitely use some cleaning up - call grid_utils_init(Atm(n), npx, npy, npz, non_ortho, grid_type, c2l_ord) - - !!!CLEANUP: Are these correctly writing out on all pes? - if ( is_master() ) then - sdt = dt_atmos/real(n_split*k_split*abs(p_split)) - write(*,*) ' ' - write(*,*) 'Divergence damping Coefficients' - write(*,*) 'For small dt=', sdt - write(*,*) 'External mode del-2 (m**2/s)=', d_ext*Atm(n)%gridstruct%da_min_c/sdt - write(*,*) 'Internal mode del-2 SMAG dimensionless coeff=', dddmp - write(*,*) 'Internal mode del-2 background diff=', d2_bg*Atm(n)%gridstruct%da_min_c/sdt - - if (nord==1) then - write(*,*) 'Internal mode del-4 background diff=', d4_bg - write(*,*) 'Vorticity del-4 (m**4/s)=', (vtdm4*Atm(n)%gridstruct%da_min)**2/sdt*1.E-6 - endif - if (nord==2) write(*,*) 'Internal mode del-6 background diff=', d4_bg - if (nord==3) write(*,*) 'Internal mode del-8 background diff=', d4_bg - write(*,*) 'tracer del-2 diff=', trdm2 - - write(*,*) 'Vorticity del-4 (m**4/s)=', (vtdm4*Atm(n)%gridstruct%da_min)**2/sdt*1.E-6 - write(*,*) 'beta=', beta - write(*,*) ' ' - endif - - - Atm(n)%ts = 300. - Atm(n)%phis = too_big - ! The following statements are to prevent the phatom corner regions from - ! growing instability - Atm(n)%u = 0. - Atm(n)%v = 0. - Atm(n)%ua = too_big - Atm(n)%va = too_big - - else !this grid is NOT defined on this pe - - !Allocate dummy arrays - call allocate_fv_atmos_type(Atm(n), Atm(n)%bd%isd, Atm(n)%bd%ied, Atm(n)%bd%jsd, Atm(n)%bd%jed, & - Atm(n)%bd%isc, Atm(n)%bd%iec, Atm(n)%bd%jsc, Atm(n)%bd%jec, & - npx, npy, npz, ndims, ncnst, ncnst-pnats, ng, .true., .false., ngrids) - - !Need to SEND grid_global to any child grids; this is received in setup_aligned_nest in fv_grid_tools - if (Atm(n)%neststruct%nested) then - - call mpp_get_global_domain( Atm(n)%parent_grid%domain, & - isg, ieg, jsg, jeg) - - !FIXME: Should replace this by generating the global grid (or at least one face thereof) on the - ! nested PEs instead of sending it around. - if (gid == Atm(n)%parent_grid%pelist(1)) then - call mpp_send(Atm(n)%parent_grid%grid_global(isg-ng:ieg+1+ng,jsg-ng:jeg+1+ng,1:2,parent_tile), & - size(Atm(n)%parent_grid%grid_global(isg-ng:ieg+1+ng,jsg-ng:jeg+1+ng,1:2,parent_tile)), & - Atm(n)%pelist(1)) !send to p_ind in setup_aligned_nest - call mpp_sync_self() - endif - - if (Atm(n)%neststruct%twowaynest) then - - !This in reality should be very simple. With the - ! restriction that only the compute domain data is - ! sent from the coarse grid, we can compute - ! exactly which coarse grid cells should use - ! which nested-grid data. We then don't need to send around p_ind. - - Atm(n)%neststruct%ind_update_h = -99999 - - if (Atm(n)%parent_grid%tile == Atm(n)%neststruct%parent_tile) then - - isc_p = Atm(n)%parent_grid%bd%isc - iec_p = Atm(n)%parent_grid%bd%iec - jsc_p = Atm(n)%parent_grid%bd%jsc - jec_p = Atm(n)%parent_grid%bd%jec - upoff = Atm(n)%neststruct%upoff - - Atm(n)%neststruct%jsu = jsc_p - Atm(n)%neststruct%jeu = jsc_p-1 - do j=jsc_p,jec_p+1 - if (j < joffset+upoff) then - do i=isc_p,iec_p+1 - Atm(n)%neststruct%ind_update_h(i,j,2) = -9999 - enddo - Atm(n)%neststruct%jsu = Atm(n)%neststruct%jsu + 1 - elseif (j > joffset + (npy-1)/refinement - upoff) then - do i=isc_p,iec_p+1 - Atm(n)%neststruct%ind_update_h(i,j,2) = -9999 - enddo - else - jind = (j - joffset)*refinement + 1 - do i=isc_p,iec_p+1 - Atm(n)%neststruct%ind_update_h(i,j,2) = jind - enddo - if ( (j < joffset + (npy-1)/refinement - upoff) .and. j <= jec_p) Atm(n)%neststruct%jeu = j - endif - !write(mpp_pe()+4000,*) j, joffset, upoff, Atm(n)%neststruct%ind_update_h(isc_p,j,2) - enddo - - Atm(n)%neststruct%isu = isc_p - Atm(n)%neststruct%ieu = isc_p-1 - do i=isc_p,iec_p+1 - if (i < ioffset+upoff) then - Atm(n)%neststruct%ind_update_h(i,:,1) = -9999 - Atm(n)%neststruct%isu = Atm(n)%neststruct%isu + 1 - elseif (i > ioffset + (npx-1)/refinement - upoff) then - Atm(n)%neststruct%ind_update_h(i,:,1) = -9999 - else - Atm(n)%neststruct%ind_update_h(i,:,1) = (i-ioffset)*refinement + 1 - if ( (i < ioffset + (npx-1)/refinement - upoff) .and. i <= iec_p) Atm(n)%neststruct%ieu = i - end if - !write(mpp_pe()+5000,*) i, ioffset, upoff, Atm(n)%neststruct%ind_update_h(i,jsc_p,1) - enddo - - end if - - - end if - - endif - endif - end do - - if (ntilesMe > 1) call switch_current_Atm(Atm(1)) - if (ntilesMe > 1) call setup_pointers(Atm(1)) - - end subroutine fv_init -!------------------------------------------------------------------------------- - - -!>@brief The subroutine 'run_setup' initializes the run from a namelist. - subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) - type(fv_atmos_type), intent(inout), target :: Atm(:) - real, intent(in) :: dt_atmos - logical, intent(INOUT) :: grids_on_this_pe(:) - integer, intent(INOUT) :: p_split - !--- local variables --- - character(len=80) :: tracerName, errString - character(len=32) :: nested_grid_filename - integer :: ios, ierr, f_unit, unit - logical :: exists - - real :: dim0 = 180. !< base dimension - real :: dt0 = 1800. !< base time step - real :: ns0 = 5. !< base nsplit for base dimension - !< For cubed sphere 5 is better - !real :: umax = 350. ! max wave speed for grid_type>3 ! Now defined above - real :: dimx, dl, dp, dxmin, dymin, d_fac - - integer :: n0split - integer :: n, nn, i - - integer :: pe_counter - -! local version of these variables to allow PGI compiler to compile - character(len=128) :: res_latlon_dynamics = '' - character(len=128) :: res_latlon_tracers = '' - character(len=80) :: grid_name = '' - character(len=120) :: grid_file = '' - - namelist /fv_grid_nml/ grid_name, grid_file - namelist /fv_core_nml/npx, npy, ntiles, npz, npz_rst, layout, io_layout, ncnst, nwat, & - use_logp, p_fac, a_imp, k_split, n_split, m_split, q_split, print_freq, write_3d_diags, do_schmidt, & - hord_mt, hord_vt, hord_tm, hord_dp, hord_tr, shift_fac, stretch_fac, target_lat, target_lon, & - kord_mt, kord_wz, kord_tm, kord_tr, fv_debug, fv_land, nudge, do_sat_adj, do_f3d, & - external_ic, read_increment, ncep_ic, nggps_ic, ecmwf_ic, use_new_ncep, use_ncep_phy, fv_diag_ic, & - external_eta, res_latlon_dynamics, res_latlon_tracers, scale_z, w_max, z_min, lim_fac, & - dddmp, d2_bg, d4_bg, vtdm4, trdm2, d_ext, delt_max, beta, non_ortho, n_sponge, & - warm_start, adjust_dry_mass, mountain, d_con, ke_bg, nord, nord_tr, convert_ke, use_old_omega, & - dry_mass, grid_type, do_Held_Suarez, do_reed_physics, reed_cond_only, & - consv_te, fill, filter_phys, fill_dp, fill_wz, consv_am, RF_fast, & - range_warn, dwind_2d, inline_q, z_tracer, reproduce_sum, adiabatic, do_vort_damp, no_dycore, & - tau, tau_h2o, rf_cutoff, nf_omega, hydrostatic, fv_sg_adj, breed_vortex_inline, & - na_init, nudge_dz, hybrid_z, Make_NH, n_zs_filter, nord_zs_filter, full_zs_filter, reset_eta, & - pnats, dnats, a2b_ord, remap_t, p_ref, d2_bg_k1, d2_bg_k2, & - c2l_ord, dx_const, dy_const, umax, deglat, & - deglon_start, deglon_stop, deglat_start, deglat_stop, & - phys_hydrostatic, use_hydro_pressure, make_hybrid_z, old_divg_damp, add_noise, & - nested, twowaynest, parent_grid_num, parent_tile, nudge_qv, & - refinement, nestbctype, nestupdate, nsponge, s_weight, & - ioffset, joffset, check_negative, nudge_ic, halo_update_type, gfs_phil, agrid_vel_rst, & - do_uni_zfull, adj_mass_vmr, fac_n_spl, fhouri, regional, bc_update_interval - - namelist /test_case_nml/test_case, bubble_do, alpha, nsolitons, soliton_Umax, soliton_size -#ifdef MULTI_GASES - namelist /multi_gases_nml/ rilist,cpilist -#endif - - - pe_counter = mpp_root_pe() - -! Make alpha = 0 the default: - alpha = 0. - bubble_do = .false. - test_case = 11 ! (USGS terrain) - -#ifdef INTERNAL_FILE_NML -! Read Main namelist - read (input_nml_file,fv_grid_nml,iostat=ios) - ierr = check_nml_error(ios,'fv_grid_nml') -#else - f_unit=open_namelist_file() - rewind (f_unit) -! Read Main namelist - read (f_unit,fv_grid_nml,iostat=ios) - ierr = check_nml_error(ios,'fv_grid_nml') - call close_file(f_unit) -#endif - - call write_version_number ( 'FV_CONTROL_MOD', version ) - unit = stdlog() - write(unit, nml=fv_grid_nml) - - do n=1,size(Atm) - - call switch_current_Atm(Atm(n), .false.) - call setup_pointers(Atm(n)) - Atm(n)%grid_number = n - if (grids_on_this_pe(n)) then - call fv_diag_init_gn(Atm(n)) - endif - -#ifdef INTERNAL_FILE_NML - ! Set input_file_nml for correct parent/nest initialization - if (n > 1) then - write(nested_grid_filename,'(A4, I2.2)') 'nest', n - call read_input_nml(nested_grid_filename) - endif - ! Read FVCORE namelist - read (input_nml_file,fv_core_nml,iostat=ios) - ierr = check_nml_error(ios,'fv_core_nml') -#ifdef MULTI_GASES - if( is_master() ) print *,' enter multi_gases: ncnst = ',ncnst - allocate (rilist(0:ncnst)) - allocate (cpilist(0:ncnst)) - rilist = 0.0 - cpilist = 0.0 - rilist(0) = rdgas - rilist(1) = rvgas - cpilist(0) = cp_air - cpilist(1) = 4*cp_air - ! Read multi_gases namelist - read (input_nml_file,multi_gases_nml,iostat=ios) - ierr = check_nml_error(ios,'multi_gases_nml') -#endif - ! Read Test_Case namelist - read (input_nml_file,test_case_nml,iostat=ios) - ierr = check_nml_error(ios,'test_case_nml') - - ! Reset input_file_nml to default behavior - call read_input_nml -#else - if (size(Atm) == 1) then - f_unit = open_namelist_file() - else if (n == 1) then - f_unit = open_namelist_file('input.nml') - else - write(nested_grid_filename,'(A10, I2.2, A4)') 'input_nest', n, '.nml' - f_unit = open_namelist_file(nested_grid_filename) - endif - - ! Read FVCORE namelist - read (f_unit,fv_core_nml,iostat=ios) - ierr = check_nml_error(ios,'fv_core_nml') - -#ifdef MULTI_GASES - if( is_master() ) print *,' enter multi_gases: ncnst = ',ncnst - allocate (rilist(0:ncnst)) - allocate (cpilist(0:ncnst)) - rilist = 0.0 - cpilist = 0.0 - rilist(0) = rdgas - rilist(1) = rvgas - cpilist(0) = cp_air - cpilist(1) = 4*cp_air - ! Read multi_gases namelist - rewind (f_unit) - read (f_unit,multi_gases_nml,iostat=ios) - ierr = check_nml_error(ios,'multi_gases_nml') -#endif - ! Read Test_Case namelist - rewind (f_unit) - read (f_unit,test_case_nml,iostat=ios) - ierr = check_nml_error(ios,'test_case_nml') - call close_file(f_unit) -#endif - write(unit, nml=fv_core_nml) - write(unit, nml=test_case_nml) -#ifdef MULTI_GASES - write(unit, nml=multi_gases_nml) - call multi_gases_init(ncnst,nwat) -#endif - - if (len_trim(grid_file) /= 0) Atm(n)%flagstruct%grid_file = grid_file - if (len_trim(grid_name) /= 0) Atm(n)%flagstruct%grid_name = grid_name - if (len_trim(res_latlon_dynamics) /= 0) Atm(n)%flagstruct%res_latlon_dynamics = res_latlon_dynamics - if (len_trim(res_latlon_tracers) /= 0) Atm(n)%flagstruct%res_latlon_tracers = res_latlon_tracers - - !*** single tile for Cartesian grids - if (grid_type>3) then - ntiles=1 - non_ortho = .false. - nf_omega = 0 - endif - - if (.not. (nested .or. regional)) Atm(n)%neststruct%npx_global = npx - - ! Define n_split if not in namelist - if (ntiles == 6) then - dimx = 4.0*(npx-1) - if ( hydrostatic ) then - if ( npx >= 120 ) ns0 = 6 - else - if ( npx <= 45 ) then - ns0 = 6 - elseif ( npx <= 90 ) then - ns0 = 7 - else - ns0 = 8 - endif - endif - else - dimx = max ( npx, 2*(npy-1) ) - endif - - if (grid_type < 4) then - n0split = nint ( ns0*abs(dt_atmos)*dimx/(dt0*dim0) + 0.49 ) - elseif (grid_type == 4 .or. grid_type == 7) then - n0split = nint ( 2.*umax*dt_atmos/sqrt(dx_const**2 + dy_const**2) + 0.49 ) - elseif (grid_type == 5 .or. grid_type == 6) then - if (grid_type == 6) then - deglon_start = 0.; deglon_stop = 360. - endif - dl = (deglon_stop-deglon_start)*pi/(180.*(npx-1)) - dp = (deglat_stop-deglat_start)*pi/(180.*(npy-1)) - - dxmin=dl*radius*min(cos(deglat_start*pi/180.-ng*dp), & - cos(deglat_stop *pi/180.+ng*dp)) - dymin=dp*radius - n0split = nint ( 2.*umax*dt_atmos/sqrt(dxmin**2 + dymin**2) + 0.49 ) - endif - n0split = max ( 1, n0split ) - - if ( n_split == 0 ) then - n_split = nint( real(n0split)/real(k_split*abs(p_split)) * stretch_fac + 0.5 ) - if(is_master()) write(*,*) 'For k_split (remapping)=', k_split - if(is_master()) write(*,198) 'n_split is set to ', n_split, ' for resolution-dt=',npx,npy,ntiles,dt_atmos - else - if(is_master()) write(*,199) 'Using n_split from the namelist: ', n_split - endif - if (is_master() .and. n == 1 .and. abs(p_split) > 1) then - write(*,199) 'Using p_split = ', p_split - endif - - if (Atm(n)%neststruct%nested) then - do i=1,n-1 - if (Atm(i)%grid_number == parent_grid_num) then - Atm(n)%parent_grid => Atm(i) - exit - end if - end do - if (.not. associated(Atm(n)%parent_grid)) then - write(errstring,'(2(A,I3))') "Could not find parent grid #", parent_grid_num, ' for grid #', n - call mpp_error(FATAL, errstring) - end if - - !Note that if a gnomonic grid has a parent it is a NESTED gnomonic grid and therefore only has one tile - if ( Atm(n)%parent_grid%flagstruct%grid_type < 3 .and. & - .not. associated(Atm(n)%parent_grid%parent_grid)) then - if (parent_tile > 6 .or. parent_tile < 1) then - call mpp_error(FATAL, 'parent tile must be between 1 and 6 if the parent is a cubed-sphere grid') - end if - else - if (parent_tile /= 1) then - call mpp_error(FATAL, 'parent tile must be 1 if the parent is not a cubed-sphere grid') - end if - end if - - if ( refinement < 1 ) call mpp_error(FATAL, 'grid refinement must be positive') - - if (nestupdate == 1 .or. nestupdate == 2) then - - if (mod(npx-1,refinement) /= 0 .or. mod(npy-1,refinement) /= 0) then - call mpp_error(WARNING, 'npx-1 or npy-1 is not evenly divisible by the refinement ratio; averaging update cannot be mass-conservative.') - end if - - end if - - if ( consv_te > 0.) then - call mpp_error(FATAL, 'The global energy fixer cannot be used on a nested grid. consv_te must be set to 0.') - end if - - Atm(n)%neststruct%refinement_of_global = Atm(n)%neststruct%refinement * Atm(n)%parent_grid%neststruct%refinement_of_global - max_refinement_of_global = max(Atm(n)%neststruct%refinement_of_global,max_refinement_of_global) - Atm(n)%neststruct%npx_global = Atm(n)%neststruct%refinement * Atm(n)%parent_grid%neststruct%npx_global - - else - Atm(n)%neststruct%ioffset = -999 - Atm(n)%neststruct%joffset = -999 - Atm(n)%neststruct%parent_tile = -1 - Atm(n)%neststruct%refinement = -1 - end if - - if (Atm(n)%neststruct%nested) then - if (Atm(n)%flagstruct%grid_type >= 4 .and. Atm(n)%parent_grid%flagstruct%grid_type >= 4) then - Atm(n)%flagstruct%dx_const = Atm(n)%parent_grid%flagstruct%dx_const / real(Atm(n)%neststruct%refinement) - Atm(n)%flagstruct%dy_const = Atm(n)%parent_grid%flagstruct%dy_const / real(Atm(n)%neststruct%refinement) - end if - end if - - -!---------------------------------------- -! Adjust divergence damping coefficients: -!---------------------------------------- -! d_fac = real(n0split)/real(n_split) -! dddmp = dddmp * d_fac -! d2_bg = d2_bg * d_fac -! d4_bg = d4_bg * d_fac -! d_ext = d_ext * d_fac -! vtdm4 = vtdm4 * d_fac - if (old_divg_damp) then - if (is_master()) write(*,*) " fv_control: using original values for divergence damping " - d2_bg_k1 = 6. ! factor for d2_bg (k=1) - default(4.) - d2_bg_k2 = 4. ! factor for d2_bg (k=2) - default(2.) - d2_divg_max_k1 = 0.02 ! d2_divg max value (k=1) - default(0.05) - d2_divg_max_k2 = 0.01 ! d2_divg max value (k=2) - default(0.02) - damp_k_k1 = 0. ! damp_k value (k=1) - default(0.05) - damp_k_k2 = 0. ! damp_k value (k=2) - default(0.025) - elseif (n_sponge == 0 ) then - if ( d2_bg_k1 > 1. ) d2_bg_k1 = 0.20 - if ( d2_bg_k2 > 1. ) d2_bg_k2 = 0.015 - endif - -! if ( beta < 1.e-5 ) beta = 0. ! beta < 0 is used for non-hydrostatic "one_grad_p" - - if ( .not.hydrostatic ) then - if ( m_split==0 ) then - m_split = 1. + abs(dt_atmos)/real(k_split*n_split*abs(p_split)) - if (abs(a_imp) < 0.5) then - if(is_master()) write(*,199) 'm_split is set to ', m_split - endif - endif - if(is_master()) then - write(*,*) 'Off center implicit scheme param=', a_imp - write(*,*) ' p_fac=', p_fac - endif - endif - - if(is_master()) then - if (n_sponge >= 0) write(*,199) 'Using n_sponge : ', n_sponge - write(*,197) 'Using non_ortho : ', non_ortho - endif - - 197 format(A,l7) - 198 format(A,i2.2,A,i4.4,'x',i4.4,'x',i1.1,'-',f9.3) - 199 format(A,i3.3) - - if (.not. (nested .or. regional)) alpha = alpha*pi - - - allocate(Atm(n)%neststruct%child_grids(size(Atm))) - Atm(N)%neststruct%child_grids = .false. - - !Broadcast data - - !Check layout - - enddo - - !Set pelists - do n=1,size(Atm) - if (ANY(Atm(n)%pelist == gid)) then - call mpp_set_current_pelist(Atm(n)%pelist) - call mpp_get_current_pelist(Atm(n)%pelist, commID=commID) - call mp_start(commID,halo_update_type) - endif - - if (Atm(n)%neststruct%nested) then - Atm(n)%neststruct%parent_proc = ANY(Atm(n)%parent_grid%pelist == gid) - Atm(n)%neststruct%child_proc = ANY(Atm(n)%pelist == gid) - endif - enddo - - do n=1,size(Atm) - - call switch_current_Atm(Atm(n),.false.) - call setup_pointers(Atm(n)) - !! CLEANUP: WARNING not sure what changes to domain_decomp may cause - call domain_decomp(npx,npy,ntiles,grid_type,nested,Atm(n),layout,io_layout) - enddo - - !!! CLEANUP: This sets the pelist to ALL, which is also - !!! required for the define_nest_domains step in the next loop. - !!! Later the pelist must be reset to the 'local' pelist. - call broadcast_domains(Atm) - - do n=1,size(Atm) - call switch_current_Atm(Atm(n)) - call setup_pointers(Atm(n)) - - if (nested) then - if (mod(npx-1 , refinement) /= 0 .or. mod(npy-1, refinement) /= 0) & - call mpp_error(FATAL, 'npx or npy not an even refinement of its coarse grid.') - - !Pelist needs to be set to ALL (which should have been done - !in broadcast_domains) to get this to work - call mpp_define_nest_domains(Atm(n)%neststruct%nest_domain, Atm(n)%domain, Atm(parent_grid_num)%domain, & - 7, parent_tile, & - 1, npx-1, 1, npy-1, & !Grid cells, not points - ioffset, ioffset + (npx-1)/refinement - 1, & - joffset, joffset + (npy-1)/refinement - 1, & - (/ (i,i=0,mpp_npes()-1) /), extra_halo = 0, name="nest_domain") !What pelist to use? - call mpp_define_nest_domains(Atm(n)%neststruct%nest_domain, Atm(n)%domain, Atm(parent_grid_num)%domain, & - 7, parent_tile, & - 1, npx-1, 1, npy-1, & !Grid cells, not points - ioffset, ioffset + (npx-1)/refinement - 1, & - joffset, joffset + (npy-1)/refinement - 1, & - (/ (i,i=0,mpp_npes()-1) /), extra_halo = 0, name="nest_domain") !What pelist to use? -! (/ (i,i=0,mpp_npes()-1) /), extra_halo = 2, name="nest_domain_for_BC") !What pelist to use? - - Atm(parent_grid_num)%neststruct%child_grids(n) = .true. - - if (Atm(n)%neststruct%nestbctype > 1) then - - call mpp_error(FATAL, 'nestbctype > 1 not yet implemented') - - !This check is due to a bug which has not yet been identified. Beware. -! if (Atm(n)%parent_grid%flagstruct%hord_tr == 7) & -! call mpp_error(FATAL, "Flux-form nested BCs (nestbctype > 1) should not use hord_tr == 7 (on parent grid), since there is no guarantee of tracer mass conservation with this option.") - -!!$ if (Atm(n)%flagstruct%q_split > 0 .and. Atm(n)%parent_grid%flagstruct%q_split > 0) then -!!$ if (mod(Atm(n)%flagstruct%q_split,Atm(n)%parent_grid%flagstruct%q_split) /= 0) call mpp_error(FATAL, & -!!$ "Flux-form nested BCs (nestbctype > 1) require q_split on the nested grid to be evenly divisible by that on the coarse grid.") -!!$ endif -!!$ if (mod((Atm(n)%npx-1),Atm(n)%neststruct%refinement) /= 0 .or. mod((Atm(n)%npy-1),Atm(n)%neststruct%refinement) /= 0) call mpp_error(FATAL, & -!!$ "Flux-form nested BCs (nestbctype > 1) requires npx and npy to be one more than a multiple of the refinement ratio.") -!!$ Atm(n)%parent_grid%neststruct%do_flux_BCs = .true. -!!$ if (Atm(n)%neststruct%nestbctype == 3 .or. Atm(n)%neststruct%nestbctype == 4) Atm(n)%parent_grid%neststruct%do_2way_flux_BCs = .true. - Atm(n)%neststruct%upoff = 0 - endif - - end if - - do nn=1,size(Atm) - if (n == 1) allocate(Atm(nn)%neststruct%nest_domain_all(size(Atm))) - Atm(nn)%neststruct%nest_domain_all(n) = Atm(n)%neststruct%nest_domain - enddo - - end do - - do n=1,size(Atm) - if (ANY(Atm(n)%pelist == gid)) then - call mpp_set_current_pelist(Atm(n)%pelist) - endif - enddo - - end subroutine run_setup - subroutine init_nesting(Atm, grids_on_this_pe, p_split) - - type(fv_atmos_type), intent(inout), allocatable :: Atm(:) - logical, allocatable, intent(INOUT) :: grids_on_this_pe(:) - integer, intent(INOUT) :: p_split - character(100) :: pe_list_name - integer :: nest_pes(100) - integer :: n, npes, ntiles, pecounter, i - integer, allocatable :: pelist(:) - integer :: f_unit, ios, ierr - - !This is an OPTIONAL namelist, that needs to be read before everything else - namelist /nest_nml/ ngrids, ntiles, nest_pes, p_split - - call mp_assign_gid - - nest_pes = 0 - ntiles = -999 - -#ifdef INTERNAL_FILE_NML - read (input_nml_file,nest_nml,iostat=ios) - ierr = check_nml_error(ios,'nest_nml') -#else - f_unit=open_namelist_file() - rewind (f_unit) - read (f_unit,nest_nml,iostat=ios) - ierr = check_nml_error(ios,'nest_nml') - call close_file(f_unit) -#endif - - if (ntiles /= -999) ngrids = ntiles - if (ngrids > 10) call mpp_error(FATAL, "More than 10 nested grids not supported") - - allocate(Atm(ngrids)) - - allocate(grids_on_this_pe(ngrids)) - grids_on_this_pe = .false. !initialization - - npes = mpp_npes() - - ! Need to get a global pelist to send data around later? - allocate( pelist_all(npes) ) - pelist_all = (/ (i,i=0,npes-1) /) - pelist_all = pelist_all + mpp_root_pe() - - if (ngrids == 1) then - - !Set up the single pelist - allocate(Atm(1)%pelist(npes)) - Atm(1)%pelist = (/(i, i=0, npes-1)/) - Atm(1)%pelist = Atm(1)%pelist + mpp_root_pe() - call mpp_declare_pelist(Atm(1)%pelist) - call mpp_set_current_pelist(Atm(1)%pelist) - !Now set in domain_decomp - !masterproc = Atm(1)%pelist(1) - call setup_master(Atm(1)%pelist) - grids_on_this_pe(1) = .true. - Atm(1)%npes_this_grid = npes - - else - - pecounter = mpp_root_pe() - do n=1,ngrids - if (n == 1) then - pe_list_name = '' - else - write(pe_list_name,'(A4, I2.2)') 'nest', n - endif - - if (nest_pes(n) == 0) then - if (n < ngrids) call mpp_error(FATAL, 'Only nest_pes(ngrids) in nest_nml can be zero; preceeding values must be nonzero.') - allocate(Atm(n)%pelist(npes-pecounter)) - Atm(n)%pelist = (/(i, i=pecounter, npes-1)/) - if (n > 1) then - call mpp_declare_pelist(Atm(n)%pelist, trim(pe_list_name)) - !Make sure nested-grid input file exists - if (.not. file_exist('input_'//trim(pe_list_name)//'.nml')) then - call mpp_error(FATAL, "Could not find nested grid namelist input_"//trim(pe_list_name)//".nml") - endif - endif - exit - else - allocate(Atm(n)%pelist(nest_pes(n))) - Atm(n)%pelist = (/ (i, i=pecounter, pecounter+nest_pes(n)-1) /) - if (Atm(n)%pelist(nest_pes(n)) >= npes) then - call mpp_error(FATAL, 'PEs assigned by nest_pes in nest_nml exceeds number of available PEs.') - endif - - call mpp_declare_pelist(Atm(n)%pelist, trim(pe_list_name)) - !Make sure nested-grid input file exists - if (n > 1) then - if (.not. file_exist('input_'//trim(pe_list_name)//'.nml')) then - call mpp_error(FATAL, "Could not find nested grid namelist input_"//trim(pe_list_name)//".nml") - endif - endif - pecounter = pecounter+nest_pes(n) - endif - enddo - - !Set pelists - do n=1,ngrids - Atm(n)%npes_this_grid = size(Atm(n)%pelist) - if (ANY(gid == Atm(n)%pelist)) then - call mpp_set_current_pelist(Atm(n)%pelist) - !now set in domain_decomp - !masterproc = Atm(n)%pelist(1) - call setup_master(Atm(n)%pelist) - grids_on_this_pe(n) = .true. - exit - endif - enddo - - if (pecounter /= npes) then - call mpp_error(FATAL, 'nest_pes in nest_nml does not assign all of the available PEs.') - endif - endif - - !Layout is checked later, in fv_control - - end subroutine init_nesting - -!>@brief The subroutine 'setup_pointers' associates the MODULE flag pointers -!! with the ARRAY flag variables for the grid active on THIS pe so the flags -!! can be read in from the namelist. - subroutine setup_pointers(Atm) - - type(fv_atmos_type), intent(INOUT), target :: Atm - - !This routine associates the MODULE flag pointers with the ARRAY flag variables for the grid active on THIS pe so the flags can be read in from the namelist. - - res_latlon_dynamics => Atm%flagstruct%res_latlon_dynamics - res_latlon_tracers => Atm%flagstruct%res_latlon_tracers - - grid_type => Atm%flagstruct%grid_type - grid_name => Atm%flagstruct%grid_name - grid_file => Atm%flagstruct%grid_file - hord_mt => Atm%flagstruct%hord_mt - kord_mt => Atm%flagstruct%kord_mt - kord_wz => Atm%flagstruct%kord_wz - hord_vt => Atm%flagstruct%hord_vt - hord_tm => Atm%flagstruct%hord_tm - hord_dp => Atm%flagstruct%hord_dp - kord_tm => Atm%flagstruct%kord_tm - hord_tr => Atm%flagstruct%hord_tr - kord_tr => Atm%flagstruct%kord_tr - scale_z => Atm%flagstruct%scale_z - w_max => Atm%flagstruct%w_max - z_min => Atm%flagstruct%z_min - lim_fac => Atm%flagstruct%lim_fac - nord => Atm%flagstruct%nord - nord_tr => Atm%flagstruct%nord_tr - dddmp => Atm%flagstruct%dddmp - d2_bg => Atm%flagstruct%d2_bg - d4_bg => Atm%flagstruct%d4_bg - vtdm4 => Atm%flagstruct%vtdm4 - trdm2 => Atm%flagstruct%trdm2 - d2_bg_k1 => Atm%flagstruct%d2_bg_k1 - d2_bg_k2 => Atm%flagstruct%d2_bg_k2 - d2_divg_max_k1 => Atm%flagstruct%d2_divg_max_k1 - d2_divg_max_k2 => Atm%flagstruct%d2_divg_max_k2 - damp_k_k1 => Atm%flagstruct%damp_k_k1 - damp_k_k2 => Atm%flagstruct%damp_k_k2 - n_zs_filter => Atm%flagstruct%n_zs_filter - nord_zs_filter => Atm%flagstruct%nord_zs_filter - full_zs_filter => Atm%flagstruct%full_zs_filter - RF_fast => Atm%flagstruct%RF_fast - consv_am => Atm%flagstruct%consv_am - do_sat_adj => Atm%flagstruct%do_sat_adj - do_f3d => Atm%flagstruct%do_f3d - no_dycore => Atm%flagstruct%no_dycore - convert_ke => Atm%flagstruct%convert_ke - do_vort_damp => Atm%flagstruct%do_vort_damp - use_old_omega => Atm%flagstruct%use_old_omega - beta => Atm%flagstruct%beta - n_sponge => Atm%flagstruct%n_sponge - d_ext => Atm%flagstruct%d_ext - nwat => Atm%flagstruct%nwat - use_logp => Atm%flagstruct%use_logp - warm_start => Atm%flagstruct%warm_start - inline_q => Atm%flagstruct%inline_q - shift_fac => Atm%flagstruct%shift_fac - do_schmidt => Atm%flagstruct%do_schmidt - stretch_fac => Atm%flagstruct%stretch_fac - target_lat => Atm%flagstruct%target_lat - target_lon => Atm%flagstruct%target_lon - regional => Atm%flagstruct%regional - bc_update_interval => Atm%flagstruct%bc_update_interval - reset_eta => Atm%flagstruct%reset_eta - p_fac => Atm%flagstruct%p_fac - a_imp => Atm%flagstruct%a_imp - n_split => Atm%flagstruct%n_split - fac_n_spl => Atm%flagstruct%fac_n_spl - fhouri => Atm%flagstruct%fhouri - m_split => Atm%flagstruct%m_split - k_split => Atm%flagstruct%k_split - use_logp => Atm%flagstruct%use_logp - q_split => Atm%flagstruct%q_split - print_freq => Atm%flagstruct%print_freq - write_3d_diags => Atm%flagstruct%write_3d_diags - npx => Atm%flagstruct%npx - npy => Atm%flagstruct%npy - npz => Atm%flagstruct%npz - npz_rst => Atm%flagstruct%npz_rst - ncnst => Atm%flagstruct%ncnst - pnats => Atm%flagstruct%pnats - dnats => Atm%flagstruct%dnats - ntiles => Atm%flagstruct%ntiles - nf_omega => Atm%flagstruct%nf_omega - fv_sg_adj => Atm%flagstruct%fv_sg_adj - na_init => Atm%flagstruct%na_init - nudge_dz => Atm%flagstruct%nudge_dz - p_ref => Atm%flagstruct%p_ref - dry_mass => Atm%flagstruct%dry_mass - nt_prog => Atm%flagstruct%nt_prog - nt_phys => Atm%flagstruct%nt_phys - tau_h2o => Atm%flagstruct%tau_h2o - delt_max => Atm%flagstruct%delt_max - d_con => Atm%flagstruct%d_con - ke_bg => Atm%flagstruct%ke_bg - consv_te => Atm%flagstruct%consv_te - tau => Atm%flagstruct%tau - rf_cutoff => Atm%flagstruct%rf_cutoff - filter_phys => Atm%flagstruct%filter_phys - dwind_2d => Atm%flagstruct%dwind_2d - breed_vortex_inline => Atm%flagstruct%breed_vortex_inline - range_warn => Atm%flagstruct%range_warn - fill => Atm%flagstruct%fill - fill_dp => Atm%flagstruct%fill_dp - fill_wz => Atm%flagstruct%fill_wz - check_negative => Atm%flagstruct%check_negative - non_ortho => Atm%flagstruct%non_ortho - adiabatic => Atm%flagstruct%adiabatic - moist_phys => Atm%flagstruct%moist_phys - do_Held_Suarez => Atm%flagstruct%do_Held_Suarez - do_reed_physics => Atm%flagstruct%do_reed_physics - reed_cond_only => Atm%flagstruct%reed_cond_only - reproduce_sum => Atm%flagstruct%reproduce_sum - adjust_dry_mass => Atm%flagstruct%adjust_dry_mass - fv_debug => Atm%flagstruct%fv_debug - srf_init => Atm%flagstruct%srf_init - mountain => Atm%flagstruct%mountain - remap_t => Atm%flagstruct%remap_t - z_tracer => Atm%flagstruct%z_tracer - old_divg_damp => Atm%flagstruct%old_divg_damp - fv_land => Atm%flagstruct%fv_land - nudge => Atm%flagstruct%nudge - nudge_ic => Atm%flagstruct%nudge_ic - ncep_ic => Atm%flagstruct%ncep_ic - nggps_ic => Atm%flagstruct%nggps_ic - ecmwf_ic => Atm%flagstruct%ecmwf_ic - gfs_phil => Atm%flagstruct%gfs_phil - agrid_vel_rst => Atm%flagstruct%agrid_vel_rst - use_new_ncep => Atm%flagstruct%use_new_ncep - use_ncep_phy => Atm%flagstruct%use_ncep_phy - fv_diag_ic => Atm%flagstruct%fv_diag_ic - external_ic => Atm%flagstruct%external_ic - external_eta => Atm%flagstruct%external_eta - read_increment => Atm%flagstruct%read_increment - - hydrostatic => Atm%flagstruct%hydrostatic - phys_hydrostatic => Atm%flagstruct%phys_hydrostatic - use_hydro_pressure => Atm%flagstruct%use_hydro_pressure - do_uni_zfull => Atm%flagstruct%do_uni_zfull !miz - adj_mass_vmr => Atm%flagstruct%adj_mass_vmr !f1p - hybrid_z => Atm%flagstruct%hybrid_z - Make_NH => Atm%flagstruct%Make_NH - make_hybrid_z => Atm%flagstruct%make_hybrid_z - nudge_qv => Atm%flagstruct%nudge_qv - add_noise => Atm%flagstruct%add_noise - a2b_ord => Atm%flagstruct%a2b_ord - c2l_ord => Atm%flagstruct%c2l_ord - ndims => Atm%flagstruct%ndims - - dx_const => Atm%flagstruct%dx_const - dy_const => Atm%flagstruct%dy_const - deglon_start => Atm%flagstruct%deglon_start - deglon_stop => Atm%flagstruct%deglon_stop - deglat_start => Atm%flagstruct%deglat_start - deglat_stop => Atm%flagstruct%deglat_stop - - deglat => Atm%flagstruct%deglat - - nested => Atm%neststruct%nested - twowaynest => Atm%neststruct%twowaynest - parent_tile => Atm%neststruct%parent_tile - refinement => Atm%neststruct%refinement - nestbctype => Atm%neststruct%nestbctype - nestupdate => Atm%neststruct%nestupdate - nsponge => Atm%neststruct%nsponge - s_weight => Atm%neststruct%s_weight - ioffset => Atm%neststruct%ioffset - joffset => Atm%neststruct%joffset - - layout => Atm%layout - io_layout => Atm%io_layout - end subroutine setup_pointers - - -end module fv_control_stub_mod diff --git a/get_lats_node_a_stochy.f b/get_lats_node_a_stochy.f deleted file mode 100644 index 986afea0..00000000 --- a/get_lats_node_a_stochy.f +++ /dev/null @@ -1,93 +0,0 @@ -!>@brief The module 'get_lats_node_a_stochy_mod' contains the subroutine get_lats_node_a_stochy - module get_lats_node_a_stochy_mod - - implicit none - - contains -!>@brief The subroutine 'get_lats_node_a_stochy' calculates the decomposition of the gaussian grid based on the processor layout -!>@details This code is taken from the legacy spectral GFS - subroutine get_lats_node_a_stochy(me_fake,global_lats_a, - & lats_nodes_a_fake,gl_lats_index, - & global_time_sort_index,iprint) -cc - use spectral_layout_mod - implicit none -cc - integer gl_lats_index,gl_start - integer me_fake - integer global_lats_a(latg) - integer lats_nodes_a_fake - integer iprint -cc - integer ijk - integer jptlats - integer lat - integer node,nodesio - integer global_time_sort_index(latg) - integer nodes_tmp -cc -c -!jw if (liope) then -!jw if (icolor.eq.2) then -!jw nodesio=1 -!jw else - nodesio=nodes -!jw endif -!jw else -!jw nodesio=nodes -!jw endif -!! -cc - lat = 1 - nodes_tmp = nodes -!jw if (liope .and. icolor .eq. 2) nodes_tmp = nodes -1 - - gl_start = gl_lats_index -cc............................................. - do ijk=1,latg -cc - do node=1,nodes_tmp - if (node.eq.me_fake+1) then - gl_lats_index=gl_lats_index+1 - global_lats_a(gl_lats_index) = global_time_sort_index(lat) - endif - lat = lat + 1 - if (lat .gt. latg) go to 200 - enddo -cc - do node=nodes_tmp,1,-1 - if (node.eq.me_fake+1) then - gl_lats_index=gl_lats_index+1 - global_lats_a(gl_lats_index) = global_time_sort_index(lat) - endif - lat = lat + 1 - if (lat .gt. latg) go to 200 - enddo -cc - enddo -cc............................................. -cc - 200 continue -cc -cc............................................. -cc -!jw if (liope .and. icolor .eq. 2) gl_start = 0 - do node=1,nodes_tmp - if (node.eq.me_fake+1) then - lats_nodes_a_fake=gl_lats_index-gl_start -c$$$ print*,' setting lats_nodes_a_fake = ', -c$$$ . lats_nodes_a_fake - endif - enddo - - if(iprint.eq.1) print 220 - 220 format ('completed loop 200 in get_lats_a ') -c - if(iprint.eq.1) - & print*,'completed get_lats_node, lats_nodes_a_fake=', - & lats_nodes_a_fake -cc - return - end - - end module get_lats_node_a_stochy_mod diff --git a/get_ls_node_stochy.f b/get_ls_node_stochy.f deleted file mode 100644 index 655bd789..00000000 --- a/get_ls_node_stochy.f +++ /dev/null @@ -1,84 +0,0 @@ -!>@brief The module 'get_ls_node_stochy_mod' contains the subroutine get_ls_node_stochy - module get_ls_node_stochy_mod - - implicit none - - contains - -!>@brief The subroutine 'get_ls_node_stochy' calculates the decomposition of the spherical harmonics based on the processor layout - subroutine get_ls_node_stochy(me_fake,ls_node,ls_max_node_fake, - c iprint) -!>@details This code is taken from the legacy spectral GFS -! - use spectral_layout_mod - implicit none -! - integer me_fake, ls_max_node_fake, iprint - integer ls_node(ls_dim) - - integer ijk, jptls, l, node, nodesio, jcap1 -! -!jw if (liope) then -!jw if (icolor.eq.2) then -!jw nodesio=1 -!jw else - - nodesio = nodes - -!jw endif -!jw else -!jw nodesio=nodes -!jw endif -!! - ls_node = -1 - jcap1=jcap+1 -! - jptls = 0 - l = 0 -!............................................. - do ijk=1,jcap1 -! - do node=1,nodesio - if (node == me_fake+1) then - jptls = jptls + 1 - ls_node(jptls) = l - endif - l = l + 1 - if (l > jcap) go to 200 - enddo -! - do node=nodesio,1,-1 - if (node == me_fake+1) then - jptls = jptls + 1 - ls_node(jptls) = l - endif - l = l + 1 - if (l > jcap) go to 200 - enddo -! - enddo -!............................................. -! - 200 continue -! -!............................................. -! - if(iprint == 1) print *, 'completed loop 200 in get_ls_node' - ls_max_node_fake = 0 - do ijk=1,ls_dim - if(ls_node(ijk) >= 0) then - ls_max_node_fake = ijk - if(iprint == 1) - & print 230, me_fake, ijk, ls_node(ijk) - endif - 230 format ('me_fake=',i5,' get_ls_node ls_node(', i5, ')=',i5) - enddo -! - if(iprint == 1) - & print*,'completed get_ls_node, ls_max_node_fake=', - & ls_max_node_fake -! - return - end - - end module get_ls_node_stochy_mod diff --git a/get_stochy_pattern.F90 b/get_stochy_pattern.F90 index 3d235bee..f3858567 100644 --- a/get_stochy_pattern.F90 +++ b/get_stochy_pattern.F90 @@ -1,10 +1,10 @@ !>@brief The module 'get_stochy_pattern_mod' contains the subroutines to retrieve the random pattern in the cubed-sphere grid module get_stochy_pattern_mod use kinddef, only : kind_dbl_prec, kind_evod - use spectral_layout_mod, only : ipt_lats_node_a, lat1s_a, lats_dim_a, & - lats_node_a, lon_dim_a, len_trie_ls, & - len_trio_ls, ls_dim, nodes, stochy_la2ga, & - coslat_a, latg, latg2, levs, lonf, skeblevs + use spectral_transforms, only : len_trie_ls, & + len_trio_ls, ls_dim, stochy_la2ga, & + coslat_a, latg, levs, lonf, skeblevs,& + four_to_grid, spec_to_four, dezouv_stochy,dozeuv_stochy use stochy_namelist_def, only : n_var_lndp, ntrunc, stochini use stochy_data_mod, only : gg_lats, gg_lons, inttyp, nskeb, nshum, nsppt, & nocnsppt,nepbl,nlndp, & @@ -15,12 +15,8 @@ module get_stochy_pattern_mod use stochy_patterngenerator_mod, only: random_pattern, ndimspec, & patterngenerator_advance use stochy_internal_state_mod, only: stochy_internal_state - use mpi_wrapper, only : mp_reduce_sum,is_master + use mpi_wrapper, only : mp_reduce_sum,is_rootpe use mersenne_twister, only: random_seed - use dezouv_stochy_mod, only: dezouv_stochy - use dozeuv_stochy_mod, only: dozeuv_stochy - use four_to_grid_mod, only: four_to_grid - use sumfln_stochy_mod, only: sumfln_stochy implicit none private @@ -58,26 +54,22 @@ subroutine get_random_pattern_sfc(rpattern,npatterns,& glolal = 0. do n=1,npatterns call patterngenerator_advance(rpattern(n),k,.false.) - if (is_master()) print *, 'Random pattern for LNDP PERTS in get_random_pattern_fv3_sfc: k, min, max ',k,minval(rpattern_sfc(n)%spec_o(:,:,k)), maxval(rpattern_sfc(n)%spec_o(:,:,k)) - call scalarspect_to_gaugrid( & - rpattern(n)%spec_e(:,:,k),rpattern(n)%spec_o(:,:,k),wrk2d,& - gis_stochy%ls_node,gis_stochy%ls_nodes,gis_stochy%max_ls_nodes,& - gis_stochy%lats_nodes_a,gis_stochy%global_lats_a,gis_stochy%lonsperlat,& - gis_stochy%plnev_a,gis_stochy%plnod_a,1) +! if (is_rootpe()) print *, 'Random pattern for LNDP PERTS in get_random_pattern_fv3_sfc: k, min, max ',k,minval(rpattern_sfc(n)%spec_o(:,:,k)), maxval(rpattern_sfc(n)%spec_o(:,:,k)) + call scalarspect_to_gaugrid(rpattern(n),gis_stochy,wrk2d,k) glolal = glolal + wrk2d(:,:,1) enddo allocate(workg(lonf,latg)) workg = 0. do j=1,gis_stochy%lats_node_a - lat=gis_stochy%global_lats_a(ipt_lats_node_a-1+j) + lat=gis_stochy%global_lats_a(gis_stochy%ipt_lats_node_a-1+j) do i=1,lonf workg(i,lat) = glolal(i,j) enddo enddo call mp_reduce_sum(workg,lonf,latg) - if (is_master()) print *, 'workg after mp_reduce_sum for LNDP PERTS in get_random_pattern_fv3_sfc: k, min, max ',k,minval(workg), maxval(workg) +! if (is_rootpe()) print *, 'workg after mp_reduce_sum for LNDP PERTS in get_random_pattern_fv3_sfc: k, min, max ',k,minval(workg), maxval(workg) ! interpolate to cube grid @@ -90,7 +82,7 @@ subroutine get_random_pattern_sfc(rpattern,npatterns,& pattern_3d(:,j,k)=pattern_1d(:) end associate enddo - if (is_master()) print *, '3D pattern for LNDP PERTS in get_random_pattern_fv3_sfc: k, min, max ',k,minval(pattern_3d(:,:,k)), maxval(pattern_3d(:,:,k)) +! if (is_rootpe()) print *, '3D pattern for LNDP PERTS in get_random_pattern_fv3_sfc: k, min, max ',k,minval(pattern_3d(:,:,k)), maxval(pattern_3d(:,:,k)) deallocate(workg) enddo ! loop over k, n_var_lndp @@ -109,8 +101,8 @@ subroutine get_random_pattern_vector(rpattern,npatterns,& type(stochy_internal_state), intent(in) :: gis_stochy type(random_pattern), intent(inout) :: rpattern(npatterns) - real(kind=kind_evod), dimension(len_trie_ls,2,1) :: vrtspec_e,divspec_e - real(kind=kind_evod), dimension(len_trio_ls,2,1) :: vrtspec_o,divspec_o + real(kind=kind_evod), dimension(len_trie_ls,2) :: vrtspec_e,divspec_e + real(kind=kind_evod), dimension(len_trio_ls,2) :: vrtspec_o,divspec_o integer:: npatterns real(kind=kind_dbl_prec) :: upattern_3d(gis_stochy%nx,gis_stochy%ny,levs) @@ -137,20 +129,15 @@ subroutine get_random_pattern_vector(rpattern,npatterns,& if (.not. stochini) call patterngenerator_advance(rpattern(n),k,first_call) ! ke norm (convert streamfunction forcing to vorticity forcing) do nn=1,2 - vrtspec_e(:,nn,1) = gis_stochy%kenorm_e*rpattern(n)%spec_e(:,nn,k) - vrtspec_o(:,nn,1) = gis_stochy%kenorm_o*rpattern(n)%spec_o(:,nn,k) + vrtspec_e(:,nn) = gis_stochy%kenorm_e*rpattern(n)%spec_e(:,nn,k) + vrtspec_o(:,nn) = gis_stochy%kenorm_o*rpattern(n)%spec_o(:,nn,k) enddo ! convert to winds - call vrtdivspect_to_uvgrid(& - divspec_e,divspec_o,vrtspec_e,vrtspec_o,& - wrk2du,wrk2dv,& - gis_stochy%ls_node,gis_stochy%ls_nodes,gis_stochy%max_ls_nodes,& - gis_stochy%lats_nodes_a,gis_stochy%global_lats_a,gis_stochy%lonsperlat,& - gis_stochy%epsedn,gis_stochy%epsodn,gis_stochy%snnp1ev,gis_stochy%snnp1od,& - gis_stochy%plnev_a,gis_stochy%plnod_a,1) + call vrtdivspect_to_uvgrid( divspec_e,divspec_o,vrtspec_e,vrtspec_o,& + wrk2du,wrk2dv, gis_stochy) do i=1,lonf do j=1,gis_stochy%lats_node_a - lat=gis_stochy%global_lats_a(ipt_lats_node_a-1+j) + lat=gis_stochy%global_lats_a(gis_stochy%ipt_lats_node_a-1+j) workgu(i,lat) = workgu(i,lat) + wrk2du(i,j,1) workgv(i,lat) = workgv(i,lat) + wrk2dv(i,j,1) enddo @@ -189,20 +176,16 @@ subroutine get_random_pattern_vector(rpattern,npatterns,& ! ke norm (convert streamfunction forcing to vorticity forcing) divspec_e = 0; divspec_o = 0. do nn=1,2 - vrtspec_e(:,nn,1) = gis_stochy%kenorm_e*rpattern(n)%spec_e(:,nn,skeblevs) - vrtspec_o(:,nn,1) = gis_stochy%kenorm_o*rpattern(n)%spec_o(:,nn,skeblevs) + vrtspec_e(:,nn) = gis_stochy%kenorm_e*rpattern(n)%spec_e(:,nn,skeblevs) + vrtspec_o(:,nn) = gis_stochy%kenorm_o*rpattern(n)%spec_o(:,nn,skeblevs) enddo ! convert to winds call vrtdivspect_to_uvgrid(& divspec_e,divspec_o,vrtspec_e,vrtspec_o,& - wrk2du,wrk2dv,& - gis_stochy%ls_node,gis_stochy%ls_nodes,gis_stochy%max_ls_nodes,& - gis_stochy%lats_nodes_a,gis_stochy%global_lats_a,gis_stochy%lonsperlat,& - gis_stochy%epsedn,gis_stochy%epsodn,gis_stochy%snnp1ev,gis_stochy%snnp1od,& - gis_stochy%plnev_a,gis_stochy%plnod_a,1) + wrk2du,wrk2dv, gis_stochy) do i=1,lonf do j=1,gis_stochy%lats_node_a - lat=gis_stochy%global_lats_a(ipt_lats_node_a-1+j) + lat=gis_stochy%global_lats_a(gis_stochy%ipt_lats_node_a-1+j) workgu(i,lat) = workgu(i,lat) + wrk2du(i,j,1) workgv(i,lat) = workgv(i,lat) + wrk2dv(i,j,1) enddo @@ -247,7 +230,7 @@ subroutine get_random_pattern_scalar(rpattern,npatterns,& type(stochy_internal_state) :: gis_stochy integer,intent(in):: npatterns - integer i,j,lat,n,pe_print + integer i,j,lat,n real(kind=kind_dbl_prec), dimension(lonf,gis_stochy%lats_node_a,1):: wrk2d ! logical lprint @@ -257,28 +240,20 @@ subroutine get_random_pattern_scalar(rpattern,npatterns,& integer kmsk0(lonf,gis_stochy%lats_node_a) real(kind=kind_dbl_prec) :: pattern_2d(gis_stochy%nx,gis_stochy%ny) real(kind=kind_dbl_prec) :: pattern_1d(gis_stochy%nx) - pe_print=111 - !if (is_master()) then - ! print*,'in get_random_pattern_scalar',npatterns - ! print*,'nx,ny',gis_stochy%nx,gis_stochy%ny - !endif kmsk0 = 0 glolal = 0. do n=1,npatterns call patterngenerator_advance(rpattern(n),1,.false.) - call scalarspect_to_gaugrid( & - rpattern(n)%spec_e,rpattern(n)%spec_o,wrk2d,& - gis_stochy%ls_node,gis_stochy%ls_nodes,gis_stochy%max_ls_nodes,& - gis_stochy%lats_nodes_a,gis_stochy%global_lats_a,gis_stochy%lonsperlat,& - gis_stochy%plnev_a,gis_stochy%plnod_a,1) + call scalarspect_to_gaugrid(rpattern(n),gis_stochy, & + wrk2d,1) glolal = glolal + wrk2d(:,:,1) enddo allocate(workg(lonf,latg)) workg = 0. do j=1,gis_stochy%lats_node_a - lat=gis_stochy%global_lats_a(ipt_lats_node_a-1+j) + lat=gis_stochy%global_lats_a(gis_stochy%ipt_lats_node_a-1+j) do i=1,lonf workg(i,lat) = glolal(i,j) enddo @@ -303,54 +278,37 @@ end subroutine get_random_pattern_scalar !>@brief The subroutine 'scalarspect_to_gaugrid' converts scalar spherical harmonics to a scalar on a gaussian grid !>@details This subroutine is for a 2-D (lat-lon) scalar field -subroutine scalarspect_to_gaugrid(& - trie_ls,trio_ls,datag,& - ls_node,ls_nodes,max_ls_nodes,& - lats_nodes_a,global_lats_a,lonsperlat,& - plnev_a,plnod_a,nlevs) +subroutine scalarspect_to_gaugrid(rpattern,gis_stochy,datag,n) !\callgraph - implicit none - real(kind=kind_dbl_prec), intent(in) :: trie_ls(len_trie_ls,2,nlevs) - real(kind=kind_dbl_prec), intent(in) :: trio_ls(len_trio_ls,2,nlevs) - real(kind=kind_dbl_prec), intent(out) :: datag(lonf,lats_node_a,nlevs) - integer, intent(in) :: ls_node(ls_dim,3),ls_nodes(ls_dim,nodes),& - nlevs,max_ls_nodes(nodes),lats_nodes_a(nodes),global_lats_a(latg),lonsperlat(latg) - real(kind=kind_dbl_prec),intent(in) :: plnev_a(len_trie_ls,latg2),plnod_a(len_trio_ls,latg2) + type(random_pattern), intent(in) :: rpattern + type(stochy_internal_state), intent(in) :: gis_stochy + integer , intent(in) :: n + real(kind=kind_dbl_prec), intent(out) :: datag(lonf,gis_stochy%lats_node_a) ! local vars - real(kind=kind_dbl_prec) for_gr_a_1(lon_dim_a,nlevs,lats_dim_a) - real(kind=kind_dbl_prec) for_gr_a_2(lonf,nlevs,lats_dim_a) + real(kind=kind_dbl_prec) for_gr_a_1(gis_stochy%lon_dim_a,1,gis_stochy%lats_dim_a) + real(kind=kind_dbl_prec) for_gr_a_2(lonf,1,gis_stochy%lats_dim_a) integer i,k integer lan,lat - integer lons_lat - - call sumfln_stochy(trie_ls,& - trio_ls,& - lat1s_a,& - plnev_a,plnod_a,& - nlevs,ls_node,latg2,& - lats_dim_a,nlevs,for_gr_a_1,& - ls_nodes,max_ls_nodes,& - lats_nodes_a,global_lats_a,& - lats_node_a,ipt_lats_node_a,& - lonsperlat,lon_dim_a,latg,0) - - do lan=1,lats_node_a - lat = global_lats_a(ipt_lats_node_a-1+lan) - lons_lat = lonsperlat(lat) - CALL FOUR_TO_GRID(for_gr_a_1(1,1,lan),for_gr_a_2(1,1,lan),& - lon_dim_a,lonf,lons_lat,nlevs) + call spec_to_four(rpattern%spec_e(:,:,n), rpattern%spec_o(:,:,n), & + gis_stochy%plnev_a,gis_stochy%plnod_a,& + gis_stochy%ls_node, & + gis_stochy%lats_dim_a,for_gr_a_1,& + gis_stochy%ls_nodes,gis_stochy%max_ls_nodes,& + gis_stochy%lats_nodes_a,gis_stochy%global_lats_a,& + gis_stochy%lats_node_a,gis_stochy%ipt_lats_node_a,1) + do lan=1,gis_stochy%lats_node_a + lat = gis_stochy%global_lats_a(gis_stochy%ipt_lats_node_a-1+lan) + call four_to_grid(for_gr_a_1(:,:,lan),for_gr_a_2(:,:,lan),& + gis_stochy%lon_dim_a,1) enddo datag = 0. - do lan=1,lats_node_a - lat = global_lats_a(ipt_lats_node_a-1+lan) - lons_lat = lonsperlat(lat) - do k=1,nlevs - do i=1,lons_lat - datag(i,lan,k) = for_gr_a_2(i,k,lan) - enddo + do lan=1,gis_stochy%lats_node_a + lat = gis_stochy%global_lats_a(gis_stochy%ipt_lats_node_a-1+lan) + do i=1,lonf + datag(i,lan) = for_gr_a_2(i,1,lan) enddo enddo @@ -374,7 +332,7 @@ subroutine write_stoch_restart_atm(sfile) if ( ( .NOT. do_sppt) .AND. (.NOT. do_shum) .AND. (.NOT. do_skeb) .AND. (lndp_type==0 ) ) return stochlun=99 - if (is_master()) then + if (is_rootpe()) then if (nsppt > 0 .OR. nshum > 0 .OR. nskeb > 0 .OR. nlndp>0 ) then ierr=nf90_create(trim(sfile),cmode=NF90_CLOBBER,ncid=ncid) ierr=NF90_PUT_ATT(ncid,NF_GLOBAL,"ntrunc",ntrunc) @@ -448,7 +406,7 @@ subroutine write_stoch_restart_atm(sfile) enddo enddo endif - if (is_master() ) then + if (is_rootpe() ) then ierr=NF90_CLOSE(ncid) if (ierr .NE. 0) then write(0,*) 'error writing patterns and closing file' @@ -472,7 +430,7 @@ subroutine write_stoch_restart_ocn(sfile) include 'netcdf.inc' if ( ( .NOT. do_ocnsppt) .AND. (.NOT. pert_epbl) ) return stochlun=99 - if (is_master()) then + if (is_rootpe()) then ierr=nf90_create(trim(sfile),cmode=NF90_CLOBBER,ncid=ncid) ierr=NF90_PUT_ATT(ncid,NF_GLOBAL,"ntrunc",ntrunc) call random_seed(size=isize) ! get seed size @@ -515,7 +473,7 @@ subroutine write_stoch_restart_ocn(sfile) call write_pattern(rpattern_epbl2(n),ncid,1,n,varid3a,varid3b,.false.,ierr) enddo endif - if (is_master() ) then + if (is_rootpe() ) then ierr=NF90_CLOSE(ncid) if (ierr .NE. 0) then write(0,*) 'error writing patterns and closing file' @@ -557,7 +515,7 @@ subroutine write_pattern(rpattern,outlun,lev,np,varid1,varid2,slice_of_3d,iret) enddo call mp_reduce_sum(pattern2d,arrlen) ! write only on root process - if (is_master()) then + if (is_rootpe()) then print*,'writing out random pattern (min/max/size)',& minval(pattern2d),maxval(pattern2d),size(pattern2d) call random_seed(size=isize) ! get seed size @@ -582,71 +540,54 @@ end subroutine write_pattern !>@details This subroutine is for a 2-D (lat-lon) vector field subroutine vrtdivspect_to_uvgrid(& trie_di,trio_di,trie_ze,trio_ze,& - uug,vvg,& - ls_node,ls_nodes,max_ls_nodes,& - lats_nodes_a,global_lats_a,lonsperlar,& - epsedn,epsodn,snnp1ev,snnp1od,plnev_a,plnod_a,nlevs) + uug,vvg, gis_stochy) !\callgraph implicit none - real(kind=kind_dbl_prec), intent(in) :: trie_di(len_trie_ls,2,nlevs) - real(kind=kind_dbl_prec), intent(in) :: trio_di(len_trio_ls,2,nlevs) - real(kind=kind_dbl_prec), intent(in) :: trie_ze(len_trie_ls,2,nlevs) - real(kind=kind_dbl_prec), intent(in) :: trio_ze(len_trio_ls,2,nlevs) - real(kind=kind_dbl_prec), intent(out) :: uug(lonf,lats_node_a,nlevs) - real(kind=kind_dbl_prec), intent(out) :: vvg(lonf,lats_node_a,nlevs) - integer, intent(in) :: ls_node(ls_dim,3),ls_nodes(ls_dim,nodes),& - nlevs,max_ls_nodes(nodes),lats_nodes_a(nodes),global_lats_a(latg),lonsperlar(latg) - real(kind=kind_dbl_prec),intent(in) :: epsedn(len_trie_ls),& - epsodn(len_trio_ls),snnp1ev(len_trie_ls),snnp1od(len_trio_ls),& - plnev_a(len_trie_ls,latg2),plnod_a(len_trio_ls,latg2) + type(stochy_internal_state), intent(in) :: gis_stochy + real(kind=kind_dbl_prec), intent(in) :: trie_di(len_trie_ls,2) + real(kind=kind_dbl_prec), intent(in) :: trio_di(len_trio_ls,2) + real(kind=kind_dbl_prec), intent(in) :: trie_ze(len_trie_ls,2) + real(kind=kind_dbl_prec), intent(in) :: trio_ze(len_trio_ls,2) + real(kind=kind_dbl_prec), intent(out) :: uug(lonf,gis_stochy%lats_node_a) + real(kind=kind_dbl_prec), intent(out) :: vvg(lonf,gis_stochy%lats_node_a) ! local vars - real(kind=kind_dbl_prec) trie_ls(len_trie_ls,2,2*nlevs) - real(kind=kind_dbl_prec) trio_ls(len_trio_ls,2,2*nlevs) - real(kind=kind_dbl_prec) for_gr_a_1(lon_dim_a,2*nlevs,lats_dim_a) - real(kind=kind_dbl_prec) for_gr_a_2(lonf,2*nlevs,lats_dim_a) + real(kind=kind_dbl_prec) trie_ls(len_trie_ls,2,2) + real(kind=kind_dbl_prec) trio_ls(len_trio_ls,2,2) + real(kind=kind_dbl_prec) for_gr_a_1(gis_stochy%lon_dim_a,2,gis_stochy%lats_dim_a) + real(kind=kind_dbl_prec) for_gr_a_2(lonf,2,gis_stochy%lats_dim_a) integer i,k integer lan,lat - integer lons_lat real (kind=kind_dbl_prec) tx1 - do k=1,nlevs - call dezouv_stochy(trie_di(1,1,k), trio_ze(1,1,k),& - trie_ls(1,1,k), trio_ls(1,1,nlevs+k),& - epsedn,epsodn,snnp1ev,snnp1od,ls_node) - call dozeuv_stochy(trio_di(1,1,k), trie_ze(1,1,k),& - trio_ls(1,1,k), trie_ls(1,1,nlevs+k),& - epsedn,epsodn,snnp1ev,snnp1od,ls_node) - enddo - - call sumfln_stochy(trie_ls,& - trio_ls,& - lat1s_a,& - plnev_a,plnod_a,& - 2*nlevs,ls_node,latg2,& - lats_dim_a,2*nlevs,for_gr_a_1,& - ls_nodes,max_ls_nodes,& - lats_nodes_a,global_lats_a,& - lats_node_a,ipt_lats_node_a,& - lonsperlar,lon_dim_a,latg,0) - - do lan=1,lats_node_a - lat = global_lats_a(ipt_lats_node_a-1+lan) - lons_lat = lonsperlar(lat) - CALL FOUR_TO_GRID(for_gr_a_1(1,1,lan),for_gr_a_2(1,1,lan),& - lon_dim_a,lonf,lons_lat,2*nlevs) + call dezouv_stochy(trie_di(:,:), trio_ze(:,:), & + trie_ls(:,:,1), trio_ls(:,:,2), gis_stochy%epsedn,gis_stochy%epsodn, & + gis_stochy%snnp1ev,gis_stochy%snnp1od,gis_stochy%ls_node) + call dozeuv_stochy(trio_di(:,:), trie_ze(:,:), & + trio_ls(:,:,1), trie_ls(:,:,2), gis_stochy%epsedn,gis_stochy%epsodn, & + gis_stochy%snnp1ev,gis_stochy%snnp1od,gis_stochy%ls_node) + + call spec_to_four(trie_ls, trio_ls, & + gis_stochy%plnev_a,gis_stochy%plnod_a,& + gis_stochy%ls_node,& + gis_stochy%lats_dim_a,for_gr_a_1,& + gis_stochy%ls_nodes,gis_stochy%max_ls_nodes,& + gis_stochy%lats_nodes_a,gis_stochy%global_lats_a,& + gis_stochy%lats_node_a,gis_stochy%ipt_lats_node_a,2) + + do lan=1,gis_stochy%lats_node_a + lat = gis_stochy%global_lats_a(gis_stochy%ipt_lats_node_a-1+lan) + call four_to_grid(for_gr_a_1(:,:,lan),for_gr_a_2(:,:,lan),& + gis_stochy%lon_dim_a,2) enddo uug = 0.; vvg = 0. - do lan=1,lats_node_a - lat = global_lats_a(ipt_lats_node_a-1+lan) - lons_lat = lonsperlar(lat) + do lan=1,gis_stochy%lats_node_a + lat = gis_stochy%global_lats_a(gis_stochy%ipt_lats_node_a-1+lan) tx1 = 1. / coslat_a(lat) - do k=1,nlevs - do i=1,lons_lat - uug(i,lan,k) = for_gr_a_2(i,k,lan) * tx1 - vvg(i,lan,k) = for_gr_a_2(i,nlevs+k,lan) * tx1 - enddo + do i=1,lonf + uug(i,lan) = for_gr_a_2(i,1,lan) * tx1 + vvg(i,lan) = for_gr_a_2(i,2,lan) * tx1 enddo enddo diff --git a/getcon_lag_stochy.f b/getcon_lag_stochy.f deleted file mode 100644 index 4f8666f6..00000000 --- a/getcon_lag_stochy.f +++ /dev/null @@ -1,89 +0,0 @@ -!>@brief The module 'getcon_lag_stochy_mod' contains the subroute getcon_lag_stochy - module getcon_lag_stochy_mod - - implicit none - - contains - -!>@brief The subroutine 'getcon_lag' calculates grid properties and domain decompostion for the gaussian grid -!>@details This code is taken from the legacy spectral GFS - subroutine getcon_lag_stochy(lats_nodes_a,global_lats_a, - & lats_nodes_h,global_lats_h_sn, - & lonsperlat,xhalo,yhalo) - use spectral_layout_mod, only : me,nodes,jcap,latg,latg2,lonf, - & colrad_a,sinlat_a, - & ipt_lats_node_h,lat1s_h,lats_dim_h, - & lats_node_h,lats_node_h_max,lon_dim_h - use setlats_lag_stochy_mod, only: setlats_lag_stochy - implicit none -! - integer yhalo,xhalo -! - integer, dimension(nodes) :: lats_nodes_a, lats_nodes_h - integer, dimension(latg) :: lonsperlat, global_lats_a - - integer, dimension(latg+2*yhalo*nodes) :: global_lats_h_sn -! - integer i,j,l,n,lat,i1,i2,node,nodesio - integer, dimension(latg+2*yhalo*nodes) :: global_lats_h_ns -! - if (me == 0) print 100, jcap, me -100 format ('getcon_h jcap= ',i4,2x,'me=',i3) - - do lat = 1, latg2 - lonsperlat(latg+1-lat) = lonsperlat(lat) - end do - nodesio = nodes - -! print*,'con_h me,nodes,nodesio = ',me,nodes,nodesio - - call setlats_lag_stochy(lats_nodes_a,global_lats_a, - & lats_nodes_h,global_lats_h_ns,yhalo) - -! reverse order for use in set_halos - - i1 = 1 - i2 = 0 - do n=1,nodes - j = 0 - i2 = i2 + lats_nodes_h(n) - do i=i1,i2 - j = j + 1 - global_lats_h_sn(i) = global_lats_h_ns(i2+1-j) - enddo - i1 = i2 + 1 - enddo - - 830 format(10(i4,1x)) - lats_dim_h = 0 - do node=1,nodes - lats_dim_h = max(lats_dim_h, lats_nodes_h(node)) - enddo - lats_node_h = lats_nodes_h(me+1) - lats_node_h_max = 0 - do i=1,nodes - lats_node_h_max = max(lats_node_h_max, lats_nodes_h(i)) - enddo - ipt_lats_node_h = 1 - if ( me > 0 ) then - do node=1,me - ipt_lats_node_h = ipt_lats_node_h + lats_nodes_h(node) - enddo - endif - do j=1,latg2 - sinlat_a(j) = cos(colrad_a(j)) - enddo - do l=0,jcap - do lat = 1, latg2 - if ( l <= min(jcap,lonsperlat(lat)/2) ) then - lat1s_h(l) = lat - go to 200 - endif - end do - 200 continue - end do - lon_dim_h = lonf + 1 + xhalo + xhalo !even/odd - return - end - - end module getcon_lag_stochy_mod diff --git a/getcon_spectral.F90 b/getcon_spectral.F90 deleted file mode 100644 index ddb95458..00000000 --- a/getcon_spectral.F90 +++ /dev/null @@ -1,273 +0,0 @@ -!>@brief The module 'getcon_spectral_mod' contains the subroutine getcon_spectral -module getcon_spectral_mod - - implicit none - - contains - -!>@brief The subroutine 'getcon_spectral' gets various constants for the spectral and related gaussian grid -!! and caluated the assoicate legendre polynomials -!>@details This code is taken from the legacy spectral GFS - subroutine getcon_spectral ( ls_node,ls_nodes,max_ls_nodes, & - lats_nodes_a,global_lats_a, & - lonsperlat,latsmax, & - epse,epso,epsedn,epsodn, & - snnp1ev,snnp1od, & - plnev_a,plnod_a,pddev_a,pddod_a, & - plnew_a,plnow_a) - -! program log: -! 20110220 henry juang update code to fit mass_dp and ndslfv -! 20201002 philip pegion clean up of code -! - use epslon_stochy_mod, only: epslon_stochy - use get_lats_node_a_stochy_mod, only: get_lats_node_a_stochy - use get_ls_node_stochy_mod, only: get_ls_node_stochy - use glats_stochy_mod, only: glats_stochy - use gozrineo_a_stochy_mod, only: gozrineo_a_stochy - use pln2eo_a_stochy_mod, only: pln2eo_a_stochy - use setlats_a_stochy_mod, only: setlats_a_stochy - use spectral_layout_mod - use stochy_internal_state_mod - use kinddef - - implicit none -! - integer i,j,l,lat,n - integer ls_node(ls_dim,3) -! -! ls_node(1,1) ... ls_node(ls_max_node,1) : values of L -! ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev -! ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod -! - integer ls_nodes(ls_dim,nodes) - integer, dimension(nodes) :: max_ls_nodes, lats_nodes_a - integer, dimension(latg) :: global_lats_a, lonsperlat -! -! - real(kind=kind_dbl_prec), dimension(len_trie_ls) :: epse, epsedn, snnp1ev - real(kind=kind_dbl_prec), dimension(len_trio_ls) :: epso, epsodn, snnp1od -! - real(kind=kind_dbl_prec), dimension(len_trie_ls,latg2) :: plnev_a, pddev_a, plnew_a - real(kind=kind_dbl_prec), dimension(len_trio_ls,latg2) :: plnod_a, pddod_a, plnow_a -! - real(kind=kind_dbl_prec), allocatable:: colrad_dp(:), wgt_dp(:),& - wgtcs_dp(:), rcs2_dp(:), epse_dp(:), epso_dp(:),& - epsedn_dp(:), epsodn_dp(:),plnev_dp(:), plnod_dp(:),& - pddev_dp(:), pddod_dp(:),plnew_dp(:), plnow_dp(:) -! - integer iprint,locl,node,& - len_trie_ls_nod, len_trio_ls_nod,& - indev, indod, indlsev,jbasev,indlsod,jbasod -! - integer gl_lats_index, latsmax - integer global_time_sort_index_a(latg) -! - include 'function2' -! - real(kind=kind_dbl_prec) global_time_a(latg) -! - real(kind=kind_dbl_prec), parameter :: cons0 = 0.d0, cons0p5 = 0.5d0,& - cons1 = 1.d0, cons0p92 = 0.92d0 -! - gl_lats_index = 0 - global_lats_a = -1 - do lat = 1,latg !my intialize global_time_a to lonsperlat - global_time_a(lat) = lonsperlat(lat) - enddo - - do lat = 1, latg2 - lonsperlat(latg+1-lat) = lonsperlat(lat) - end do - do node=1,nodes - call get_lats_node_a_stochy( node-1, global_lats_a,lats_nodes_a(node),& - gl_lats_index,global_time_sort_index_a, iprint) - enddo - call setlats_a_stochy(lats_nodes_a,global_lats_a,iprint, lonsperlat) - - iprint = 0 - do node=1,nodes - call get_ls_node_stochy( node-1, ls_nodes(1,node),max_ls_nodes(node), iprint ) - enddo -! - len_trie_ls_max = 0 - len_trio_ls_max = 0 - do node=1,nodes -! - len_trie_ls_nod = 0 - len_trio_ls_nod = 0 - do locl=1,max_ls_nodes(node) - l=ls_nodes(locl,node) - len_trie_ls_nod = len_trie_ls_nod+(jcap+3-l)/2 - len_trio_ls_nod = len_trio_ls_nod+(jcap+2-l)/2 - enddo - len_trie_ls_max = max(len_trie_ls_max,len_trie_ls_nod) - len_trio_ls_max = max(len_trio_ls_max,len_trio_ls_nod) -! - enddo -! - iprint = 0 -! - lats_dim_a = 0 - do node=1,nodes - lats_dim_a = max(lats_dim_a,lats_nodes_a(node)) - enddo - lats_node_a = lats_nodes_a(me+1) - - lats_node_a_max = 0 - do i=1,nodes - lats_node_a_max = max(lats_node_a_max, lats_nodes_a(i)) - enddo - latsmax = lats_node_a_max - -! - ipt_lats_node_a = 1 - if ( me > 0 ) then - do node=1,me - ipt_lats_node_a = ipt_lats_node_a + lats_nodes_a(node) - enddo - endif - -! - iprint = 0 -! - if ( kind_dbl_prec == 8 ) then !------------------------------------ - call glats_stochy(latg2,colrad_a,wgt_a,wgtcs_a,rcs2_a,iprint) - call epslon_stochy(epse,epso,epsedn,epsodn,ls_node) - call pln2eo_a_stochy(plnev_a,plnod_a,epse,epso,ls_node,latg2) - call gozrineo_a_stochy(plnev_a,plnod_a,pddev_a,pddod_a, & - plnew_a,plnow_a,epse,epso,ls_node,latg2) -! - else !------------------------------------------------------------ - allocate ( colrad_dp(latg2) ) - allocate ( wgt_dp(latg2) ) - allocate ( wgtcs_dp(latg2) ) - allocate ( rcs2_dp(latg2) ) -! - allocate ( epse_dp(len_trie_ls) ) - allocate ( epso_dp(len_trio_ls) ) - allocate ( epsedn_dp(len_trie_ls) ) - allocate ( epsodn_dp(len_trio_ls) ) -! - allocate ( plnev_dp(len_trie_ls) ) - allocate ( plnod_dp(len_trio_ls) ) - allocate ( pddev_dp(len_trie_ls) ) - allocate ( pddod_dp(len_trio_ls) ) - allocate ( plnew_dp(len_trie_ls) ) - allocate ( plnow_dp(len_trio_ls) ) - - call glats_stochy(latg2,colrad_dp,wgt_dp,wgtcs_dp,rcs2_dp,iprint) -! - do i=1,latg2 - colrad_a(i) = colrad_dp(i) - wgt_a(i) = wgt_dp(i) - wgtcs_a(i) = wgtcs_dp(i) - rcs2_a(i) = rcs2_dp(i) - enddo -! - call epslon_stochy(epse_dp,epso_dp,epsedn_dp,epsodn_dp,ls_node) -! - do i=1,len_trie_ls - epse(i) = epse_dp(i) - epsedn(i) = epsedn_dp(i) - enddo -! - do i=1,len_trio_ls - epso(i) = epso_dp(i) - epsodn(i) = epsodn_dp(i) - enddo -! - do lat=1,latg2 -! - call pln2eo_a_stochy(plnev_dp,plnod_dp,epse_dp,epso_dp,ls_node,1) -! - call gozrineo_a_stochy(plnev_dp,plnod_dp,pddev_dp,pddod_dp, plnew_dp,plnow_dp,& - epse_dp,epso_dp,ls_node,1) -! - do i=1,len_trie_ls - plnev_a(i,lat) = plnev_dp(i) - pddev_a(i,lat) = pddev_dp(i) - plnew_a(i,lat) = plnew_dp(i) - enddo - do i=1,len_trio_ls - plnod_a(i,lat) = plnod_dp(i) - pddod_a(i,lat) = pddod_dp(i) - plnow_a(i,lat) = plnow_dp(i) - enddo - enddo -! - deallocate ( wgt_dp, wgtcs_dp, rcs2_dp , & - epse_dp, epso_dp, epsedn_dp, epsodn_dp, & - plnev_dp, plnod_dp, pddev_dp, pddod_dp , & - plnew_dp, plnow_dp ) - endif !----------------------------------------------------------- -! -! - do locl=1,ls_max_node - l = ls_node(locl,1) - jbasev = ls_node(locl,2) - indev = indlsev(l,l) - do n = l, jcap, 2 - snnp1ev(indev) = n*(n+1) - indev = indev+1 - end do - end do -! -! - do locl=1,ls_max_node - l = ls_node(locl,1) - jbasod = ls_node(locl,3) - if ( l <= jcap-1 ) then - indod = indlsod(l+1,l) - do n = l+1, jcap, 2 - snnp1od(indod) = n*(n+1) - indod = indod+1 - end do - end if - end do -! -! - do locl=1,ls_max_node - l = ls_node(locl,1) - jbasev = ls_node(locl,2) - jbasod = ls_node(locl,3) - if (mod(L,2) == mod(jcap+1,2)) then ! set even (n-l) terms of top row to zero - snnp1ev(indlsev(jcap+1,l)) = cons0 - else ! set odd (n-l) terms of top row to zero - snnp1od(indlsod(jcap+1,l)) = cons0 - endif - enddo -! - do j=1,latg - if( j <= latg2 ) then - sinlat_a(j) = cos(colrad_a(j)) - else - sinlat_a(j) = -cos(colrad_a(latg+1-j)) - endif - coslat_a(j) = sqrt(1.-sinlat_a(j)*sinlat_a(j)) - enddo -! - do L=0,jcap - do lat = 1, latg2 - if ( L <= min(jcap,lonsperlat(lat)/2) ) then - lat1s_a(L) = lat - go to 200 - endif - end do - 200 continue - end do -! - - do j=1,lats_node_a - lat = global_lats_a(ipt_lats_node_a-1+j) - if ( lonsperlat(lat) == lonf ) then - lon_dims_a(j) = lonfx - else - lon_dims_a(j) = lonsperlat(lat) + 2 - endif - enddo -! - return - end - -end module getcon_spectral_mod diff --git a/glats_stochy.f b/glats_stochy.f deleted file mode 100644 index 51aad0fe..00000000 --- a/glats_stochy.f +++ /dev/null @@ -1,115 +0,0 @@ -!>@brief The module 'glats_stochy_mod' contains the subroute glats_stochy - module glats_stochy_mod - - - implicit none - - contains - -!>@brief The subroutine 'glats_stochy' calculate the latitudes for the gaussian grid -!>@details This code is taken from the legacy spectral GFS - subroutine glats_stochy(lgghaf,colrad,wgt,wgtcs,rcs2,iprint) -! -! Jan 2013 Henry Juang increase precision by kind_qdt_prec=16 -! to help wgt (Gaussian weighting) - use kinddef - implicit none - integer iter,k,k1,l2,lgghaf,iprint -! -! increase precision for more significant digit to help wgt - real(kind=kind_qdt_prec) drad,dradz,p1,p2,phi,pi,rad,rc -! real(kind=kind_qdt_prec) drad,dradz,eps,p1,p2,phi,pi,rad,rc - real(kind=kind_qdt_prec) rl2,scale,si,sn,w,x -! - real(kind=kind_dbl_prec), dimension(lgghaf) :: colrad, wgt, - & wgtcs, rcs2 -! - real(kind=kind_dbl_prec), parameter :: cons0 = 0.d0, cons1 = 1.d0, - & cons2 = 2.d0, cons4 = 4.d0, - & cons180 = 180.d0, - & cons360 = 360.d0, - & cons0p25 = 0.25d0 - real(kind=kind_qdt_prec), parameter :: eps = 1.d-20 -! -! for better accuracy to select smaller number -! eps = 1.d-12 -! eps = 1.d-20 -! - if(iprint == 1) print 101 - 101 format (' i colat colrad wgt', 12x, 'wgtcs', - & 10x, 'iter res') - si = cons1 - l2 = 2*lgghaf - rl2 = l2 - scale = cons2/(rl2*rl2) - k1 = l2-1 - pi = atan(si)*cons4 -! dradz = pi / cons360 / 10.0 -! for better accuracy to start iteration - dradz = pi / float(lgghaf) / 200.0 - rad = cons0 - do k=1,lgghaf - iter = 0 - drad = dradz -1 call poly(l2,rad,p2) -2 p1 = p2 - iter = iter + 1 - rad = rad + drad - call poly(l2,rad,p2) - if(sign(si,p1) == sign(si,p2)) go to 2 - if(drad < eps)go to 3 - rad = rad-drad - drad = drad * cons0p25 - go to 1 -3 continue - colrad(k) = rad - phi = rad * cons180 / pi - call poly(k1,rad,p1) - x = cos(rad) - w = scale * (cons1 - x*x)/ (p1*p1) - wgt(k) = w - sn = sin(rad) - w = w/(sn*sn) - wgtcs(k) = w - rc = cons1/(sn*sn) - rcs2(k) = rc - call poly(l2,rad,p1) - if(iprint == 1) - & print 102,k,phi,colrad(k),wgt(k),wgtcs(k),iter,p1 - 102 format(1x,i3,2x,f6.2,2x,f10.7,2x,e14.7,2x,e14.7,2x,i4,2x,e14.7) - enddo - if(iprint == 1) print 100,lgghaf -100 format(1h ,'shalom from 0.0e0 glats for ',i3) -! - return - end - -!>@brief The subroutine 'poly' does something with latitudes -!>@details This code is taken from the legacy spectral GFS - subroutine poly(n,rad,p) - use kinddef -! - implicit none -! - integer i,n -! -! increase precision for more significant digit to help wgt - real(kind=kind_qdt_prec) floati,g,p,rad,x,y1,y2,y3 -! - real(kind=kind_dbl_prec), parameter :: cons1 = 1.d0 -! - x = cos(rad) - y1 = cons1 - y2 = x - do i=2,n - g = x*y2 - floati = i - y3 = g - y1 + g - (g-y1)/floati - y1 = y2 - y2 = y3 - enddo - p = y3 - return - end - - end module glats_stochy_mod diff --git a/gozrineo_stochy.f b/gozrineo_stochy.f deleted file mode 100644 index 954e9b4e..00000000 --- a/gozrineo_stochy.f +++ /dev/null @@ -1,179 +0,0 @@ -!>@brief The module 'gozrineo_a_stochy_mod' contains the subroutine 'gozrineo_a_stochy' - module gozrineo_a_stochy_mod - - implicit none - - contains -!>@brief The subroutine 'gozrineo_a_stochy' calculates the deriviates of assoicate legendre polynomials -!>@details This code is taken from the legacy spectral GFS - subroutine gozrineo_a_stochy(plnev_a,plnod_a, - & pddev_a,pddod_a, - & plnew_a,plnow_a, - & epse,epso,ls_node,num_lat) -cc - use spectral_layout_mod - use kinddef - implicit none -cc - real(kind=kind_dbl_prec) plnev_a(len_trie_ls,latg2) - real(kind=kind_dbl_prec) plnod_a(len_trio_ls,latg2) - real(kind=kind_dbl_prec) pddev_a(len_trie_ls,latg2) - real(kind=kind_dbl_prec) pddod_a(len_trio_ls,latg2) - real(kind=kind_dbl_prec) plnew_a(len_trie_ls,latg2) - real(kind=kind_dbl_prec) plnow_a(len_trio_ls,latg2) -cc - real(kind=kind_dbl_prec) epse(len_trie_ls) - real(kind=kind_dbl_prec) epso(len_trio_ls) -cc -cc - integer ls_node(ls_dim,3) -cc - integer num_lat -cc -!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L -!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev -!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod -cc - integer l,lat,locl,n -cc - integer indev,indev1,indev2 - integer indod,indod1,indod2 - integer inddif -cc - real(kind=kind_dbl_prec) rn,rnp1,wcsa -cc - real(kind=kind_dbl_prec) cons0 !constant - real(kind=kind_dbl_prec) cons2 !constant - real rerth -cc - integer indlsev,jbasev - integer indlsod,jbasod -cc - include 'function2' -cc -cc - cons0 = 0.d0 !constant - cons2 = 2.d0 !constant - rerth =6.3712e+6 ! radius of earth (m) -cc -cc - do lat=1,num_lat -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) -cc - rn=l -cc -cc - pddev_a(indlsev(l,l),lat) = -epso(indlsod(l+1,l)) - & * plnod_a(indlsod(l+1,l),lat) * rn - indev1 = indlsev(L,L) + 1 - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap-1,L) - else - indev2 = indlsev(jcap ,L) - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - rn =l+2 - rnp1=l+2+1 - do indev = indev1 , indev2 -cc - pddev_a(indev,lat) = epse(indev) - & * plnod_a(indev-inddif ,lat) * rnp1 - & - epso(indev-inddif+1) - & * plnod_a(indev-inddif+1,lat) * rn -cc - rn = rn + cons2 !constant - rnp1 = rnp1 + cons2 !constant - enddo -cc -cc...................................................................... - indev1 = indlsev(L,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - 1 - else - indev2 = indlsev(jcap ,L) - 1 - endif - indod1 = indlsod(l+1,l) - inddif = indev1 - indod1 -cc - rn =l+1 - rnp1=l+1+1 - do indev = indev1 , indev2 -cc - pddod_a(indev-inddif,lat) = epso(indev-inddif) - & * plnev_a(indev ,lat) * rnp1 - & - epse(indev+1) - & * plnev_a(indev+1,lat) * rn -cc - rn = rn + cons2 !constant - rnp1 = rnp1 + cons2 !constant - enddo -cc - enddo -cc -cc...................................................................... -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) -cc - if (mod(L,2).eq.mod(jcap+1,2)) then -cc -cc set the even (n-l) terms of the top row to zero - pddev_a(indlsev(jcap+1,l),lat) = cons0 !constant -cc - else -cc -cc set the odd (n-l) terms of the top row to zero - pddod_a(indlsod(jcap+1,l),lat) = cons0 !constant -cc - endif -cc - enddo -cc -cc...................................................................... -cc - wcsa=rcs2_a(lat)/rerth -cc -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - indev1 = indlsev(L,L) - indod1 = indlsod(L+1,L) - if (mod(L,2).eq.mod(jcap+1,2)) then - indev2 = indlsev(jcap+1,L) - indod2 = indlsod(jcap ,L) - else - indev2 = indlsev(jcap ,L) - indod2 = indlsod(jcap+1,L) - endif - do indev = indev1 , indev2 -cc - pddev_a(indev,lat) = pddev_a(indev,lat) * wcsa - plnew_a(indev,lat) = plnev_a(indev,lat) * wgt_a(lat) -cc - enddo -cc - do indod = indod1 , indod2 -cc - pddod_a(indod,lat) = pddod_a(indod,lat) * wcsa - plnow_a(indod,lat) = plnod_a(indod,lat) * wgt_a(lat) -cc - enddo -cc - enddo -cc - enddo -cc - return - end - - end module gozrineo_a_stochy_mod diff --git a/initialize_spectral_mod.F90 b/initialize_spectral_mod.F90 deleted file mode 100644 index 7150e6ac..00000000 --- a/initialize_spectral_mod.F90 +++ /dev/null @@ -1,250 +0,0 @@ -!>@brief The module 'initialize_spectral_mod' cotains the subroutine initialize_spectral -! !module: stochy_initialize_spectral -! --- initialize module of the -! gridded component of the stochastic physics patteern -! generator, which is in spectral space -! -! !description: gfs dynamics gridded component initialize module. -! -! !revision history: -! -! oct 11 2016 P.Pegion copy of gsm/dynamics to create stand alone version -! -! !interface: -! - module initialize_spectral_mod -! -!!uses: -! - use kinddef - use spectral_layout_mod, only : ipt_lats_node_a, lats_node_a_max,lon_dim_a,len_trie_ls,len_trio_ls & - ,nodes,ls_max_node,lats_dim_a,ls_dim,lat1s_a - use stochy_internal_state_mod - use spectral_layout_mod,only:jcap,lon_dims_a,wgt_a,sinlat_a,coslat_a,colrad_a,wgtcs_a,rcs2_a,lats_nodes_h,global_lats_h,& - latg,latg2,lonf,lotls,lat1s_h - use stochy_namelist_def - use mpp_mod, only : mpp_pe,mpp_root_pe - use getcon_spectral_mod, only: getcon_spectral - use get_ls_node_stochy_mod, only: get_ls_node_stochy - use getcon_lag_stochy_mod, only: getcon_lag_stochy - !use mpp_mod -#ifndef IBM - USE omp_lib -#endif - - implicit none - - contains - -!>@brief The subroutine 'initialize_spectral' initializes the -!gridded component of the stochastic physics pattern -!>@details This code is taken from the legacy spectral GFS - subroutine initialize_spectral(gis_stochy, rc) - -! this subroutine set up the internal state variables, -! allocate internal state arrays for initializing the gfs system. -!---------------------------------------------------------------- -! - implicit none -! -! type(stochy_internal_state), pointer, intent(inout) :: gis_stochy - type(stochy_internal_state), intent(inout) :: gis_stochy - integer, intent(out) :: rc - integer :: npe_single_member, iret,latghf - integer :: i, l, locl - logical :: file_exists=.false. - integer, parameter :: iunit=101 - -!------------------------------------------------------------------- - -! set up gfs internal state dimension and values for dynamics etc -!------------------------------------------------------------------- -! print*,'before allocate lonsperlat,',& -! allocated(gis_stochy%lonsperlat),'latg=',latg -! -! gis_stochy%nodes=mpp_npes() -! print*,'mpp_npes=',mpp_npes() - nodes = gis_stochy%nodes - npe_single_member = gis_stochy%npe_single_member - - lon_dim_a = lon_s + 2 - jcap=ntrunc - latg = lat_s - latg2 = latg/2 - lonf = lon_s - - allocate(lat1s_a(0:jcap)) - allocate(lon_dims_a(latg)) - - allocate(wgt_a(latg2)) - allocate(wgtcs_a(latg2)) - allocate(rcs2_a(latg2)) - -! if (mpp_pe==mpp_root_pe()) then -! print*,'number of mpi procs is',nodes -! endif -! - ls_dim = (jcap)/nodes+1 -! print*,'allocating lonsperlat',latg - allocate(gis_stochy%lonsperlat(latg)) -! print*,'size=',size(gis_stochy%lonsperlat) - - - inquire (file="lonsperlat.dat", exist=file_exists) - if ( .not. file_exists ) then - !call mpp_error(FATAL,'Requested lonsperlat.dat data file does not exist') - gis_stochy%lonsperlat(:)=lonf - else - open (iunit,file='lonsperlat.dat',status='old',form='formatted', & - action='read',iostat=iret) - if (iret /= 0) then - write(0,*) 'error while reading lonsperlat.dat' - rc = 1 - return - end if - rewind iunit - read (iunit,*,iostat=iret) latghf,(gis_stochy%lonsperlat(i),i=1,latghf) - if (latghf+latghf /= latg) then - write(0,*)' latghf=',latghf,' not equal to latg/2=',latg/2 - if (iret /= 0) then - write(0,*) 'lonsperlat file has wrong size' - rc = 1 - return - end if - endif - do i=1,latghf - gis_stochy%lonsperlat(latg-i+1) = gis_stochy%lonsperlat(i) - enddo - close(iunit) - endif -!! -!cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -! -! write(0,*)'before allocate ls_nodes,',allocated(gis_stochy%ls_nodes),& -! 'ls_dim=', ls_dim,'nodes=',nodes - allocate ( gis_stochy%ls_node (ls_dim*3) ) - allocate ( gis_stochy%ls_nodes(ls_dim,nodes) ) - allocate ( gis_stochy%max_ls_nodes(nodes) ) -! - allocate ( gis_stochy%lats_nodes_a_fix(nodes)) ! added for mGrid -! - allocate ( gis_stochy%lats_nodes_a(nodes) ) - allocate ( gis_stochy%global_lats_a(latg) ) -! - -! internal parallel structure. Weiyu. -!--------------------------------------------------- - ALLOCATE(gis_stochy%TRIE_LS_SIZE (npe_single_member)) - ALLOCATE(gis_stochy%TRIO_LS_SIZE (npe_single_member)) - ALLOCATE(gis_stochy%TRIEO_LS_SIZE (npe_single_member)) - ALLOCATE(gis_stochy%LS_MAX_NODE_GLOBAL(npe_single_member)) - ALLOCATE(gis_stochy%LS_NODE_GLOBAL (LS_DIM*3, npe_single_member)) - - gis_stochy%LS_NODE_GLOBAL = 0 - gis_stochy%LS_MAX_NODE_GLOBAL = 0 - gis_stochy%TRIEO_TOTAL_SIZE = 0 - - DO i = 1, npe_single_member - CALL GET_LS_NODE_STOCHY(i-1, gis_stochy%LS_NODE_GLOBAL(1, i), & - gis_stochy%LS_MAX_NODE_GLOBAL(i), gis_stochy%IPRINT) - gis_stochy%TRIE_LS_SIZE(i) = 0 - gis_stochy%TRIO_LS_SIZE(i) = 0 - DO LOCL = 1, gis_stochy%LS_MAX_NODE_GLOBAL(i) - gis_stochy%LS_NODE_GLOBAL(LOCL+ LS_DIM, i) = gis_stochy%TRIE_LS_SIZE(i) - gis_stochy%LS_NODE_GLOBAL(LOCL+ 2*LS_DIM, i) = gis_stochy%TRIO_LS_SIZE(i) - - L = gis_stochy%LS_NODE_GLOBAL(LOCL, i) - - gis_stochy%TRIE_LS_SIZE(i) = gis_stochy%TRIE_LS_SIZE(i) + (JCAP+3-L)/2 - gis_stochy%TRIO_LS_SIZE(i) = gis_stochy%TRIO_LS_SIZE(i) + (JCAP+2-L)/2 - END DO - gis_stochy%TRIEO_LS_SIZE(i) = gis_stochy%TRIE_LS_SIZE(i) + gis_stochy%TRIO_LS_SIZE(i) + 3 - gis_stochy%TRIEO_TOTAL_SIZE = gis_stochy%TRIEO_TOTAL_SIZE + gis_stochy%TRIEO_LS_SIZE(i) - END DO - - -!--------------------------------------------------- -! - gis_stochy%iprint = 0 - call get_ls_node_stochy( gis_stochy%me, gis_stochy%ls_node, ls_max_node, gis_stochy%iprint ) -! -! - len_trie_ls = 0 - len_trio_ls = 0 - do locl=1,ls_max_node - gis_stochy%ls_node(locl+ ls_dim) = len_trie_ls - gis_stochy%ls_node(locl+2*ls_dim) = len_trio_ls - l = gis_stochy%ls_node(locl) - len_trie_ls = len_trie_ls+(jcap+3-l)/2 - len_trio_ls = len_trio_ls+(jcap+2-l)/2 - enddo -! if (gis_stochy%me == 0) print *,'ls_node=',gis_stochy%ls_node(1:ls_dim),'2dim=', & -! gis_stochy%ls_node(ls_dim+1:2*ls_dim),'3dim=', & -! gis_stochy%ls_node(2*ls_dim+1:3*ls_dim) -! -! - allocate ( gis_stochy%epse (len_trie_ls) ) - allocate ( gis_stochy%epso (len_trio_ls) ) - allocate ( gis_stochy%epsedn(len_trie_ls) ) - allocate ( gis_stochy%epsodn(len_trio_ls) ) - allocate ( gis_stochy%kenorm_e(len_trie_ls) ) - allocate ( gis_stochy%kenorm_o(len_trio_ls) ) -! - allocate ( gis_stochy%snnp1ev(len_trie_ls) ) - allocate ( gis_stochy%snnp1od(len_trio_ls) ) -! - allocate ( gis_stochy%plnev_a(len_trie_ls,latg2) ) - allocate ( gis_stochy%plnod_a(len_trio_ls,latg2) ) - allocate ( gis_stochy%pddev_a(len_trie_ls,latg2) ) - allocate ( gis_stochy%pddod_a(len_trio_ls,latg2) ) - allocate ( gis_stochy%plnew_a(len_trie_ls,latg2) ) - allocate ( gis_stochy%plnow_a(len_trio_ls,latg2) ) - - allocate(colrad_a(latg2)) - allocate(sinlat_a(latg)) - allocate(coslat_a(latg)) - allocate(lat1s_h(0:jcap)) -! - if(gis_stochy%iret/=0) then - write(0,*) 'incompatible namelist - aborted in stochy' - rc = 1 - return - end if -!! - call getcon_spectral(gis_stochy%ls_node, gis_stochy%ls_nodes, & - gis_stochy%max_ls_nodes, gis_stochy%lats_nodes_a, & - gis_stochy%global_lats_a, gis_stochy%lonsperlat, & - gis_stochy%lats_node_a_max, gis_stochy%epse, & - gis_stochy%epso, gis_stochy%epsedn, & - gis_stochy%epsodn, gis_stochy%snnp1ev, & - gis_stochy%snnp1od, gis_stochy%plnev_a, & - gis_stochy%plnod_a, gis_stochy%pddev_a, & - gis_stochy%pddod_a, gis_stochy%plnew_a, & - gis_stochy%plnow_a) -! - gis_stochy%lats_node_a = gis_stochy%lats_nodes_a(gis_stochy%me+1) - gis_stochy%ipt_lats_node_a = ipt_lats_node_a - -! if (gis_stochy%me == 0) & -! write(0,*)'after getcon_spectral lats_node_a=',gis_stochy%lats_node_a & -! ,'ipt_lats_node_a=',gis_stochy%ipt_lats_node_a -! - if (.not. allocated(lats_nodes_h)) allocate (lats_nodes_h(nodes)) - if (.not. allocated(global_lats_h)) allocate (global_lats_h(latg+2*gis_stochy%yhalo*nodes)) - call getcon_lag_stochy(gis_stochy%lats_nodes_a,gis_stochy%global_lats_a, & - lats_nodes_h, global_lats_h, & - gis_stochy%lonsperlat,gis_stochy%xhalo,gis_stochy%yhalo) - -! -! - allocate ( gis_stochy%trie_ls (len_trie_ls,2,lotls) ) - allocate ( gis_stochy%trio_ls (len_trio_ls,2,lotls) ) - -! if (gis_stochy%me == 0) then -! print*, ' lats_dim_a=', lats_dim_a, ' lats_node_a=', gis_stochy%lats_node_a -! endif - rc=0 - - end subroutine initialize_spectral - -end module initialize_spectral_mod diff --git a/mersenne_twister.F b/mersenne_twister.F90 similarity index 97% rename from mersenne_twister.F rename to mersenne_twister.F90 index 8cc6bd5e..9ab6103e 100644 --- a/mersenne_twister.F +++ b/mersenne_twister.F90 @@ -223,19 +223,15 @@ subroutine random_seed(size,put,get,stat) integer,intent(out),optional:: get(nrest) type(random_stat),intent(inout),optional:: stat if(present(size)) then ! return size of seed array -! if(present(put).or.present(get))& -! call errmsg('RANDOM_SEED: more than one option set - some ignored') size=nrest elseif(present(put)) then ! restore from seed array -! if(present(get))& -! call errmsg('RANDOM_SEED: more than one option set - some ignored') if(present(stat)) then stat%mti=put(1) stat%mt=put(2:n+1) stat%iset=put(n+2) stat%gset=transfer(put(n+3:nrest),stat%gset) - if(stat%mti.lt.0.or.stat%mti.gt.n.or.any(stat%mt.eq.0).or. - & stat%iset.lt.0.or.stat%iset.gt.1) then + if(stat%mti.lt.0.or.stat%mti.gt.n.or.any(stat%mt.eq.0).or. & + stat%iset.lt.0.or.stat%iset.gt.1) then call random_setseed_t(iseed,stat) ! call errmsg('RANDOM_SEED: invalid seeds put - default seeds used') endif @@ -244,8 +240,8 @@ subroutine random_seed(size,put,get,stat) sstat%mt=put(2:n+1) sstat%iset=put(n+2) sstat%gset=transfer(put(n+3:nrest),sstat%gset) - if(sstat%mti.lt.0.or.sstat%mti.gt.n.or.any(sstat%mt.eq.0) - & .or.sstat%iset.lt.0.or.sstat%iset.gt.1) then + if(sstat%mti.lt.0.or.sstat%mti.gt.n.or.any(sstat%mt.eq.0) & + .or.sstat%iset.lt.0.or.sstat%iset.gt.1) then call random_setseed_t(iseed,sstat) ! call errmsg('RANDOM_SEED: invalid seeds put - default seeds used') endif @@ -340,17 +336,14 @@ subroutine random_number_t(harvest,stat) if(stat%mti.ge.n) then do kk=0,n-m-1 y=ior(iand(stat%mt(kk),umask),iand(stat%mt(kk+1),lmask)) - stat%mt(kk)=ieor(ieor(stat%mt(kk+m),ishft(y,-1)), - & mag01(iand(y,1))) + stat%mt(kk)=ieor(ieor(stat%mt(kk+m),ishft(y,-1)), mag01(iand(y,1))) enddo do kk=n-m,n-2 y=ior(iand(stat%mt(kk),umask),iand(stat%mt(kk+1),lmask)) - stat%mt(kk)=ieor(ieor(stat%mt(kk+(m-n)),ishft(y,-1)), - & mag01(iand(y,1))) + stat%mt(kk)=ieor(ieor(stat%mt(kk+(m-n)),ishft(y,-1)), mag01(iand(y,1))) enddo y=ior(iand(stat%mt(n-1),umask),iand(stat%mt(0),lmask)) - stat%mt(n-1)=ieor(ieor(stat%mt(m-1),ishft(y,-1)), - & mag01(iand(y,1))) + stat%mt(n-1)=ieor(ieor(stat%mt(m-1),ishft(y,-1)), mag01(iand(y,1))) stat%mti=0 endif y=stat%mt(stat%mti) diff --git a/mpi_wrapper.F90 b/mpi_wrapper.F90 index cde23777..e7566784 100644 --- a/mpi_wrapper.F90 +++ b/mpi_wrapper.F90 @@ -4,7 +4,7 @@ module mpi_wrapper private - public :: mype, npes, root, comm, is_master + public :: mype, npes, root, comm, is_rootpe public :: mpi_wrapper_initialize, mpi_wrapper_finalize public :: mp_reduce_min, mp_reduce_max, mp_reduce_sum public :: mp_bcst, mp_alltoall @@ -59,6 +59,8 @@ module mpi_wrapper MODULE PROCEDURE mp_reduce_sum_r8_1d MODULE PROCEDURE mp_reduce_sum_r8_1darr MODULE PROCEDURE mp_reduce_sum_r8_2darr + MODULE PROCEDURE mp_reduce_sum_i + MODULE PROCEDURE mp_reduce_sum_i8 END INTERFACE INTERFACE mp_alltoall @@ -67,13 +69,13 @@ module mpi_wrapper contains - logical function is_master() + logical function is_rootpe() if (mype==root) then - is_master = .true. + is_rootpe = .true. else - is_master = .false. + is_rootpe = .false. end if - end function is_master + end function is_rootpe subroutine mpi_wrapper_initialize(mpiroot, mpicomm) integer, intent(in) :: mpiroot, mpicomm @@ -643,6 +645,53 @@ end subroutine mp_reduce_sum_r8_2darr ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! ! +!------------------------------------------------------------------------------- +! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +! +! mp_reduce_sum_i :: Call SPMD REDUCE_SUM +! + subroutine mp_reduce_sum_i(mysum) + integer, intent(INOUT) :: mysum + + integer :: gsum + + call MPI_ALLREDUCE( mysum, gsum, 1, MPI_INTEGER, MPI_SUM, & + comm, ierror ) + + mysum = gsum + + end subroutine mp_reduce_sum_i +! +! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!------------------------------------------------------------------------------- + + + +!------------------------------------------------------------------------------- +! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + +!------------------------------------------------------------------------------- +! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +! +! mp_reduce_sum_i8 :: Call SPMD REDUCE_SUM +! + subroutine mp_reduce_sum_i8(mysum) + integer*8, intent(INOUT) :: mysum + + integer*8 :: gsum + + call MPI_ALLREDUCE( mysum, gsum, 1, MPI_INTEGER8, MPI_SUM, & + comm, ierror ) + + mysum = gsum + + end subroutine mp_reduce_sum_i8 +! +! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!------------------------------------------------------------------------------- + + + !------------------------------------------------------------------------------- ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! ! diff --git a/num_parthds_stochy.f b/num_parthds_stochy.f deleted file mode 100644 index 58b7ccbe..00000000 --- a/num_parthds_stochy.f +++ /dev/null @@ -1,11 +0,0 @@ -! this function is no longer used, and will be removed soon - function num_parthds_stochy() - integer:: number_of_openMP_threads - character(2) :: omp_threads - integer :: stat - call get_environment_variable("OMP_NUM_THREADS",omp_threads) - read(omp_threads,*,iostat=stat)number_of_openMP_threads - num_parthds_stochy = number_of_openMP_threads - return - end - diff --git a/pln2eo_stochy.f b/pln2eo_stochy.f deleted file mode 100644 index c5316cb1..00000000 --- a/pln2eo_stochy.f +++ /dev/null @@ -1,288 +0,0 @@ -!>@brief The module 'pln2eo_a_stochy_mod' contains the subroutine pln2eo_a_stochy - module pln2eo_a_stochy_mod - - implicit none - - contains - -!>@brief The subroutine 'pln2eo_a_stochy' calculates the assoicate legendre polynomials -!>@details This code is taken from the legacy spectral GFS - subroutine pln2eo_a_stochy(plnev_a,plnod_a,epse,epso, - & ls_node,num_lat) -! -! use x-number method to archieve accuracy due to recursive to avoid -! underflow and overflow if necessary by henry juang 2012 july -! - use spectral_layout_mod - use kinddef - implicit none -! -! define x number constant for real8 start - integer, parameter :: in_f = 960 , in_h = in_f/2 - real(kind=kind_dbl_prec), parameter :: bb_f = 2.d0 ** ( in_f ) - real(kind=kind_dbl_prec), parameter :: bs_f = 2.d0 ** (-in_f ) - real(kind=kind_dbl_prec), parameter :: bb_h = 2.d0 ** ( in_h ) - real(kind=kind_dbl_prec), parameter :: bs_h = 2.d0 ** (-in_h ) -! define x number constant end - -cc - real(kind=kind_dbl_prec) plnev_a(len_trie_ls,latg2) - real(kind=kind_dbl_prec) plnod_a(len_trio_ls,latg2) -cc - real(kind=kind_dbl_prec) epse(len_trie_ls) - real(kind=kind_dbl_prec) epso(len_trio_ls) -cc -cc - integer ls_node(ls_dim,3) -cc - integer num_lat -cc -!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L -!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev -!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod -cc - integer l,lat,locl,max_l,n -cc - integer indev - integer indod -cc -! need index for alp to be x-number - integer id, ialp1, ialp2, ialp3, iprod - integer ialp10(0:jcap) - real(kind=kind_dbl_prec) aa, bb, w - - real(kind=kind_dbl_prec) alp1,alp2,alp3 - real(kind=kind_dbl_prec) cos2,fl,prod,sinlat,coslat -cc - real(kind=kind_dbl_prec) alp10(0:jcap) -cc - real(kind=kind_dbl_prec) cons0,cons0p5,cons1,cons2,cons3 !constant -cc -cc - integer indlsev,jbasev - integer indlsod,jbasod -cc - include 'function2' -cc -cc - cons0=0.0d0 !constant - cons0p5=0.5d0 !constant - cons1=1.0d0 !constant - cons2=2.0d0 !constant - cons3=3.0d0 !constant -cc -cc - max_l=-1 - do locl=1,ls_max_node - max_l = max ( max_l, ls_node(locl,1) ) - enddo -cc -cc - do lat=1,num_lat -cc - sinlat = cos(colrad_a(lat)) - cos2=cons1-sinlat*sinlat !constant - coslat = sqrt(cos2) - -! use x number for alp10 - alp10(0) = sqrt(0.5) - ialp10(0) = 0 - - do l=1,max_l - fl = l - prod=coslat*sqrt(cons1+cons1/(cons2*fl)) - iprod=0 - w = abs(prod) - if( w.ge.bb_h ) then - prod = prod * bs_f - iprod = iprod + 1 - elseif( w.lt.bs_h ) then - prod = prod * bb_f - iprod = iprod - 1 - endif - alp10(l)=alp10(l-1)*prod - ialp10(l)=ialp10(l-1)+iprod - w = abs(alp10(l)) - if( w.ge.bb_h ) then - alp10(l) = alp10(l) * bs_f - ialp10(l) = ialp10(l) + 1 - elseif( w.lt.bs_h ) then - alp10(l) = alp10(l) * bb_f - ialp10(l) = ialp10(l) - 1 - endif - enddo -cc - do locl=1,ls_max_node - l=ls_node(locl,1) - jbasev=ls_node(locl,2) - jbasod=ls_node(locl,3) - n=l - fl=l -! get m=normalized x number for alp1 start - alp1=alp10(l) - ialp1=ialp10(l) - - indev=indlsev(n ,l) - indod=indlsod(n+1,l) -! x2f plnev_a(indev ,lat)=alp1 -! x2f start - if( ialp1.eq.0 ) then - plnev_a(indev ,lat)=alp1 - elseif( ialp1.eq.-1 ) then - plnev_a(indev ,lat)=alp1 * bs_f - elseif( ialp1.lt.-1 ) then - plnev_a(indev ,lat)=0.0 -!! plnev_a(indev ,lat)=alp1 * bs_f * bs_f - else - plnev_a(indev ,lat)=alp1 * bb_f - endif -! x2f end - -! xltime alp2=sqrt(cons2*fl+cons3)*sinlat*alp1 !constant -! xltime start - prod=sqrt(cons2*fl+cons3)*sinlat - iprod=0 - w = abs(prod) - if( w.ge.bb_h ) then - prod = prod * bs_f - iprod = iprod + 1 - elseif( w.lt.bs_h ) then - prod = prod * bb_f - iprod = iprod - 1 - endif - alp2=alp1*prod - ialp2 = ialp1 + iprod -! xltime end -! norm alp2 start - w = abs(alp2) - if( w.ge.bb_h ) then - alp2 = alp2*bs_f - ialp2 = ialp2 + 1 - elseif( w.lt.bs_h ) then - alp2 = alp2*bb_f - ialp2 = ialp2 - 1 - endif -! norm alp2 end - -! x2f plnod_a(indod ,lat)=alp2 -! x2f start - if( ialp2.eq.0 ) then - plnod_a(indod ,lat)=alp2 - elseif( ialp2.eq.-1 ) then - plnod_a(indod ,lat)=alp2 * bs_f - elseif( ialp2.lt.-1 ) then - plnod_a(indod ,lat)=0.0 -!! plnod_a(indod ,lat)=alp2 * bs_f * bs_f - else - plnod_a(indod ,lat)=alp2 * bb_f - endif -! x2f end -cc - do n=l+2,jcap+1 - if(mod(n+l,2).eq.0) then - indev=indev+1 -! xlsum2 start - aa = sinlat / epse(indev) - bb = epso(indod) / epse(indev) - id = ialp2 - ialp1 - if( id.eq.0 ) then - alp3 = aa*alp2 - bb*alp1 - ialp3 = ialp1 - elseif( id.eq.1 ) then - alp3 = aa*alp2 - bb*alp1*bs_f - ialp3 = ialp2 - elseif( id.eq.-1 ) then - alp3 = aa*alp2*bs_f - bb*alp1 - ialp3 = ialp1 - elseif( id.gt.1 ) then - alp3 = aa*alp2 - ialp3 = ialp2 - else - alp3 = - bb*alp1 - ialp3 = ialp1 - endif -! xlsum2 end -! xnorm alp3 start - w = abs(alp3) - if( w.ge.bb_h ) then - alp3 = alp3*bs_f - ialp3 = ialp3 + 1 - elseif( w.lt.bs_h ) then - alp3 = alp3*bb_f - ialp3 = ialp3 - 1 - endif -! xnorm alp3 end - -! x2f alp3 start - if( ialp3.eq.0 ) then - plnev_a(indev,lat)=alp3 - elseif( ialp3.eq.-1 ) then - plnev_a(indev,lat)=alp3 * bs_f - elseif( ialp3.lt.-1 ) then - plnev_a(indev,lat)=0.0 - else - plnev_a(indev,lat)=alp3 * bb_f - endif -! x2f alp3 end - - else - indod=indod+1 - -! xlsum2 start - aa = sinlat / epso(indod) - bb = epse(indev) / epso(indod) - id = ialp2 - ialp1 - if( id.eq.0 ) then - alp3 = aa*alp2 - bb*alp1 - ialp3 = ialp1 - elseif( id.eq.1 ) then - alp3 = aa*alp2 - bb*alp1*bs_f - ialp3 = ialp2 - elseif( id.eq.-1 ) then - alp3 = aa*alp2*bs_f - bb*alp1 - ialp3 = ialp1 - elseif( id.gt.1 ) then - alp3 = aa*alp2 - ialp3 = ialp2 - else - alp3 = - bb*alp1 - ialp3 = ialp1 - endif -! xlsum2 end -! xnorm alp3 start - w = abs(alp3) - if( w.ge.bb_h ) then - alp3 = alp3*bs_f - ialp3 = ialp3 + 1 - elseif( w.lt.bs_h ) then - alp3 = alp3*bb_f - ialp3 = ialp3 - 1 - endif -! xnorm alp3 end - -! x2f alp3 start - if( ialp3.eq.0 ) then - plnod_a(indod,lat)=alp3 - elseif( ialp3.eq.-1 ) then - plnod_a(indod,lat)=alp3 * bs_f - elseif( ialp3.lt.-1 ) then - plnod_a(indod,lat)=0.0 - else - plnod_a(indod,lat)=alp3 * bb_f - endif -! x2f alp3 end - endif - alp1=alp2 - alp2=alp3 - ialp1 = ialp2 - ialp2 = ialp3 - enddo -cc - enddo -cc - enddo -cc - return - end - - end module pln2eo_a_stochy_mod diff --git a/plumes.f90 b/plumes.F90 similarity index 100% rename from plumes.f90 rename to plumes.F90 diff --git a/random_numbers.F90 b/random_numbers.F90 new file mode 100644 index 00000000..e082e8d5 --- /dev/null +++ b/random_numbers.F90 @@ -0,0 +1,30 @@ +module random_numbers + + implicit none + +contains +!> Returns a random number between 0 and 1 +!! See https://arxiv.org/abs/2004.06278. Not an exact reproduction of +!"squares" because Fortran +!! doesn't have a uint64 type, and not all compilers provide integers +!with > 64 bits... +real function random_01_CB(ctr, key) + use iso_fortran_env, only : int64 + integer, intent(in) :: ctr !< ctr should be incremented each time you call the function + integer, intent(in) :: key !< key is like a seed: use a different key for each random stream + integer(kind=int64) :: x, y, z ! Follows "Squares" naming convention + + x = (ctr + 1) * (key + 65536) ! 65536 added because keys below that don't work. + y = (ctr + 1) * (key + 65536) + z = y + (key + 65536) + x = x*x + y + x = ior(ishft(x,32),ishft(x,-32)) + x = x*x + z + x = ior(ishft(x,32),ishft(x,-32)) + x = x*x + y + x = ior(ishft(x,32),ishft(x,-32)) + x = x*x + z + random_01_CB = .5*(1. + .5*real(int(ishft(x,-32)))/real(2**30)) + +end function +end module random_numbers diff --git a/setlats_a_stochy.f b/setlats_a_stochy.f deleted file mode 100644 index 9db140fd..00000000 --- a/setlats_a_stochy.f +++ /dev/null @@ -1,196 +0,0 @@ -!>@brief The module 'setlats_a_stochy_mod' contains the subroutine setlats_a_stochy - module setlats_a_stochy_mod - - implicit none - - contains -!>@brief The subroutine 'setlats_a_stochy' selects the latitude points on this task -!>@details This code is taken from the legacy spectral GFS - subroutine setlats_a_stochy(lats_nodes_a,global_lats_a, - & iprint,lonsperlat) -! - use spectral_layout_mod , only : nodes,me,latg,lonf -! - implicit none -! - integer, dimension(latg) :: global_lats_a, lonsperlat - integer lats_nodes_a(nodes) - - integer iprint,opt,ifin,nodesio - &, jcount,jpt,lat,lats_sum,node,i,ii - &, ngrptg,ngrptl,ipe,irest,idp - &, ngrptgh,nodesioh -! &, ilatpe,ngrptg,ngrptl,ipe,irest,idp -! - integer,allocatable :: lats_hold(:,:) -! - allocate ( lats_hold(latg,nodes) ) -! -! iprint = 1 - iprint = 0 - opt = 1 ! reduced grid - if (opt == 2) lonsperlat = lonf ! full grid - lats_nodes_a = 0 -! if (liope .and. icolor == 2) then -! nodesio = 1 -! else - nodesio = nodes -! endif -! - ngrptg = 0 - do lat=1,latg - do i=1,lonsperlat(lat) - ngrptg = ngrptg + 1 - enddo - enddo - -! -! ngrptg contains total number of grid points. -! -! distribution of the grid - nodesioh = nodesio / 2 - - if (nodesioh*2 /= nodesio) then -! ilatpe = ngrptg / nodesio - ngrptl = 0 - ipe = 0 - irest = 0 - idp = 1 - - do lat=1,latg - ifin = lonsperlat(lat) - ngrptl = ngrptl + ifin - -! if (me == 0) -! &write(2000+me,*)'in setlats lat=',lat,' latg=',latg,' ifin=',ifin -! &,' ngrptl=',ngrptl,' nodesio=',nodesio,' ngrptg=',ngrptg -! &,' irest=',irest - - if (ngrptl*nodesio <= ngrptg+irest) then - lats_nodes_a(ipe+1) = lats_nodes_a(ipe+1) + 1 - lats_hold(idp,ipe+1) = lat - idp = idp + 1 -! if (me == 0) -! & write(2000+me,*)' nodesio1=',nodesio,' idp=',idp,' ipe=',ipe - else - ipe = ipe + 1 - if (ipe <= nodesio) lats_hold(1,ipe+1) = lat - idp = 2 - irest = irest + ngrptg - (ngrptl-ifin)*nodesio - ngrptl = ifin - lats_nodes_a(ipe+1) = lats_nodes_a(ipe+1) + 1 -! if (me == 0) -! & write(2000+me,*)' nodesio1=',nodesio,' idp=',idp,' ipe=',ipe - endif -! if (me == 0) -! & write(2000+me,*)' lat=',lat,' lats_nodes_a=',lats_nodes_a(ipe+1) -! &,' ipe+1=',ipe+1 - enddo - else - nodesioh = nodesio/2 - ngrptgh = ngrptg/2 - ngrptl = 0 - ipe = 0 - irest = 0 - idp = 1 - - do lat=1,latg/2 - ifin = lonsperlat(lat) - ngrptl = ngrptl + ifin - -! if (me == 0) -! &write(0,*)'in setlats lat=',lat,' latg=',latg,' ifin=',ifin -! &,' ngrptl=',ngrptl,' nodesio=',nodesio,' ngrptg=',ngrptg -! &,' irest=',irest,' ngrptgh=',ngrptgh,' nodesioh=',nodesioh - - if (ngrptl*nodesioh <= ngrptgh+irest .or. lat == latg/2) then - lats_nodes_a(ipe+1) = lats_nodes_a(ipe+1) + 1 - lats_hold(idp,ipe+1) = lat -! lats_nodes_a(nodesio-ipe) = lats_nodes_a(nodesio-ipe) + 1 -! lats_hold(idp,nodesio-ipe) = latg+1-lat - idp = idp + 1 -! if (me == 0) -! & write(0,*)' nodesio1=',nodesioh,' idp=',idp,' ipe=',ipe - else - ipe = ipe + 1 - if (ipe <= nodesioh) then - lats_hold(1,ipe+1) = lat -! lats_hold(1,nodesio-ipe) = latg+1-lat - endif - idp = 2 - irest = irest + ngrptgh - (ngrptl-ifin)*nodesioh - ngrptl = ifin - lats_nodes_a(ipe+1) = lats_nodes_a(ipe+1) + 1 -! lats_nodes_a(nodesio-ipe) = lats_nodes_a(nodesio-ipe) + 1 -! if (me == 0) -! & write(0,*)' nodesio1h=',nodesioh,'idp=',idp,' ipe=',ipe - endif -! if (me == 0) -! & write(0,*)' lat=',lat,' lats_nodes_a=',lats_nodes_a(ipe+1) -! &,' ipe+1=',ipe+1 - enddo - do node=1, nodesioh - ii = nodesio-node+1 - jpt = lats_nodes_a(node) - lats_nodes_a(ii) = jpt - do i=1,jpt - lats_hold(jpt+1-i,ii) = latg+1-lats_hold(i,node) - enddo - enddo - - - endif -!! -!!........................................................ -!! - jpt = 0 - do node=1,nodesio -! write(2000+me,*)'node=',node,' lats_nodes_a=',lats_nodes_a(node) -! &, ' jpt=',jpt,' nodesio=',nodesio - if ( lats_nodes_a(node) > 0 ) then - do jcount=1,lats_nodes_a(node) - global_lats_a(jpt+jcount) = lats_hold(jcount,node) -! write(2000+me,*)' jpt+jcount=',jpt+jcount -! &, 'global_lats_a=',global_lats_a(jpt+jcount) - enddo - endif - jpt = jpt + lats_nodes_a(node) - enddo -!! - deallocate (lats_hold) - if ( iprint /= 1 ) return -!! - if (me == 0) then - jpt=0 - do node=1,nodesio - if ( lats_nodes_a(node) > 0 ) then - print 600 - lats_sum=0 - do jcount=1,lats_nodes_a(node) - lats_sum=lats_sum + lonsperlat(global_lats_a(jpt+jcount)) - print 700, node-1, - x node, lats_nodes_a(node), - x jpt+jcount, global_lats_a(jpt+jcount), - x lonsperlat(global_lats_a(jpt+jcount)), - x lats_sum - enddo - endif - jpt=jpt+lats_nodes_a(node) - enddo -! - print 600 -! - 600 format ( ' ' ) -! - 700 format ( 'setlats me=', i4, - x ' lats_nodes_a(', i4, ' )=', i4, - x ' global_lats_a(', i4, ' )=', i4, - x ' lonsperlat=', i5, - x ' lats_sum=', i6 ) -! - endif - - return - end - - end module setlats_a_stochy_mod diff --git a/setlats_lag_stochy.f b/setlats_lag_stochy.f deleted file mode 100644 index ddf8ebd5..00000000 --- a/setlats_lag_stochy.f +++ /dev/null @@ -1,134 +0,0 @@ -!>@brief The module 'setlats_lag_stochy_mod' contains the subroutine setlats_lag_stochy - module setlats_lag_stochy_mod - - implicit none - - contains - -!>@brief The subroutine 'setlats_a_stochy' selects the latitude points on this task -! and halos -!>@details This code is taken from the legacy spectral GFS - subroutine setlats_lag_stochy(lats_nodes_a, global_lats_a, - & lats_nodes_h, global_lats_h, yhalo) -! - use spectral_layout_mod, only : me,nodes,latg - implicit none -! - integer yhalo -! - integer lats_nodes_a(nodes), lats_nodes_h(nodes) - &, global_lats_a(latg) - &, global_lats_h(latg+2*yhalo*nodes) -! - integer jj,jpt_a,jpt_h,lat_val,nn,nodes_lats - &, j1, j2, iprint -! - lats_nodes_h = 0 -! - nodes_lats = 0 - do nn=1,nodes - if (lats_nodes_a(nn) > 0) then - lats_nodes_h(nn) = lats_nodes_a(nn) + yhalo + yhalo - nodes_lats = nodes_lats + 1 - endif - enddo -! - global_lats_h = 0 -! -! set non-yhalo latitudes -! - jpt_a = 0 - jpt_h = yhalo - do nn=1,nodes - if (lats_nodes_a(nn) > 0) then - do jj=1,lats_nodes_a(nn) - jpt_a = jpt_a + 1 - jpt_h = jpt_h + 1 - global_lats_h(jpt_h) = global_lats_a(jpt_a) - enddo - jpt_h = jpt_h + yhalo + yhalo - endif - enddo -! - j1 = latg + (yhalo+yhalo) * nodes_lats - do jj=1,yhalo - j2 = yhalo - jj - global_lats_h(jj) = global_lats_a(1) + j2 ! set north pole yhalo - global_lats_h(j1-j2) = global_lats_a(latg) + 1 - jj ! set south pole yhalo - enddo -! - if (lats_nodes_a(1) /= latg) then -! -! set non-polar south yhalos - jpt_h = 0 - do nn=1,nodes-1 - if (lats_nodes_h(nn).GT.0) then - jpt_h = jpt_h + lats_nodes_h(nn) - lat_val = global_lats_h(jpt_h-yhalo) - do jj=1,yhalo - global_lats_h(jpt_h-yhalo+jj) = min(lat_val+jj,latg) - enddo - endif - enddo -! -! set non-polar north yhalos - jpt_h = 0 - do nn=1,nodes-1 - if (lats_nodes_h(nn).GT.0) then - jpt_h = jpt_h + lats_nodes_h(nn) - lat_val = global_lats_h(jpt_h+yhalo+1) - do jj=1,yhalo - global_lats_h(jpt_h+yhalo-(jj-1)) = max(lat_val-jj,1) - enddo - endif - enddo -! - endif -! - - iprint = 0 -! iprint = 1 - if (iprint == 1 .and. me == 0) then -! - write(me+6000,'("setlats_h yhalo=",i3," nodes=",i3/)') - & yhalo,nodes -! - do nn=1,nodes - write(me+6000,'("lats_nodes_a(",i4,")=",i4," ", - & " lats_nodes_h(",i4,")=",i4)') - & nn, lats_nodes_a(nn), - & nn, lats_nodes_h(nn) - enddo -! - jpt_a = 0 - do nn=1,nodes - if (lats_nodes_a(nn) > 0) then - write(me+6000,'(" ")') - do jj=1,lats_nodes_a(nn) - jpt_a=jpt_a+1 - write(me+6000,'(2i4," global_lats_a(",i4,")=",i4)') - & nn, jj, jpt_a, global_lats_a(jpt_a) - enddo - endif - enddo -! - jpt_h=0 - do nn=1,nodes - if (lats_nodes_h(nn).gt.0) then - write(me+6000,'(" ")') - do jj=1,lats_nodes_h(nn) - jpt_h=jpt_h+1 - write(me+6000,'(2i4," global_lats_h(",i4,")=",i4)') - & nn, jj, jpt_h, global_lats_h(jpt_h) - enddo - endif - enddo -! - close(6000+me) - endif -! close(6000+me) -! - return - end - - end module setlats_lag_stochy_mod diff --git a/spectral_layout.F90 b/spectral_layout.F90 deleted file mode 100644 index f8477760..00000000 --- a/spectral_layout.F90 +++ /dev/null @@ -1,269 +0,0 @@ -!>@brief The module 'spectral_layout_mod' contains the gaussian grid domain decompostion -! and the subroutine to interpolate from the gaussian grid to cubed-sphere (or any lat-lon pair) -module spectral_layout_mod - - implicit none - -! -! program log: -! 20161011 philip pegion : make stochastic pattern generator standalone -! -! 20190503 dom heinzeller : add ompthreads and stochy_la2ga; todo: cleanup nodes, me, ... (defined multiple times in several files) -! 20201002 philip pegion: cleanup of code -! - integer :: nodes, & - me, & - master, & - lon_dim_a, & - ls_dim, & - ls_max_node, & - lats_dim_a, & - lats_node_a, & - lats_node_a_max, & - ipt_lats_node_a, & - len_trie_ls, & - len_trio_ls, & - len_trie_ls_max, & - len_trio_ls_max, & - lats_dim_ext, & - jcap,latg,latg2, & - skeblevs,levs,lnt, & - lonf,lonfx, & - latgd,lotls - -! - integer, allocatable :: lat1s_a(:), lon_dims_a(:),lon_dims_ext(:) - real, allocatable, dimension(:) :: colrad_a, wgt_a, wgtcs_a, rcs2_a, & - sinlat_a, coslat_a - integer ,allocatable, dimension(:) :: lats_nodes_h,global_lats_h - - integer lats_dim_h, & - lats_node_h, & - lats_node_h_max, & - ipt_lats_node_h, & - lon_dim_h - INTEGER ,ALLOCATABLE :: lat1s_h(:) - -contains - -! - ! interpolation from lat/lon or gaussian grid to other lat/lon grid - ! -!>@brief The subroutine 'stochy_la2ga' intepolates from the global gaussian grid -!! to the cubed sphere points -!>@details This code is taken from the legacy spectral GFS - subroutine stochy_la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat, & - gauout,len,outlat, outlon) - use kinddef , only : kind_io8, kind_io4 - implicit none - ! interface variables - real (kind=kind_io8), intent(in) :: regin(imxin,jmxin) - integer, intent(in) :: imxin - integer, intent(in) :: jmxin - real (kind=kind_io8), intent(in) :: rinlon(imxin) - real (kind=kind_io8), intent(in) :: rinlat(jmxin) - real (kind=kind_io8), intent(in) :: rlon - real (kind=kind_io8), intent(in) :: rlat - real (kind=kind_io8), intent(out) :: gauout(len) - integer, intent(in) :: len - real (kind=kind_io8), intent(in) :: outlat(len) - real (kind=kind_io8), intent(in) :: outlon(len) - ! local variables - real (kind=kind_io8) :: sum2,sum1,sum3,sum4 - real (kind=kind_io8) :: wsum,wsumiv,sums,sumn,wi2j2,x,y,wi1j1 - real (kind=kind_io8) :: wi1j2,wi2j1,aphi,rnume,alamd,denom - integer :: i,j,jq,jx - integer :: j1,j2,ii,i1,i2 - integer :: iindx1(len) - integer :: iindx2(len) - integer :: jindx1(len) - integer :: jindx2(len) - real(kind=kind_io8) :: ddx(len) - real(kind=kind_io8) :: ddy(len) - real(kind=kind_io8) :: wrk(len) -! -! -! find i-index for interpolation - do i=1,len - alamd = outlon(i) - if (alamd .lt. rlon) alamd = alamd + 360.0 - if (alamd .gt. 360.0+rlon) alamd = alamd - 360.0 - wrk(i) = alamd - iindx1(i) = imxin - enddo - do i=1,len - do ii=1,imxin - if(wrk(i) .ge. rinlon(ii)) iindx1(i) = ii - enddo - enddo - do i=1,len - i1 = iindx1(i) - if (i1 .lt. 1) i1 = imxin - i2 = i1 + 1 - if (i2 .gt. imxin) i2 = 1 - iindx1(i) = i1 - iindx2(i) = i2 - denom = rinlon(i2) - rinlon(i1) - if(denom.lt.0.) denom = denom + 360. - rnume = wrk(i) - rinlon(i1) - if(rnume.lt.0.) rnume = rnume + 360. - ddx(i) = rnume / denom - enddo -! -! find j-index for interplation -! - if(rlat.gt.0.) then - do j=1,len - jindx1(j)=0 - enddo - do jx=1,jmxin - do j=1,len - if(outlat(j).le.rinlat(jx)) jindx1(j) = jx - enddo - enddo - do j=1,len - jq = jindx1(j) - aphi=outlat(j) - if(jq.ge.1 .and. jq .lt. jmxin) then - j2=jq+1 - j1=jq - ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1)) - elseif (jq .eq. 0) then - j2=1 - j1=1 - if(abs(90.-rinlat(j1)).gt.0.001) then - ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1)) - else - ddy(j)=0.0 - endif - else - j2=jmxin - j1=jmxin - if(abs(-90.-rinlat(j1)).gt.0.001) then - ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1)) - else - ddy(j)=0.0 - endif - endif - jindx1(j)=j1 - jindx2(j)=j2 - enddo - else - do j=1,len - jindx1(j) = jmxin+1 - enddo - do jx=jmxin,1,-1 - do j=1,len - if(outlat(j).le.rinlat(jx)) jindx1(j) = jx - enddo - enddo - do j=1,len - jq = jindx1(j) - aphi=outlat(j) - if(jq.gt.1 .and. jq .le. jmxin) then - j2=jq - j1=jq-1 - ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1)) - elseif (jq .eq. 1) then - j2=1 - j1=1 - if(abs(-90.-rinlat(j1)).gt.0.001) then - ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1)) - else - ddy(j)=0.0 - endif - else - j2=jmxin - j1=jmxin - if(abs(90.-rinlat(j1)).gt.0.001) then - ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1)) - else - ddy(j)=0.0 - endif - endif - jindx1(j)=j1 - jindx2(j)=j2 - enddo - endif -! - sum1 = 0. - sum2 = 0. - sum3 = 0. - sum4 = 0. - do i=1,imxin - sum1 = sum1 + regin(i,1) - sum2 = sum2 + regin(i,jmxin) - enddo - sum1 = sum1 / imxin - sum2 = sum2 / imxin - sum3 = sum1 - sum4 = sum2 -! -! quasi-bilinear interpolation -! - do i=1,len - y = ddy(i) - j1 = jindx1(i) - j2 = jindx2(i) - x = ddx(i) - i1 = iindx1(i) - i2 = iindx2(i) -! - wi1j1 = (1.-x) * (1.-y) - wi2j1 = x *( 1.-y) - wi1j2 = (1.-x) * y - wi2j2 = x * y -! - wsum = wi1j1 + wi2j1 + wi1j2 + wi2j2 - wrk(i) = wsum - if(wsum.ne.0.) then - wsumiv = 1./wsum - if(j1.ne.j2) then - gauout(i) = (wi1j1*regin(i1,j1) + wi2j1*regin(i2,j1) + & - wi1j2*regin(i1,j2) + wi2j2*regin(i2,j2)) & - *wsumiv - else - if (rlat .gt. 0.0) then - sumn = sum3 - sums = sum4 - if( j1 .eq. 1) then - gauout(i) = (wi1j1*sumn +wi2j1*sumn + & - wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2)) & - * wsumiv - elseif (j1 .eq. jmxin) then - gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+ & - wi1j2*sums +wi2j2*sums ) & - * wsumiv - endif - else - sums = sum3 - sumn = sum4 - if( j1 .eq. 1) then - gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+ & - wi1j2*sums +wi2j2*sums ) & - * wsumiv - elseif (j1 .eq. jmxin) then - gauout(i) = (wi1j1*sumn +wi2j1*sumn + & - wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2)) & - * wsumiv - endif - endif - endif ! if j1 .ne. j2 - endif - enddo - do i=1,len - j1 = jindx1(i) - j2 = jindx2(i) - i1 = iindx1(i) - i2 = iindx2(i) - if(wrk(i) .eq. 0.0) then - write(6,*) ' la2ga: error' - call sleep(2) - stop - endif - enddo - return -! - end subroutine stochy_la2ga - -end module spectral_layout_mod diff --git a/spectral_transforms.F90 b/spectral_transforms.F90 new file mode 100644 index 00000000..71e14bb2 --- /dev/null +++ b/spectral_transforms.F90 @@ -0,0 +1,2366 @@ +!>@brief The module 'spectral_transforms' contains the subroutines spec_to_four and four_to_grid +module spectral_transforms + + use kinddef + use mpi_wrapper, only : mp_alltoall,mype,npes + use stochy_internal_state_mod, only : stochy_internal_state + use stochy_namelist_def + + private + public :: spec_to_four, four_to_grid,dozeuv_stochy,dezouv_stochy + public :: initialize_spectral,stochy_la2ga + + integer, public :: ls_dim, & + ls_max_node, & + len_trie_ls, & + len_trio_ls, & + jcap,latg,latg2, & + skeblevs,levs,lnt, & + lonf,lonfx + +! + integer, public, allocatable :: lat1s_a(:), lon_dims_a(:) + real, public, allocatable, dimension(:) :: colrad_a, wgt_a, rcs2_a, & + sinlat_a, coslat_a + + + contains + +!>@brief The subrountine 'spec_to_four' converts the spherical harmonics to fourier coefficients +!>@details This code is taken from the legacy spectral GFS + subroutine spec_to_four(flnev,flnod,plnev,plnod, & + ls_node, & + workdim,four_gr, & + ls_nodes,max_ls_nodes, & + lats_nodes,global_lats, & + lats_node,ipt_lats_node, & + nvars ) +! + + implicit none +! + external esmf_dgemm +! + integer, intent(in) :: nvars + real(kind=kind_dbl_prec) flnev(len_trie_ls,2*nvars) + real(kind=kind_dbl_prec) flnod(len_trio_ls,2*nvars) +! + real(kind=kind_dbl_prec) plnev(len_trie_ls,latg2) + real(kind=kind_dbl_prec) plnod(len_trio_ls,latg2) +! + integer ls_node(ls_dim,3) +! +!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L +!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev +!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod +! +! local scalars +! ------------- +! + integer j, l, lat, lat1, n, kn, n2,indev,indod +! +! local arrays +! ------------ +! + real(kind=kind_dbl_prec), dimension(nvars*2,latg2) :: apev, apod +! xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +! + integer workdim, lats_node, ipt_lats_node +! + real(kind=kind_dbl_prec) four_gr(lonf+2,nvars,workdim) +! + integer ls_nodes(ls_dim,npes) + integer, dimension(npes) :: max_ls_nodes, lats_nodes + integer, dimension(latg) :: global_lats + real(kind=4),target,dimension(2,nvars,ls_dim*workdim,npes):: workr,works + real(kind=4),pointer:: work1dr(:),work1ds(:) + integer, dimension(npes) :: kpts, kptr, sendcounts, recvcounts, sdispls +! + integer ilat,ipt_ls, lmax,lval,jj,nv + integer node,arrsz,my_pe,nvar + integer ilat_list(npes) ! for OMP buffer copy +! +! statement functions +! ------------------- +! + integer indlsev, jbasev, indlsod, jbasod +! + include 'function_indlsev' + include 'function_indlsod' +! + real(kind=kind_dbl_prec), parameter :: cons0=0.0d0, cons1=1.0d0 +! +! xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +! + n2=2*nvars + arrsz=n2*ls_dim*workdim*npes + kpts = 0 +! + do j = 1, ls_max_node ! start of do j loop ##################### +! + l = ls_node(j,1) + jbasev = ls_node(j,2) + jbasod = ls_node(j,3) + + indev = indlsev(l,l) + indod = indlsod(l+1,l) +! + lat1 = lat1s_a(l) + +! compute the even and odd components of the fourier coefficients +! +! compute the sum of the even real terms for each level +! compute the sum of the even imaginary terms for each level +! + call esmf_dgemm('t', 'n', n2, latg2-lat1+1, (jcap+3-l)/2, & + cons1, flnev(indev,1), len_trie_ls, plnev(indev,lat1), & + len_trie_ls, cons0, apev(1,lat1), n2 ) +! +! compute the sum of the odd real terms for each level +! compute the sum of the odd imaginary terms for each level +! + call esmf_dgemm('t', 'n', n2, latg2-lat1+1, (jcap+2-l)/2, & + cons1, flnod(indod,1), len_trio_ls, plnod(indod,lat1), & + len_trio_ls, cons0, apod(1,lat1), n2 ) +! +!cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +! +! compute the fourier coefficients for each level +! ----------------------------------------------- +! + ilat_list(1) = 0 + do node = 1, npes - 1 + ilat_list(node+1) = ilat_list(node) + lats_nodes(node) + end do +!$omp parallel do private(node,jj,ilat,lat,ipt_ls,nvar,kn,n2) + do node=1,npes + do jj=1,lats_nodes(node) + ilat = ilat_list(node) + jj + lat = global_lats(ilat) + ipt_ls = min(lat,latg-lat+1) + if ( ipt_ls >= lat1s_a(ls_nodes(j,mype+1)) ) then + kpts(node) = kpts(node) + 1 + kn = kpts(node) +! + if ( lat <= latg2 ) then +! northern hemisphere + do nvar=1,nvars + n2 = nvar + nvar + works(1,nvar,kn,node) = apev(n2-1,ipt_ls) + apod(n2-1,ipt_ls) + works(2,nvar,kn,node) = apev(n2,ipt_ls) + apod(n2,ipt_ls) + enddo + else +! southern hemisphere + do nvar=1,nvars + n2 = nvar + nvar + works(1,nvar,kn,node) = apev(n2-1,ipt_ls) - apod(n2-1,ipt_ls) + works(2,nvar,kn,node) = apev(n2,ipt_ls) - apod(n2,ipt_ls) + enddo + endif + endif + enddo + enddo +! + enddo ! end of do j loop ####################################### +! + kptr = 0 + do node=1,npes + do l=1,max_ls_nodes(node) + lval = ls_nodes(l,node)+1 + do j=1,lats_node + lat = global_lats(ipt_lats_node-1+j) + if ( min(lat,latg-lat+1) >= lat1s_a(lval-1) ) then + kptr(node) = kptr(node) + 1 + endif + enddo + enddo + enddo +! +! +!$omp parallel do private(node) + do node=1,npes + sendcounts(node) = kpts(node) * n2 + recvcounts(node) = kptr(node) * n2 + sdispls(node) = (node-1) * n2 * ls_dim * workdim + end do + work1dr(1:arrsz)=>workr + work1ds(1:arrsz)=>works + call mp_alltoall(work1ds, sendcounts, sdispls, & + work1dr,recvcounts,sdispls) + nullify(work1dr) + nullify(work1ds) +!$omp parallel do private(j,lat,lmax,nvar,lval,nv) + do j=1,lats_node + lmax = min(jcap,lonf/2) + n2 = lmax + lmax + 3 + if ( n2 <= lonf+2 ) then + do nv=1,nvars + do lval = n2, lonf+2 + four_gr(lval,nv,j) = cons0 + enddo + enddo + endif + enddo +! + kptr = 0 +!! +!$omp parallel do private(node,l,lval,j,lat,nvar,kn,n2) + do node=1,npes + do l=1,max_ls_nodes(node) + lval = ls_nodes(l,node)+1 + n2 = lval + lval + do j=1,lats_node + lat = global_lats(ipt_lats_node-1+j) + if ( min(lat,latg-lat+1) >= lat1s_a(lval-1) ) then + kptr(node) = kptr(node) + 1 + kn = kptr(node) + do nv=1,nvars + four_gr(n2-1,nv,j) = workr(1,nv,kn,node) + four_gr(n2, nv,j) = workr(2,nv,kn,node) + enddo + endif + enddo + enddo + enddo +! + return + end subroutine spec_to_four + +!>@brief The subroutine 'four_to_grid' calculate real values form fourrier coefficients +!>@details This code is taken from the legacy spectral GFS + subroutine four_to_grid(syn_gr_a_1,syn_gr_a_2, lon_dim_coef,nvars) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + implicit none +!! + integer, intent(in) :: nvars + real(kind=kind_dbl_prec) syn_gr_a_1(lon_dim_coef,nvars) + real(kind=kind_dbl_prec) syn_gr_a_2(lonf,nvars) + integer lon_dim_coef +!________________________________________________________ + real(kind=kind_dbl_prec) aux1crs(44002) + integer init +!________________________________________________________ + + + init = 1 + + call dcrft_stochy(init, & + syn_gr_a_1(:,:) ,lon_dim_coef, & + syn_gr_a_2(:,:) ,lonf, & + lonf, nvars, & + aux1crs,22000, & + aux1crs(22001),20000) + + init = 0 + call dcrft_stochy(init, & + syn_gr_a_1(:,:) ,lon_dim_coef, & + syn_gr_a_2(:,:) ,lonf, & + lonf, nvars, & + aux1crs,22000, & + aux1crs(22001),20000) + + return + end + + + SUBROUTINE dcrft_stochy(init,x,ldx,y,ldy,n,nvars, table,n1,wrk,n2) + + implicit none + integer ,intent(in) :: ldx,ldy,n,nvars + integer init,n1,n2,i,j + real x(ldx,nvars),y(ldy,nvars),table(44002),wrk + + IF (init.ne.0) THEN + CALL rffti_stochy(n,table) + ELSE + DO j=1,nvars + y(1,j)=x(1,j) + DO i=2,n + y(i,j)=x(i+1,j) + ENDDO + CALL rfftb_stochy(n,y(:,j),table) + ENDDO + ENDIF + + RETURN + END + +! ****************************************************************** +! ****************************************************************** +! ****** ****** +! ****** FFTPACK ****** +! ****** ****** +! ****************************************************************** +! ****************************************************************** +! + SUBROUTINE RFFTB_STOCHY (N,R,WSAVE) + + implicit none + + real, intent(inout) :: R(:) + real, intent(inout) :: WSAVE(44002) + + integer :: N + + IF (N .EQ. 1) RETURN + CALL RFFTB1_STOCHY (N,R,WSAVE,WSAVE(N+1:),WSAVE(2*N+1:)) + RETURN + END + + SUBROUTINE RFFTI_STOCHY (N,WSAVE) + + implicit none + + REAL, intent(inout) :: WSAVE(44002) + integer :: N + + IF (N .EQ. 1) RETURN + CALL RFFTI1_STOCHY (N,WSAVE(N+1:),WSAVE(2*N+1:)) + RETURN + END + + + SUBROUTINE RFFTB1_STOCHY (N,C,CH,WA,RFAC) + + implicit none + + integer, intent(in) :: N + real, intent(inout) :: CH(44002) + real, intent(inout) :: C(:) + real, intent(inout) :: WA(:) + real, intent(inout) :: RFAC(:) + + integer :: NF,NA,L1,IW,IP,L2,IDO,IDL1,IX2,IX3,IX4 + integer :: K1,I + + NF = INT(RFAC(2)) + NA = 0 + L1 = 1 + IW = 1 + DO 116 K1=1,NF + IP = INT(RFAC(K1+2)) + L2 = IP*L1 + IDO = N/L2 + IDL1 = IDO*L1 + IF (IP .NE. 4) GO TO 103 + IX2 = IW+IDO + IX3 = IX2+IDO + IF (NA .NE. 0) GO TO 101 + CALL RADB4_STOCHY (IDO,L1,C(1:4*IDO*L1),CH(1:4*IDO*L1),WA(IW:),WA(IX2:),WA(IX3:)) + GO TO 102 + 101 CALL RADB4_STOCHY (IDO,L1,CH(1:4*IDO*L1),C(1:4*IDO*L1),WA(IW:),WA(IX2:),WA(IX3:)) + 102 NA = 1-NA + GO TO 115 + 103 IF (IP .NE. 2) GO TO 106 + IF (NA .NE. 0) GO TO 104 + CALL RADB2_STOCHY (IDO,L1,C,CH,WA(IW:)) + GO TO 105 + 104 CALL RADB2_STOCHY (IDO,L1,CH,C,WA(IW:)) + 105 NA = 1-NA + GO TO 115 + 106 IF (IP .NE. 3) GO TO 109 + IX2 = IW+IDO + IF (NA .NE. 0) GO TO 107 + CALL RADB3_STOCHY (IDO,L1,C,CH,WA(IW:),WA(IX2:)) + GO TO 108 + 107 CALL RADB3_STOCHY (IDO,L1,CH,C,WA(IW:),WA(IX2:)) + 108 NA = 1-NA + GO TO 115 + 109 IF (IP .NE. 5) GO TO 112 + IX2 = IW+IDO + IX3 = IX2+IDO + IX4 = IX3+IDO + IF (NA .NE. 0) GO TO 110 + CALL RADB5_STOCHY (IDO,L1,C,CH,WA(IW:),WA(IX2:),WA(IX3:),WA(IX4:)) + GO TO 111 + 110 CALL RADB5_STOCHY (IDO,L1,CH,C,WA(IW:),WA(IX2:),WA(IX3:),WA(IX4:)) + 111 NA = 1-NA + GO TO 115 + 112 IF (NA .NE. 0) GO TO 113 + CALL RADBG_STOCHY (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW:)) + GO TO 114 + 113 CALL RADBG_STOCHY (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW:)) + 114 IF (IDO .EQ. 1) NA = 1-NA + 115 L1 = L2 + IW = IW+(IP-1)*IDO + 116 CONTINUE + IF (NA .EQ. 0) RETURN + DO 117 I=1,N + C(I) = CH(I) + 117 CONTINUE + RETURN + END + + + SUBROUTINE RFFTI1_STOCHY (N,WA,RFAC) + + implicit none + + integer, intent(in) :: N + REAL, intent(inout) :: WA(:) + REAL, intent(inout) :: RFAC(:) + + integer :: NTRYH(4) + integer :: NL,NF, I, J, NQ,NR,LD,FI,IS,ID,L1,L2,IP + integer :: NTRY, NFM1, K1,II, IB, IDO, IPM, IC + REAL, parameter :: TPI=6.28318530717959 + real :: ARG,ARGLD,ARGH, TI2,TI4 + + DATA NTRYH(:) /4,2,3,5/ + + + NL = N + NF = 0 + J = 0 + 101 J = J+1 + IF ( (J-4) .LE. 0) THEN + GOTO 102 + ELSE + GOTO 103 + ENDIF + 102 NTRY = NTRYH(J) + GO TO 104 + 103 NTRY = NTRY+2 + 104 NQ = NL/NTRY + NR = NL-NTRY*NQ + IF (NR.EQ.0) THEN + GO TO 105 + ELSE + GO TO 101 + ENDIF + 105 NF = NF+1 + RFAC(NF+2) = FLOAT(NTRY) + NL = NQ + IF (NTRY .NE. 2) GO TO 107 + IF (NF .EQ. 1) GO TO 107 + DO 106 I=2,NF + IB = NF-I+2 + RFAC(IB+2) = RFAC(IB+1) + 106 CONTINUE + RFAC(3) = 2. + 107 IF (NL .NE. 1) GO TO 104 + RFAC(1) = FLOAT(N) + RFAC(2) = FLOAT(NF) + ARGH = TPI/FLOAT(N) + IS = 0 + NFM1 = NF-1 + L1 = 1 + IF (NFM1 .EQ. 0) RETURN +!OCL NOVREC + DO 110 K1=1,NFM1 + IP = INT(RFAC(K1+2)) + LD = 0 + L2 = L1*IP + IDO = N/L2 + IPM = IP-1 + DO 109 J=1,IPM + LD = LD+L1 + I = IS + ARGLD = FLOAT(LD)*ARGH + FI = 0 +!OCL SCALAR + DO 108 II=3,IDO,2 + I = I+2 + FI = FI+1 + ARG = FI*ARGLD + WA(I-1) = COS(ARG) + WA(I) = SIN(ARG) + 108 CONTINUE + IS = IS+IDO + 109 CONTINUE + L1 = L2 + 110 CONTINUE + RETURN + END + + + SUBROUTINE RADB2_STOCHY (IDO,L1,CC,CH,WA1) + + implicit none + + integer, intent(in) :: IDO + integer, intent(in) :: L1 + real, intent(inout) :: CC(IDO,2,L1) + real, intent(inout) :: CH(IDO,L1,2) + real, intent(inout) :: WA1(:) + + integer :: K,I,IC,IDP2 + real :: TR2,TI2 + DO 101 K=1,L1 + CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) + CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) + 101 CONTINUE + IF ( (IDO-2) .LT. 0) THEN + GO TO 107 + ELSE IF (( IDO-2).EQ. 0)THEN + GO TO 105 + ELSE + GO TO 102 + ENDIF + 102 IDP2 = IDO+2 +!OCL NOVREC + DO 104 K=1,L1 + DO 103 I=3,IDO,2 + IC = IDP2-I + CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) + TR2 = CC(I-1,1,K)-CC(IC-1,2,K) + CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) + TI2 = CC(I,1,K)+CC(IC,2,K) + CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 + CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 + 103 CONTINUE + 104 CONTINUE + IF (MOD(IDO,2) .EQ. 1) RETURN + 105 DO 106 K=1,L1 + CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) + CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) + 106 CONTINUE + 107 RETURN + END + + + SUBROUTINE RADB3_STOCHY (IDO,L1,CC,CH,WA1,WA2) + + implicit none + + integer, intent(in) :: IDO,L1 + real, intent(inout) :: CC(IDO,3,L1) + real, intent(inout) :: CH(IDO,L1,3) + real, intent(inout) :: WA1(:) + real, intent(inout) :: WA2(:) + + REAL, parameter :: TAUR= -.5 + REAL, parameter :: TAUI=.866025403784439 + integer :: I,K,IDP2,IC + real :: TR2,CR2,TI1,CI2,CR3,CI3,DR2,DR3,DI2,DI3 + real :: TI2,TI4 + + + DO 101 K=1,L1 + TR2 = CC(IDO,2,K)+CC(IDO,2,K) + CR2 = CC(1,1,K)+TAUR*TR2 + CH(1,K,1) = CC(1,1,K)+TR2 + CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) + CH(1,K,2) = CR2-CI3 + CH(1,K,3) = CR2+CI3 + 101 CONTINUE + IF (IDO .EQ. 1) RETURN + IDP2 = IDO+2 +!OCL NOVREC + DO 103 K=1,L1 + DO 102 I=3,IDO,2 + IC = IDP2-I + TR2 = CC(I-1,3,K)+CC(IC-1,2,K) + CR2 = CC(I-1,1,K)+TAUR*TR2 + CH(I-1,K,1) = CC(I-1,1,K)+TR2 + TI2 = CC(I,3,K)-CC(IC,2,K) + CI2 = CC(I,1,K)+TAUR*TI2 + CH(I,K,1) = CC(I,1,K)+TI2 + CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) + CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) + DR2 = CR2-CI3 + DR3 = CR2+CI3 + DI2 = CI2+CR3 + DI3 = CI2-CR3 + CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 + CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 + CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 + CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 + 102 CONTINUE + 103 CONTINUE + RETURN + END + + + SUBROUTINE RADB4_STOCHY (IDO,L1,CC,CH,WA1,WA2,WA3) + + implicit none + + integer, intent(in) :: IDO,L1 + real, intent(inout) :: CC(IDO,4,L1) + real, intent(inout) :: CH(IDO,L1,4) + real, intent(inout) :: WA1(:) + real, intent(inout) :: WA2(:) + real, intent(inout) :: WA3(:) + + REAL, parameter :: SQRT2=1.414213562373095 + integer :: I,K,IDP2,IC + real :: TR1,TR2,TR3,TR4,TI1,TI2,TI3,TI4 + real :: CI2,CI3,CI4,CR2,CR3,CR4 + DO 101 K=1,L1 + TR1 = CC(1,1,K)-CC(IDO,4,K) + TR2 = CC(1,1,K)+CC(IDO,4,K) + TR3 = CC(IDO,2,K)+CC(IDO,2,K) + TR4 = CC(1,3,K)+CC(1,3,K) + CH(1,K,1) = TR2+TR3 + CH(1,K,2) = TR1-TR4 + CH(1,K,3) = TR2-TR3 + CH(1,K,4) = TR1+TR4 + 101 CONTINUE + IF ( (IDO-2) .LT.0 ) THEN + GO TO 107 + ELSE IF ( (IDO-2) .EQ.0 ) THEN + GO TO 105 + ELSE + GO TO 102 + ENDIF + 102 IDP2 = IDO+2 +!OCL NOVREC + DO 104 K=1,L1 + DO 103 I=3,IDO,2 + IC = IDP2-I + TI1 = CC(I,1,K)+CC(IC,4,K) + TI2 = CC(I,1,K)-CC(IC,4,K) + TI3 = CC(I,3,K)-CC(IC,2,K) + TR4 = CC(I,3,K)+CC(IC,2,K) + TR1 = CC(I-1,1,K)-CC(IC-1,4,K) + TR2 = CC(I-1,1,K)+CC(IC-1,4,K) + TI4 = CC(I-1,3,K)-CC(IC-1,2,K) + TR3 = CC(I-1,3,K)+CC(IC-1,2,K) + CH(I-1,K,1) = TR2+TR3 + CR3 = TR2-TR3 + CH(I,K,1) = TI2+TI3 + CI3 = TI2-TI3 + CR2 = TR1-TR4 + CR4 = TR1+TR4 + CI2 = TI1+TI4 + CI4 = TI1-TI4 + CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 + CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 + CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 + CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 + CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 + CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 + 103 CONTINUE + 104 CONTINUE + IF (MOD(IDO,2) .EQ. 1) RETURN + 105 CONTINUE + DO 106 K=1,L1 + TI1 = CC(1,2,K)+CC(1,4,K) + TI2 = CC(1,4,K)-CC(1,2,K) + TR1 = CC(IDO,1,K)-CC(IDO,3,K) + TR2 = CC(IDO,1,K)+CC(IDO,3,K) + CH(IDO,K,1) = TR2+TR2 + CH(IDO,K,2) = SQRT2*(TR1-TI1) + CH(IDO,K,3) = TI2+TI2 + CH(IDO,K,4) = -SQRT2*(TR1+TI1) + 106 CONTINUE + 107 RETURN + END + + + SUBROUTINE RADB5_STOCHY (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) + DIMENSION CC(IDO,5,L1), CH(IDO,L1,5), WA1(*), WA2(*), WA3(*), WA4(*) + REAL, parameter :: TR11=0.309016994374947 + REAL, parameter :: TI11= 0.951056516295154 + REAL, parameter :: TR12=-0.809016994374947 + REAL, parameter :: TI12=0.587785252292473 + DO 101 K=1,L1 + TI5 = CC(1,3,K)+CC(1,3,K) + TI4 = CC(1,5,K)+CC(1,5,K) + TR2 = CC(IDO,2,K)+CC(IDO,2,K) + TR3 = CC(IDO,4,K)+CC(IDO,4,K) + CH(1,K,1) = CC(1,1,K)+TR2+TR3 + CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 + CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 + CI5 = TI11*TI5+TI12*TI4 + CI4 = TI12*TI5-TI11*TI4 + CH(1,K,2) = CR2-CI5 + CH(1,K,3) = CR3-CI4 + CH(1,K,4) = CR3+CI4 + CH(1,K,5) = CR2+CI5 + 101 CONTINUE + IF (IDO .EQ. 1) RETURN + IDP2 = IDO+2 + DO 103 K=1,L1 + DO 102 I=3,IDO,2 + IC = IDP2-I + TI5 = CC(I,3,K)+CC(IC,2,K) + TI2 = CC(I,3,K)-CC(IC,2,K) + TI4 = CC(I,5,K)+CC(IC,4,K) + TI3 = CC(I,5,K)-CC(IC,4,K) + TR5 = CC(I-1,3,K)-CC(IC-1,2,K) + TR2 = CC(I-1,3,K)+CC(IC-1,2,K) + TR4 = CC(I-1,5,K)-CC(IC-1,4,K) + TR3 = CC(I-1,5,K)+CC(IC-1,4,K) + CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 + CH(I,K,1) = CC(I,1,K)+TI2+TI3 + CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 + CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 + CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 + CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 + CR5 = TI11*TR5+TI12*TR4 + CI5 = TI11*TI5+TI12*TI4 + CR4 = TI12*TR5-TI11*TR4 + CI4 = TI12*TI5-TI11*TI4 + DR3 = CR3-CI4 + DR4 = CR3+CI4 + DI3 = CI3+CR4 + DI4 = CI3-CR4 + DR5 = CR2+CI5 + DR2 = CR2-CI5 + DI5 = CI2-CR5 + DI2 = CI2+CR5 + CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 + CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 + CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 + CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 + CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 + CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 + CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 + CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 + 102 CONTINUE + 103 CONTINUE + RETURN + END + + + SUBROUTINE RADBG_STOCHY (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) + DIMENSION CH(IDO,L1,IP), CC(IDO,IP,L1), C1(IDO,L1,IP), C2(IDL1,IP), & + CH2(IDL1,IP) , WA(*) + REAL, parameter :: TPI=6.28318530717959 + ARG = TPI/FLOAT(IP) + DCP = COS(ARG) + DSP = SIN(ARG) + IDP2 = IDO+2 + NBD = (IDO-1)/2 + IPP2 = IP+2 + IPPH = (IP+1)/2 + IF (IDO .LT. L1) GO TO 103 + DO K=1,L1 + DO I=1,IDO + CH(I,K,1) = CC(I,1,K) + ENDDO + ENDDO + GO TO 106 + 103 DO 105 I=1,IDO + DO 104 K=1,L1 + CH(I,K,1) = CC(I,1,K) + 104 CONTINUE + 105 CONTINUE +!OCL NOVREC + 106 DO 108 J=2,IPPH + JC = IPP2-J + J2 = J+J + DO 107 K=1,L1 + CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) + CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) + 107 CONTINUE + 108 CONTINUE + IF (IDO .EQ. 1) GO TO 116 + IF (NBD .LT. L1) GO TO 112 +!OCL NOVREC + DO 111 J=2,IPPH + JC = IPP2-J + DO 110 K=1,L1 + DO 109 I=3,IDO,2 + IC = IDP2-I + CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) + CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) + CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) + CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) + 109 CONTINUE + 110 CONTINUE + 111 CONTINUE + GO TO 116 + 112 DO 115 J=2,IPPH + JC = IPP2-J + DO 114 I=3,IDO,2 + IC = IDP2-I + DO 113 K=1,L1 + CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) + CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) + CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) + CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) + 113 CONTINUE + 114 CONTINUE + 115 CONTINUE + 116 AR1 = 1. + AI1 = 0. +!OCL NOVREC + DO 120 L=2,IPPH + LC = IPP2-L + AR1H = DCP*AR1-DSP*AI1 + AI1 = DCP*AI1+DSP*AR1 + AR1 = AR1H + DO 117 IK=1,IDL1 + C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) + C2(IK,LC) = AI1*CH2(IK,IP) + 117 CONTINUE + DC2 = AR1 + DS2 = AI1 + AR2 = AR1 + AI2 = AI1 +!OCL NOVREC + DO 119 J=3,IPPH + JC = IPP2-J + AR2H = DC2*AR2-DS2*AI2 + AI2 = DC2*AI2+DS2*AR2 + AR2 = AR2H + DO 118 IK=1,IDL1 + C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J) + C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) + 118 CONTINUE + 119 CONTINUE + 120 CONTINUE +!OCL NOVREC + DO 122 J=2,IPPH + DO 121 IK=1,IDL1 + CH2(IK,1) = CH2(IK,1)+CH2(IK,J) + 121 CONTINUE + 122 CONTINUE +!OCL NOVREC + DO 124 J=2,IPPH + JC = IPP2-J + DO 123 K=1,L1 + CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) + CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) + 123 CONTINUE + 124 CONTINUE + IF (IDO .EQ. 1) GO TO 132 + IF (NBD .LT. L1) GO TO 128 +!OCL NOVREC + DO 127 J=2,IPPH + JC = IPP2-J + DO 126 K=1,L1 + DO 125 I=3,IDO,2 + CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) + CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) + CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) + CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) + 125 CONTINUE + 126 CONTINUE + 127 CONTINUE + GO TO 132 + 128 DO 131 J=2,IPPH + JC = IPP2-J + DO 130 I=3,IDO,2 + DO 129 K=1,L1 + CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) + CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) + CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) + CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) + 129 CONTINUE + 130 CONTINUE + 131 CONTINUE + 132 CONTINUE + IF (IDO .EQ. 1) RETURN + DO 133 IK=1,IDL1 + C2(IK,1) = CH2(IK,1) + 133 CONTINUE + DO 135 J=2,IP + DO 134 K=1,L1 + C1(1,K,J) = CH(1,K,J) + 134 CONTINUE + 135 CONTINUE + IF (NBD .GT. L1) GO TO 139 + IS = -IDO + DO 138 J=2,IP + IS = IS+IDO + IDIJ = IS + DO 137 I=3,IDO,2 + IDIJ = IDIJ+2 + DO 136 K=1,L1 + C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) + C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) + 136 CONTINUE + 137 CONTINUE + 138 CONTINUE + GO TO 143 + 139 IS = -IDO +!OCL NOVREC + DO 142 J=2,IP + IS = IS+IDO + DO 141 K=1,L1 + IDIJ = IS + DO 140 I=3,IDO,2 + IDIJ = IDIJ+2 + C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) + C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE + 143 RETURN + END + + +!>@brief The subroutine 'dozeuv_stochy' caculates odd u and even v winds harmonics from the odd harmonics +! of divergence and even harmonics of vorticty +!>@details This code is taken from the legacy spectral GFS + subroutine dozeuv_stochy(dod,zev,uod,vev,epsedn,epsodn, snnp1ev,snnp1od,ls_node) + + + implicit none + real(kind_dbl_prec), intent(in) :: dod(len_trio_ls,2) + real(kind_dbl_prec), intent(in) :: zev(len_trie_ls,2) + real(kind_dbl_prec), intent(out) :: uod(len_trio_ls,2) + real(kind_dbl_prec), intent(out) :: vev(len_trie_ls,2) + real(kind_dbl_prec), intent(in) :: epsedn(len_trie_ls) + real(kind_dbl_prec), intent(in) :: epsodn(len_trio_ls) + real(kind_dbl_prec), intent(in) :: snnp1ev(len_trie_ls) + real(kind_dbl_prec), intent(in) :: snnp1od(len_trio_ls) + integer, intent(in) :: ls_node(ls_dim,3) +!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L +!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev +!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod +! locaals + integer l,locl,n + integer indev,indev1,indev2 + integer indod,indod1,indod2 + integer inddif + real(kind_dbl_prec) rl + real(kind_dbl_prec) cons0 !constant + integer indlsev,jbasev + integer indlsod,jbasod + real(kind_evod) rerth + + include 'function2' + + +!...................................................................... + cons0 = 0.d0 !constant + rerth =6.3712e+6 ! radius of earth (m) + + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + vev(indlsev(l,l),1) = cons0 !constant + vev(indlsev(l,l),2) = cons0 !constant + enddo +!...................................................................... + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + jbasod=ls_node(locl,3) + indev1 = indlsev(L,L) + if (mod(L,2).eq.mod(jcap+1,2)) then + indev2 = indlsev(jcap-1,L) + else + indev2 = indlsev(jcap ,L) + endif + indod1 = indlsod(l+1,l) + inddif = indev1 - indod1 + do indev = indev1 , indev2 + uod(indev-inddif,1) = -epsodn(indev-inddif) * zev(indev,1) + uod(indev-inddif,2) = -epsodn(indev-inddif) * zev(indev,2) + enddo + enddo +!...................................................................... + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + jbasod=ls_node(locl,3) + indev1 = indlsev(L,L) + 1 + if (mod(L,2).eq.mod(jcap+1,2)) then + indev2 = indlsev(jcap+1,L) + else + indev2 = indlsev(jcap ,L) + endif + indod1 = indlsod(l+1,l) + inddif = indev1 - indod1 + do indev = indev1 , indev2 + vev(indev,1) = epsedn(indev) * dod(indev-inddif,1) + vev(indev,2) = epsedn(indev) * dod(indev-inddif,2) + enddo + enddo + +!...................................................................... + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasod=ls_node(locl,3) + indod1 = indlsod(L+1,L) + if (mod(L,2).eq.mod(jcap+1,2)) then + indod2 = indlsod(jcap ,L) + else + indod2 = indlsod(jcap+1,L) - 1 + endif + if ( l .ge. 1 ) then + rl = l + do indod = indod1 , indod2 +! u(l,n)=-i*l*d(l,n)/(n*(n+1)) + uod(indod,1) = uod(indod,1) + rl * dod(indod,2) / snnp1od(indod) + uod(indod,2) = uod(indod,2) - rl * dod(indod,1) / snnp1od(indod) + enddo + endif + enddo +!...................................................................... + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + indev1 = indlsev(L,L) + if (mod(L,2).eq.mod(jcap+1,2)) then + indev2 = indlsev(jcap-1,L) + else + indev2 = indlsev(jcap ,L) + endif + if ( l .ge. 1 ) then + rl = l + do indev = indev1 , indev2 +! u(l,n)=-i*l*d(l,n)/(n*(n+1)) + vev(indev,1) = vev(indev,1) + rl * zev(indev,2) / snnp1ev(indev) + vev(indev,2) = vev(indev,2) - rl * zev(indev,1) / snnp1ev(indev) + enddo + endif + enddo +!...................................................................... + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + jbasod=ls_node(locl,3) + indev1 = indlsev(L,L) + 1 + if (mod(L,2).eq.mod(jcap+1,2)) then + indev2 = indlsev(jcap-1,L) + else + indev2 = indlsev(jcap ,L) + endif + indod1 = indlsod(l+1,l) + inddif = indev1 - indod1 + do indev = indev1 , indev2 + uod(indev-inddif,1) = uod(indev-inddif,1) + epsedn(indev) * zev(indev,1) + uod(indev-inddif,2) = uod(indev-inddif,2) + epsedn(indev) * zev(indev,2) + enddo + enddo +!...................................................................... + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + jbasod=ls_node(locl,3) + indev1 = indlsev(L,L) + if (mod(L,2).eq.mod(jcap+1,2)) then + indev2 = indlsev(jcap+1,L) - 1 + else + indev2 = indlsev(jcap ,L) - 1 + endif + indod1 = indlsod(l+1,l) + inddif = indev1 - indod1 + do indev = indev1 , indev2 + vev(indev,1) = vev(indev,1) - epsodn(indev-inddif) * dod(indev-inddif,1) + vev(indev,2) = vev(indev,2) - epsodn(indev-inddif) * dod(indev-inddif,2) + enddo + enddo +!...................................................................... + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + jbasod=ls_node(locl,3) + indev1 = indlsev(L,L) + indod1 = indlsod(L+1,L) + if (mod(L,2).eq.mod(jcap+1,2)) then + indev2 = indlsev(jcap+1,L) + indod2 = indlsod(jcap ,L) + else + indev2 = indlsev(jcap ,L) + indod2 = indlsod(jcap+1,L) + endif + do indod = indod1 , indod2 + uod(indod,1) = uod(indod,1) * rerth + uod(indod,2) = uod(indod,2) * rerth + enddo + do indev = indev1 , indev2 + vev(indev,1) = vev(indev,1) * rerth + vev(indev,2) = vev(indev,2) * rerth + enddo + enddo + return + end + +!>@brief The subroutine 'dezouv_stochy' caculates even u and odd v winds harmonics from the even harmonics +! of divergence and odd harmonics of vorticty +!>@details This code is taken from the legacy spectral GFS + subroutine dezouv_stochy(dev,zod,uev,vod,epsedn,epsodn,snnp1ev,snnp1od,ls_node) + + + implicit none + + real(kind_dbl_prec), intent(in) :: dev(len_trie_ls,2) + real(kind_dbl_prec), intent(in) :: zod(len_trio_ls,2) + real(kind_dbl_prec), intent(out) :: uev(len_trie_ls,2) + real(kind_dbl_prec), intent(out) :: vod(len_trio_ls,2) + real(kind_dbl_prec), intent(in) :: epsedn(len_trie_ls) + real(kind_dbl_prec), intent(in) :: epsodn(len_trio_ls) + real(kind_dbl_prec), intent(in) :: snnp1ev(len_trie_ls) + real(kind_dbl_prec), intent(in) :: snnp1od(len_trio_ls) + integer, intent(in) :: ls_node(ls_dim,3) + +!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L +!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev +!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod + + integer l,locl,n + integer indev,indev1,indev2 + integer indod,indod1,indod2 + integer inddif + + real(kind_dbl_prec) rl + real(kind_dbl_prec) cons0 !constant + + integer indlsev,jbasev + integer indlsod,jbasod + real(kind_evod) rerth + + include 'function2' +!...................................................................... + cons0 = 0.d0 !constant + rerth =6.3712e+6 ! radius of earth (m) + + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + uev(indlsev(l,l),1) = cons0 !constant + uev(indlsev(l,l),2) = cons0 !constant + enddo + +!...................................................................... + + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + jbasod=ls_node(locl,3) + indev1 = indlsev(L,L) + 1 + if (mod(L,2).eq.mod(jcap+1,2)) then + indev2 = indlsev(jcap+1,L) + else + indev2 = indlsev(jcap ,L) + endif + indod1 = indlsod(l+1,l) + inddif = indev1 - indod1 + do indev = indev1 , indev2 + uev(indev,1) = -epsedn(indev) * zod(indev-inddif,1) + uev(indev,2) = -epsedn(indev) * zod(indev-inddif,2) + enddo + enddo + + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + jbasod=ls_node(locl,3) + indev1 = indlsev(L,L) + if (mod(L,2).eq.mod(jcap+1,2)) then + indev2 = indlsev(jcap-1,L) + else + indev2 = indlsev(jcap ,L) + endif + indod1 = indlsod(l+1,l) + inddif = indev1 - indod1 + + do indev = indev1 , indev2 + vod(indev-inddif,1) = epsodn(indev-inddif) * dev(indev,1) + vod(indev-inddif,2) = epsodn(indev-inddif) * dev(indev,2) + enddo + enddo + +!...................................................................... + + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + indev1 = indlsev(L,L) + if (mod(L,2).eq.mod(jcap+1,2)) then + indev2 = indlsev(jcap-1,L) + else + indev2 = indlsev(jcap ,L) + endif + if ( l .ge. 1 ) then + rl = l + do indev = indev1 , indev2 + uev(indev,1) = uev(indev,1) + rl * dev(indev,2) / snnp1ev(indev) + uev(indev,2) = uev(indev,2) - rl * dev(indev,1) / snnp1ev(indev) + enddo + endif + enddo + +!...................................................................... + + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasod=ls_node(locl,3) + indod1 = indlsod(L+1,L) + if (mod(L,2).eq.mod(jcap+1,2)) then + indod2 = indlsod(jcap ,L) + else + indod2 = indlsod(jcap+1,L) - 1 + endif + if ( l .ge. 1 ) then + rl = l + do indod = indod1 , indod2 + vod(indod,1) = vod(indod,1) + rl * zod(indod,2) / snnp1od(indod) + vod(indod,2) = vod(indod,2) - rl * zod(indod,1) / snnp1od(indod) + enddo + endif + enddo + +!...................................................................... + + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + jbasod=ls_node(locl,3) + indev1 = indlsev(L,L) + if (mod(L,2).eq.mod(jcap+1,2)) then + indev2 = indlsev(jcap+1,L) - 1 + else + indev2 = indlsev(jcap ,L) - 1 + endif + indod1 = indlsod(l+1,l) + inddif = indev1 - indod1 + + do indev = indev1 , indev2 + uev(indev,1) = uev(indev, 1) + epsodn(indev-inddif) * zod(indev-inddif,1) + uev(indev,2) = uev(indev, 2) + epsodn(indev-inddif) * zod(indev-inddif,2) + enddo + enddo +!...................................................................... + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + jbasod=ls_node(locl,3) + indev1 = indlsev(L,L) + 1 + if (mod(L,2).eq.mod(jcap+1,2)) then + indev2 = indlsev(jcap-1,L) + else + indev2 = indlsev(jcap ,L) + endif + indod1 = indlsod(l+1,l) + inddif = indev1 - indod1 + do indev = indev1 , indev2 + vod(indev-inddif,1) = vod(indev-inddif,1) - epsedn(indev) * dev(indev, 1) + vod(indev-inddif,2) = vod(indev-inddif,2) - epsedn(indev) * dev(indev, 2) + enddo + enddo +!...................................................................... + do locl=1,ls_max_node + l=ls_node(locl,1) + jbasev=ls_node(locl,2) + jbasod=ls_node(locl,3) + indev1 = indlsev(L,L) + indod1 = indlsod(L+1,L) + if (mod(L,2).eq.mod(jcap+1,2)) then + indev2 = indlsev(jcap+1,L) + indod2 = indlsod(jcap ,L) + else + indev2 = indlsev(jcap ,L) + indod2 = indlsod(jcap+1,L) + endif + do indev = indev1 , indev2 + uev(indev,1) = uev(indev,1) * rerth + uev(indev,2) = uev(indev,2) * rerth + enddo + + do indod = indod1 , indod2 + vod(indod,1) = vod(indod,1) * rerth + vod(indod,2) = vod(indod,2) * rerth + enddo + enddo + + return + end + + ! interpolation from lat/lon or gaussian grid to other lat/lon grid + ! +!>@brief The subroutine 'stochy_la2ga' intepolates from the global gaussian grid +!! to the cubed sphere points +!>@details This code is taken from the legacy spectral GFS + subroutine stochy_la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat, & + gauout,len,outlat, outlon) + implicit none + ! interface variables + real (kind=kind_io8), intent(in) :: regin(imxin,jmxin) + integer, intent(in) :: imxin + integer, intent(in) :: jmxin + real (kind=kind_io8), intent(in) :: rinlon(imxin) + real (kind=kind_io8), intent(in) :: rinlat(jmxin) + real (kind=kind_io8), intent(in) :: rlon + real (kind=kind_io8), intent(in) :: rlat + real (kind=kind_io8), intent(out) :: gauout(len) + integer, intent(in) :: len + real (kind=kind_io8), intent(in) :: outlat(len) + real (kind=kind_io8), intent(in) :: outlon(len) + ! local variables + real (kind=kind_io8) :: sum2,sum1,sum3,sum4 + real (kind=kind_io8) :: wsum,wsumiv,sums,sumn,wi2j2,x,y,wi1j1 + real (kind=kind_io8) :: wi1j2,wi2j1,aphi,rnume,alamd,denom + integer :: i,j,jq,jx + integer :: j1,j2,ii,i1,i2 + integer :: iindx1(len) + integer :: iindx2(len) + integer :: jindx1(len) + integer :: jindx2(len) + real(kind=kind_io8) :: ddx(len) + real(kind=kind_io8) :: ddy(len) + real(kind=kind_io8) :: wrk(len) +! +! +! find i-index for interpolation + do i=1,len + alamd = outlon(i) + if (alamd .lt. rlon) alamd = alamd + 360.0 + if (alamd .gt. 360.0+rlon) alamd = alamd - 360.0 + wrk(i) = alamd + iindx1(i) = imxin + enddo + do i=1,len + do ii=1,imxin + if(wrk(i) .ge. rinlon(ii)) iindx1(i) = ii + enddo + enddo + do i=1,len + i1 = iindx1(i) + if (i1 .lt. 1) i1 = imxin + i2 = i1 + 1 + if (i2 .gt. imxin) i2 = 1 + iindx1(i) = i1 + iindx2(i) = i2 + denom = rinlon(i2) - rinlon(i1) + if(denom.lt.0.) denom = denom + 360. + rnume = wrk(i) - rinlon(i1) + if(rnume.lt.0.) rnume = rnume + 360. + ddx(i) = rnume / denom + enddo +! +! find j-index for interplation +! + if(rlat.gt.0.) then + do j=1,len + jindx1(j)=0 + enddo + do jx=1,jmxin + do j=1,len + if(outlat(j).le.rinlat(jx)) jindx1(j) = jx + enddo + enddo + do j=1,len + jq = jindx1(j) + aphi=outlat(j) + if(jq.ge.1 .and. jq .lt. jmxin) then + j2=jq+1 + j1=jq + ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1)) + elseif (jq .eq. 0) then + j2=1 + j1=1 + if(abs(90.-rinlat(j1)).gt.0.001) then + ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1)) + else + ddy(j)=0.0 + endif + else + j2=jmxin + j1=jmxin + if(abs(-90.-rinlat(j1)).gt.0.001) then + ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1)) + else + ddy(j)=0.0 + endif + endif + jindx1(j)=j1 + jindx2(j)=j2 + enddo + else + do j=1,len + jindx1(j) = jmxin+1 + enddo + do jx=jmxin,1,-1 + do j=1,len + if(outlat(j).le.rinlat(jx)) jindx1(j) = jx + enddo + enddo + do j=1,len + jq = jindx1(j) + aphi=outlat(j) + if(jq.gt.1 .and. jq .le. jmxin) then + j2=jq + j1=jq-1 + ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1)) + elseif (jq .eq. 1) then + j2=1 + j1=1 + if(abs(-90.-rinlat(j1)).gt.0.001) then + ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1)) + else + ddy(j)=0.0 + endif + else + j2=jmxin + j1=jmxin + if(abs(90.-rinlat(j1)).gt.0.001) then + ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1)) + else + ddy(j)=0.0 + endif + endif + jindx1(j)=j1 + jindx2(j)=j2 + enddo + endif +! + sum1 = 0. + sum2 = 0. + sum3 = 0. + sum4 = 0. + do i=1,imxin + sum1 = sum1 + regin(i,1) + sum2 = sum2 + regin(i,jmxin) + enddo + sum1 = sum1 / imxin + sum2 = sum2 / imxin + sum3 = sum1 + sum4 = sum2 +! +! quasi-bilinear interpolation +! + do i=1,len + y = ddy(i) + j1 = jindx1(i) + j2 = jindx2(i) + x = ddx(i) + i1 = iindx1(i) + i2 = iindx2(i) +! + wi1j1 = (1.-x) * (1.-y) + wi2j1 = x *( 1.-y) + wi1j2 = (1.-x) * y + wi2j2 = x * y +! + wsum = wi1j1 + wi2j1 + wi1j2 + wi2j2 + wrk(i) = wsum + if(wsum.ne.0.) then + wsumiv = 1./wsum + if(j1.ne.j2) then + gauout(i) = (wi1j1*regin(i1,j1) + wi2j1*regin(i2,j1) + & + wi1j2*regin(i1,j2) + wi2j2*regin(i2,j2)) & + *wsumiv + else + if (rlat .gt. 0.0) then + sumn = sum3 + sums = sum4 + if( j1 .eq. 1) then + gauout(i) = (wi1j1*sumn +wi2j1*sumn + & + wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2)) & + * wsumiv + elseif (j1 .eq. jmxin) then + gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+ & + wi1j2*sums +wi2j2*sums ) & + * wsumiv + endif + else + sums = sum3 + sumn = sum4 + if( j1 .eq. 1) then + gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+ & + wi1j2*sums +wi2j2*sums ) & + * wsumiv + elseif (j1 .eq. jmxin) then + gauout(i) = (wi1j1*sumn +wi2j1*sumn + & + wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2)) & + * wsumiv + endif + endif + endif ! if j1 .ne. j2 + endif + enddo + do i=1,len + j1 = jindx1(i) + j2 = jindx2(i) + i1 = iindx1(i) + i2 = iindx2(i) + if(wrk(i) .eq. 0.0) then + write(6,*) ' la2ga: error' + call sleep(2) + stop + endif + enddo + return +! + end subroutine stochy_la2ga + +!>@brief The subroutine 'initialize_spectral' initializes the +!gridded component of the stochastic physics pattern +!>@details This code is taken from the legacy spectral GFS + subroutine initialize_spectral(gis_stochy) + +! this subroutine set up the internal state variables, +! allocate internal state arrays for initializing the gfs system. +!---------------------------------------------------------------- +! + implicit none +! +! type(stochy_internal_state), pointer, intent(inout) :: gis_stochy + type(stochy_internal_state), intent(inout) :: gis_stochy + integer :: i, l, locl + +!------------------------------------------------------------------- + +! set up gfs internal state dimension and values for dynamics etc +!------------------------------------------------------------------- + gis_stochy%lon_dim_a = lon_s + 2 + jcap=ntrunc + latg = lat_s + latg2 = latg/2 + lonf = lon_s + + allocate(lat1s_a(0:jcap)) + allocate(lon_dims_a(latg)) + + allocate(wgt_a(latg2)) + allocate(rcs2_a(latg2)) + + ls_dim = (jcap)/gis_stochy%nodes+1 +!! +!cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +! + allocate ( gis_stochy%ls_node (ls_dim,3) ) + allocate ( gis_stochy%ls_nodes(ls_dim,gis_stochy%nodes) ) + allocate ( gis_stochy%max_ls_nodes(gis_stochy%nodes) ) +! + allocate ( gis_stochy%lats_nodes_a(gis_stochy%nodes) ) + allocate ( gis_stochy%global_lats_a(latg) ) +! + + + +!--------------------------------------------------- +! + call get_ls_node_stochy( gis_stochy%mype, gis_stochy%ls_node(:,1), ls_max_node, gis_stochy%nodes) +! +! + len_trie_ls = 0 + len_trio_ls = 0 + do locl=1,ls_max_node + gis_stochy%ls_node(locl,2) = len_trie_ls + gis_stochy%ls_node(locl,3) = len_trio_ls + l = gis_stochy%ls_node(locl,1) + len_trie_ls = len_trie_ls+(jcap+3-l)/2 + len_trio_ls = len_trio_ls+(jcap+2-l)/2 + enddo +! + allocate ( gis_stochy%epse (len_trie_ls) ) + allocate ( gis_stochy%epso (len_trio_ls) ) + allocate ( gis_stochy%epsedn(len_trie_ls) ) + allocate ( gis_stochy%epsodn(len_trio_ls) ) + allocate ( gis_stochy%kenorm_e(len_trie_ls) ) + allocate ( gis_stochy%kenorm_o(len_trio_ls) ) +! + allocate ( gis_stochy%snnp1ev(len_trie_ls) ) + allocate ( gis_stochy%snnp1od(len_trio_ls) ) +! + allocate ( gis_stochy%plnev_a(len_trie_ls,latg2) ) + allocate ( gis_stochy%plnod_a(len_trio_ls,latg2) ) + allocate ( gis_stochy%plnew_a(len_trie_ls,latg2) ) + allocate ( gis_stochy%plnow_a(len_trio_ls,latg2) ) + + allocate(colrad_a(latg2)) + allocate(sinlat_a(latg)) + allocate(coslat_a(latg)) +!! + call getcon_spectral(gis_stochy) +! + gis_stochy%lats_node_a = gis_stochy%lats_nodes_a(gis_stochy%mype+1) + + + allocate ( gis_stochy%trie_ls (len_trie_ls,2,gis_stochy%lotls) ) + allocate ( gis_stochy%trio_ls (len_trio_ls,2,gis_stochy%lotls) ) + + + end subroutine initialize_spectral + + +!>@brief The subroutine 'get_ls_node_stochy' calculates the decomposition of the spherical harmonics based on the processor layout + subroutine get_ls_node_stochy(me_fake,ls_node,ls_max_node_fake, nodes) +!>@details This code is taken from the legacy spectral GFS +! + implicit none +! + integer me_fake, ls_max_node_fake, nodes + integer ls_node(ls_dim) + + integer ijk, jptls, l, node, nodesio, jcap1 +! + nodesio = nodes + + ls_node = -1 + jcap1=jcap+1 +! + jptls = 0 + l = 0 +!............................................. + do ijk=1,jcap1 +! + do node=1,nodesio + if (node == me_fake+1) then + jptls = jptls + 1 + ls_node(jptls) = l + endif + l = l + 1 + if (l > jcap) go to 200 + enddo +! + do node=nodesio,1,-1 + if (node == me_fake+1) then + jptls = jptls + 1 + ls_node(jptls) = l + endif + l = l + 1 + if (l > jcap) go to 200 + enddo +! + enddo +!............................................. +! + 200 continue +! +!............................................. +! + ls_max_node_fake = 0 + do ijk=1,ls_dim + if(ls_node(ijk) >= 0) then + ls_max_node_fake = ijk + endif + enddo +! + return + end + +!>@brief The subroutine 'getcon_spectral' gets various constants for the spectral and related gaussian grid +!! and caluated the assoicate legendre polynomials +!>@details This code is taken from the legacy spectral GFS + subroutine getcon_spectral ( gis_stochy) + + implicit none +! + integer i,j,l,lat,n + integer ls_node(ls_dim,3) +! +! ls_node(1,1) ... ls_node(ls_max_node,1) : values of L +! ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev +! ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod +! + type(stochy_internal_state), intent(inout) :: gis_stochy +! + integer locl,node, indev, indod, indlsev,jbasev,indlsod,jbasod +! + integer gl_lats_index + integer global_time_sort_index_a(latg) +! + include 'function2' +! + real(kind=kind_dbl_prec), parameter :: cons0 = 0.d0, cons0p5 = 0.5d0,& + cons1 = 1.d0, cons0p92 = 0.92d0 +! + gl_lats_index = 0 + gis_stochy%global_lats_a = -1 + global_time_sort_index_a=lonf + + do node=1,gis_stochy%nodes + call get_lats_node_a_stochy( node-1, gis_stochy%global_lats_a,gis_stochy%lats_nodes_a(node),& + gl_lats_index,global_time_sort_index_a, gis_stochy%nodes) + enddo + call setlats_a_stochy(gis_stochy) + + do node=1,gis_stochy%nodes + call get_ls_node_stochy( node-1, gis_stochy%ls_nodes(1,node),gis_stochy%max_ls_nodes(node), gis_stochy%nodes ) + enddo +! + gis_stochy%lats_dim_a = 0 + do node=1,gis_stochy%nodes + gis_stochy%lats_dim_a = max(gis_stochy%lats_dim_a,gis_stochy%lats_nodes_a(node)) + enddo + + gis_stochy%ipt_lats_node_a = 1 + if ( gis_stochy%mype > 0 ) then + do node=1,gis_stochy%mype + gis_stochy%ipt_lats_node_a = gis_stochy%ipt_lats_node_a + gis_stochy%lats_nodes_a(node) + enddo + endif + +! + call glats_stochy(latg2,colrad_a,wgt_a,rcs2_a) + call epslon_stochy(gis_stochy) + call pln2eo_a_stochy(gis_stochy,latg2) + call gozrineo_a_stochy(gis_stochy,latg2) +! +! + do locl=1,ls_max_node + l = gis_stochy%ls_node(locl,1) + jbasev = gis_stochy%ls_node(locl,2) + indev = indlsev(l,l) + do n = l, jcap, 2 + gis_stochy%snnp1ev(indev) = n*(n+1) + indev = indev+1 + end do + end do +! + do locl=1,ls_max_node + l = gis_stochy%ls_node(locl,1) + jbasod = gis_stochy%ls_node(locl,3) + if ( l <= jcap-1 ) then + indod = indlsod(l+1,l) + do n = l+1, jcap, 2 + gis_stochy%snnp1od(indod) = n*(n+1) + indod = indod+1 + end do + end if + end do +! +! + do locl=1,ls_max_node + l = gis_stochy%ls_node(locl,1) + jbasev = gis_stochy%ls_node(locl,2) + jbasod = gis_stochy%ls_node(locl,3) + if (mod(L,2) == mod(jcap+1,2)) then ! set even (n-l) terms of top row to zero + gis_stochy%snnp1ev(indlsev(jcap+1,l)) = cons0 + else ! set odd (n-l) terms of top row to zero + gis_stochy%snnp1od(indlsod(jcap+1,l)) = cons0 + endif + enddo +! + do j=1,latg + if( j <= latg2 ) then + sinlat_a(j) = cos(colrad_a(j)) + else + sinlat_a(j) = -cos(colrad_a(latg+1-j)) + endif + coslat_a(j) = sqrt(1.-sinlat_a(j)*sinlat_a(j)) + enddo +! + do L=0,jcap + do lat = 1, latg2 + if ( L <= min(jcap,lonf/2) ) then + lat1s_a(L) = lat + go to 200 + endif + end do + 200 continue + end do + + do j=1,gis_stochy%lats_node_a + lon_dims_a(j) = lonfx + enddo + return + end + +!>@brief The subroutine 'get_lats_node_a_stochy' calculates the decomposition of the gaussian grid based on the processor layout +!>@details This code is taken from the legacy spectral GFS + subroutine get_lats_node_a_stochy(me_fake,global_lats_a, & + lats_nodes_a_fake,gl_lats_index, & + global_time_sort_index,nodes) +! + implicit none + + integer,intent(in) :: me_fake + integer,intent(in) :: nodes + integer,intent(in) :: lats_nodes_a_fake + integer,intent(inout) :: gl_lats_index + integer,intent(inout) :: global_lats_a(latg) + integer, intent(in) :: global_time_sort_index(latg) + + integer :: ijk + integer :: jptlats + integer :: lat + integer :: node + + lat = 1 + +!............................................. + do ijk=1,latg + do node=1,nodes + if (node.eq.me_fake+1) then + gl_lats_index=gl_lats_index+1 + global_lats_a(gl_lats_index) = global_time_sort_index(lat) + endif + lat = lat + 1 + if (lat .gt. latg) go to 200 + enddo + + do node=nodes,1,-1 + if (node.eq.me_fake+1) then + gl_lats_index=gl_lats_index+1 + global_lats_a(gl_lats_index) = global_time_sort_index(lat) + endif + lat = lat + 1 + if (lat .gt. latg) go to 200 + enddo + enddo + 200 continue + return + end + +!>@brief The subroutine 'gozrineo_a_stochy' calculates the deriviates of assoicate legendre polynomials +!>@details This code is taken from the legacy spectral GFS + subroutine gozrineo_a_stochy(gis_stochy, num_lat) + + implicit none + + type(stochy_internal_state), intent(inout) :: gis_stochy + integer, intent(in) :: num_lat + + integer l,lat,locl,n + integer indev,indev1,indev2 + integer indod,indod1,indod2 + integer inddif + + real(kind=kind_dbl_prec) rn,rnp1,wcsa + + real(kind=kind_dbl_prec) cons0 !constant + real(kind=kind_dbl_prec) cons2 !constant + real rerth + + integer indlsev,jbasev + integer indlsod,jbasod + + include 'function2' + + + cons0 = 0.d0 !constant + cons2 = 2.d0 !constant + rerth =6.3712e+6 ! radius of earth (m) + + + do lat=1,num_lat + + wcsa=rcs2_a(lat)/rerth + + do locl=1,ls_max_node + l=gis_stochy%ls_node(locl,1) + jbasev=gis_stochy%ls_node(locl,2) + jbasod=gis_stochy%ls_node(locl,3) + indev1 = indlsev(L,L) + indod1 = indlsod(L+1,L) + if (mod(L,2).eq.mod(jcap+1,2)) then + indev2 = indlsev(jcap+1,L) + indod2 = indlsod(jcap ,L) + else + indev2 = indlsev(jcap ,L) + indod2 = indlsod(jcap+1,L) + endif + do indev = indev1 , indev2 + gis_stochy%plnew_a(indev,lat) = gis_stochy%plnev_a(indev,lat) * wgt_a(lat) + enddo + + do indod = indod1 , indod2 + gis_stochy%plnow_a(indod,lat) = gis_stochy%plnod_a(indod,lat) * wgt_a(lat) + enddo + enddo + enddo + return + end + +!>@brief The subroutine 'setlats_a_stochy' selects the latitude points on this task +!>@details This code is taken from the legacy spectral GFS + subroutine setlats_a_stochy(gis_stochy) +! + implicit none +! + type(stochy_internal_state), intent(inout) :: gis_stochy + + integer :: nodesio, & + jcount,jpt,lat,lats_sum,node,i,ii, & + ngrptg,ngrptl,ipe,irest,idp, & + ngrptgh,nodesioh +! + integer,allocatable :: lats_hold(:,:) +! + allocate ( lats_hold(latg,gis_stochy%nodes) ) +! + gis_stochy%lats_nodes_a = 0 + nodesio = gis_stochy%nodes +! + ngrptg = 0 + do lat=1,latg + do i=1,lonf + ngrptg = ngrptg + 1 + enddo + enddo + +! +! ngrptg contains total number of grid points. +! +! distribution of the grid + nodesioh = nodesio / 2 + + if (nodesioh*2 /= nodesio) then + ngrptl = 0 + ipe = 0 + irest = 0 + idp = 1 + + do lat=1,latg + ngrptl = ngrptl + lonf + + if (ngrptl*nodesio <= ngrptg+irest) then + gis_stochy%lats_nodes_a(ipe+1) = gis_stochy%lats_nodes_a(ipe+1) + 1 + lats_hold(idp,ipe+1) = lat + idp = idp + 1 + else + ipe = ipe + 1 + if (ipe <= nodesio) lats_hold(1,ipe+1) = lat + idp = 2 + irest = irest + ngrptg - (ngrptl-lonf)*nodesio + ngrptl = lonf + gis_stochy%lats_nodes_a(ipe+1) = gis_stochy%lats_nodes_a(ipe+1) + 1 + endif + enddo + else + nodesioh = nodesio/2 + ngrptgh = ngrptg/2 + ngrptl = 0 + ipe = 0 + irest = 0 + idp = 1 + + do lat=1,latg/2 + ngrptl = ngrptl + lonf + + if (ngrptl*nodesioh <= ngrptgh+irest .or. lat == latg/2) then + gis_stochy%lats_nodes_a(ipe+1) = gis_stochy%lats_nodes_a(ipe+1) + 1 + lats_hold(idp,ipe+1) = lat + idp = idp + 1 + else + ipe = ipe + 1 + if (ipe <= nodesioh) then + lats_hold(1,ipe+1) = lat + endif + idp = 2 + irest = irest + ngrptgh - (ngrptl-lonf)*nodesioh + ngrptl = lonf + gis_stochy%lats_nodes_a(ipe+1) = gis_stochy%lats_nodes_a(ipe+1) + 1 + endif + enddo + do node=1, nodesioh + ii = nodesio-node+1 + jpt = gis_stochy%lats_nodes_a(node) + gis_stochy%lats_nodes_a(ii) = jpt + do i=1,jpt + lats_hold(jpt+1-i,ii) = latg+1-lats_hold(i,node) + enddo + enddo + + + endif +!! +!!........................................................ +!! + jpt = 0 + do node=1,nodesio + if ( gis_stochy%lats_nodes_a(node) > 0 ) then + do jcount=1,gis_stochy%lats_nodes_a(node) + gis_stochy%global_lats_a(jpt+jcount) = lats_hold(jcount,node) + enddo + endif + jpt = jpt + gis_stochy%lats_nodes_a(node) + enddo + + deallocate (lats_hold) + + return + end + +!>@brief The subroutine 'glats_stochy' calculate the latitudes for the gaussian grid +!>@details This code is taken from the legacy spectral GFS + subroutine glats_stochy(lgghaf,colrad,wgt,rcs2) +! +! Jan 2013 Henry Juang increase precision by kind_qdt_prec=16 +! to help wgt (Gaussian weighting) + implicit none + integer iter,k,k1,l2,lgghaf +! +! increase precision for more significant digit to help wgt + real(kind=kind_qdt_prec) drad,dradz,p1,p2,phi,pi,rad,rc + real(kind=kind_qdt_prec) rl2,scale,si,sn,w,x + real(kind=kind_dbl_prec), dimension(lgghaf) :: colrad, wgt, rcs2 +! + real(kind=kind_dbl_prec), parameter :: cons0 = 0.d0, cons1 = 1.d0, & + cons2 = 2.d0, cons4 = 4.d0, & + cons180 = 180.d0, & + cons0p25 = 0.25d0 + real(kind=kind_qdt_prec), parameter :: eps = 1.d-20 +! +! for better accuracy to select smaller number +! eps = 1.d-12 +! eps = 1.d-20 +! + si = cons1 + l2 = 2*lgghaf + rl2 = l2 + scale = cons2/(rl2*rl2) + k1 = l2-1 + pi = atan(si)*cons4 + +! for better accuracy to start iteration + dradz = pi / float(lgghaf) / 200.0 + rad = cons0 + do k=1,lgghaf + iter = 0 + drad = dradz +1 call poly(l2,rad,p2) +2 p1 = p2 + iter = iter + 1 + rad = rad + drad + call poly(l2,rad,p2) + if(sign(si,p1) == sign(si,p2)) go to 2 + if(drad < eps)go to 3 + rad = rad-drad + drad = drad * cons0p25 + go to 1 +3 continue + colrad(k) = rad + phi = rad * cons180 / pi + call poly(k1,rad,p1) + x = cos(rad) + w = scale * (cons1 - x*x)/ (p1*p1) + wgt(k) = w + sn = sin(rad) + w = w/(sn*sn) + rc = cons1/(sn*sn) + rcs2(k) = rc + call poly(l2,rad,p1) + enddo +! + return + end + +!>@brief The subroutine 'poly' does something with latitudes +!>@details This code is taken from the legacy spectral GFS + subroutine poly(n,rad,p) +! + implicit none + integer i,n +! +! increase precision for more significant digit to help wgt + real(kind=kind_qdt_prec) floati,g,p,rad,x,y1,y2,y3 +! + real(kind=kind_dbl_prec), parameter :: cons1 = 1.d0 +! + x = cos(rad) + y1 = cons1 + y2 = x + do i=2,n + g = x*y2 + floati = i + y3 = g - y1 + g - (g-y1)/floati + y1 = y2 + y2 = y3 + enddo + p = y3 + return + end + +!>@brief The subroutine 'pln2eo_a_stochy' calculates the assoicated legendre polynomials +!>@details This code is taken from the legacy spectral GFS + subroutine pln2eo_a_stochy(gis_stochy,num_lat) +! +! use x-number method to archieve accuracy due to recursive to avoid +! underflow and overflow if necessary by henry juang 2012 july +! + implicit none +! +! define x number constant for real8 start + type(stochy_internal_state), intent(inout) :: gis_stochy + integer, intent(in) :: num_lat + integer, parameter :: in_f = 960 , in_h = in_f/2 + real(kind=kind_dbl_prec), parameter :: bb_f = 2.d0 ** ( in_f ) + real(kind=kind_dbl_prec), parameter :: bs_f = 2.d0 ** (-in_f ) + real(kind=kind_dbl_prec), parameter :: bb_h = 2.d0 ** ( in_h ) + real(kind=kind_dbl_prec), parameter :: bs_h = 2.d0 ** (-in_h ) +! define x number constant end + +!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L +!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev +!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod + integer l,lat,locl,max_l,n + integer indev + integer indod +! need index for alp to be x-number + integer id, ialp1, ialp2, ialp3, iprod + integer ialp10(0:jcap) + real(kind=kind_dbl_prec) aa, bb, w + + real(kind=kind_dbl_prec) alp1,alp2,alp3 + real(kind=kind_dbl_prec) cos2,fl,prod,sinlat,coslat + real(kind=kind_dbl_prec) alp10(0:jcap) + real(kind=kind_dbl_prec) cons0,cons0p5,cons1,cons2,cons3 !constant + integer indlsev,jbasev + integer indlsod,jbasod + + include 'function2' + + cons0=0.0d0 !constant + cons0p5=0.5d0 !constant + cons1=1.0d0 !constant + cons2=2.0d0 !constant + cons3=3.0d0 !constant + + max_l=-1 + do locl=1,ls_max_node + max_l = max ( max_l, gis_stochy%ls_node(locl,1) ) + enddo + + do lat=1,num_lat + + sinlat = cos(colrad_a(lat)) + cos2=cons1-sinlat*sinlat !constant + coslat = sqrt(cos2) + +! use x number for alp10 + alp10(0) = sqrt(0.5) + ialp10(0) = 0 + + do l=1,max_l + fl = l + prod=coslat*sqrt(cons1+cons1/(cons2*fl)) + iprod=0 + w = abs(prod) + if( w.ge.bb_h ) then + prod = prod * bs_f + iprod = iprod + 1 + elseif( w.lt.bs_h ) then + prod = prod * bb_f + iprod = iprod - 1 + endif + alp10(l)=alp10(l-1)*prod + ialp10(l)=ialp10(l-1)+iprod + w = abs(alp10(l)) + if( w.ge.bb_h ) then + alp10(l) = alp10(l) * bs_f + ialp10(l) = ialp10(l) + 1 + elseif( w.lt.bs_h ) then + alp10(l) = alp10(l) * bb_f + ialp10(l) = ialp10(l) - 1 + endif + enddo + + do locl=1,ls_max_node + l=gis_stochy%ls_node(locl,1) + jbasev=gis_stochy%ls_node(locl,2) + jbasod=gis_stochy%ls_node(locl,3) + n=l + fl=l +! get m=normalized x number for alp1 start + alp1=alp10(l) + ialp1=ialp10(l) + + indev=indlsev(n ,l) + indod=indlsod(n+1,l) +! x2f start + if( ialp1.eq.0 ) then + gis_stochy%plnev_a(indev ,lat)=alp1 + elseif( ialp1.eq.-1 ) then + gis_stochy%plnev_a(indev ,lat)=alp1 * bs_f + elseif( ialp1.lt.-1 ) then + gis_stochy%plnev_a(indev ,lat)=0.0 + else + gis_stochy%plnev_a(indev ,lat)=alp1 * bb_f + endif +! x2f end + +! xltime alp2=sqrt(cons2*fl+cons3)*sinlat*alp1 !constant +! xltime start + prod=sqrt(cons2*fl+cons3)*sinlat + iprod=0 + w = abs(prod) + if( w.ge.bb_h ) then + prod = prod * bs_f + iprod = iprod + 1 + elseif( w.lt.bs_h ) then + prod = prod * bb_f + iprod = iprod - 1 + endif + alp2=alp1*prod + ialp2 = ialp1 + iprod +! xltime end +! norm alp2 start + w = abs(alp2) + if( w.ge.bb_h ) then + alp2 = alp2*bs_f + ialp2 = ialp2 + 1 + elseif( w.lt.bs_h ) then + alp2 = alp2*bb_f + ialp2 = ialp2 - 1 + endif +! norm alp2 end + +! x2f start + if( ialp2.eq.0 ) then + gis_stochy%plnod_a(indod ,lat)=alp2 + elseif( ialp2.eq.-1 ) then + gis_stochy%plnod_a(indod ,lat)=alp2 * bs_f + elseif( ialp2.lt.-1 ) then + gis_stochy%plnod_a(indod ,lat)=0.0 + else + gis_stochy%plnod_a(indod ,lat)=alp2 * bb_f + endif +! x2f end + + do n=l+2,jcap+1 + if(mod(n+l,2).eq.0) then + indev=indev+1 +! xlsum2 start + aa = sinlat / gis_stochy%epse(indev) + bb = gis_stochy%epso(indod) / gis_stochy%epse(indev) + id = ialp2 - ialp1 + if( id.eq.0 ) then + alp3 = aa*alp2 - bb*alp1 + ialp3 = ialp1 + elseif( id.eq.1 ) then + alp3 = aa*alp2 - bb*alp1*bs_f + ialp3 = ialp2 + elseif( id.eq.-1 ) then + alp3 = aa*alp2*bs_f - bb*alp1 + ialp3 = ialp1 + elseif( id.gt.1 ) then + alp3 = aa*alp2 + ialp3 = ialp2 + else + alp3 = - bb*alp1 + ialp3 = ialp1 + endif +! xlsum2 end +! xnorm alp3 start + w = abs(alp3) + if( w.ge.bb_h ) then + alp3 = alp3*bs_f + ialp3 = ialp3 + 1 + elseif( w.lt.bs_h ) then + alp3 = alp3*bb_f + ialp3 = ialp3 - 1 + endif +! xnorm alp3 end + +! x2f alp3 start + if( ialp3.eq.0 ) then + gis_stochy%plnev_a(indev,lat)=alp3 + elseif( ialp3.eq.-1 ) then + gis_stochy%plnev_a(indev,lat)=alp3 * bs_f + elseif( ialp3.lt.-1 ) then + gis_stochy%plnev_a(indev,lat)=0.0 + else + gis_stochy%plnev_a(indev,lat)=alp3 * bb_f + endif +! x2f alp3 end + + else + indod=indod+1 + +! xlsum2 start + aa = sinlat / gis_stochy%epso(indod) + bb = gis_stochy%epse(indev) / gis_stochy%epso(indod) + id = ialp2 - ialp1 + if( id.eq.0 ) then + alp3 = aa*alp2 - bb*alp1 + ialp3 = ialp1 + elseif( id.eq.1 ) then + alp3 = aa*alp2 - bb*alp1*bs_f + ialp3 = ialp2 + elseif( id.eq.-1 ) then + alp3 = aa*alp2*bs_f - bb*alp1 + ialp3 = ialp1 + elseif( id.gt.1 ) then + alp3 = aa*alp2 + ialp3 = ialp2 + else + alp3 = - bb*alp1 + ialp3 = ialp1 + endif +! xlsum2 end +! xnorm alp3 start + w = abs(alp3) + if( w.ge.bb_h ) then + alp3 = alp3*bs_f + ialp3 = ialp3 + 1 + elseif( w.lt.bs_h ) then + alp3 = alp3*bb_f + ialp3 = ialp3 - 1 + endif +! xnorm alp3 end + +! x2f alp3 start + if( ialp3.eq.0 ) then + gis_stochy%plnod_a(indod,lat)=alp3 + elseif( ialp3.eq.-1 ) then + gis_stochy%plnod_a(indod,lat)=alp3 * bs_f + elseif( ialp3.lt.-1 ) then + gis_stochy%plnod_a(indod,lat)=0.0 + else + gis_stochy%plnod_a(indod,lat)=alp3 * bb_f + endif +! x2f alp3 end + endif + alp1=alp2 + alp2=alp3 + ialp1 = ialp2 + ialp2 = ialp3 + enddo + enddo + enddo + + return + end + +!>@brief The subroutine 'epslon_stochy' calculate coeffients for use in spectral space +!>@details This code is taken from the legacy spectral GFS + subroutine epslon_stochy(gis_stochy) + + implicit none + + type(stochy_internal_state), intent(inout) :: gis_stochy + + integer ls_node(ls_dim,3) + +!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L +!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev +!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod + + integer l,locl,n + + integer indev + integer indod + + real(kind_dbl_prec) f1,f2,rn,val + + real(kind_dbl_prec) cons0 !constant + + integer indlsev,jbasev + integer indlsod,jbasod + + include 'function2' + + cons0=0.0d0 !constant +!c +!c...................................................................... +!c + do locl=1,ls_max_node + l=gis_stochy%ls_node(locl,1) + jbasev=gis_stochy%ls_node(locl,2) + indev=indlsev(l,l) + gis_stochy%epse (indev)=cons0 !constant + gis_stochy%epsedn(indev)=cons0 !constant + indev=indev+1 + + do n=l+2,jcap+1,2 + rn=n + f1=n*n-l*l + f2=4*n*n-1 + val=sqrt(f1/f2) + gis_stochy%epse (indev)=val + gis_stochy%epsedn(indev)=val/rn + indev=indev+1 + enddo + enddo + do locl=1,ls_max_node + l=gis_stochy%ls_node(locl,1) + jbasod=gis_stochy%ls_node(locl,3) + indod=indlsod(l+1,l) + + do n=l+1,jcap+1,2 + rn=n + f1=n*n-l*l + f2=4*n*n-1 + val=sqrt(f1/f2) + gis_stochy%epso (indod)=val + gis_stochy%epsodn(indod)=val/rn + indod=indod+1 + enddo + enddo + + return + end + end module spectral_transforms diff --git a/standalone_ca.F90 b/standalone_ca.F90 deleted file mode 100644 index 12a45092..00000000 --- a/standalone_ca.F90 +++ /dev/null @@ -1,262 +0,0 @@ -program standalone_stochy_new - -use standalone_stochy_module - -use atmosphere_stub_mod, only: Atm,atmosphere_init_stub -!use mpp_domains -use mpp_mod, only: mpp_set_current_pelist,mpp_get_current_pelist,mpp_init,mpp_pe,mpp_npes ,mpp_declare_pelist -use mpp_domains_mod, only: mpp_broadcast_domain,MPP_DOMAIN_TIME,mpp_domains_init ,mpp_domains_set_stack_size -use fms_mod, only: fms_init -!use time_manager_mod, only: time_type -use xgrid_mod, only: grid_box_type -use netcdf - - -implicit none -type(GFS_control_type) :: Model -integer, parameter :: nlevs=64 -integer :: ntasks,fid,ct -integer :: nthreads,omp_get_num_threads -integer :: ncid,xt_dim_id,yt_dim_id,time_dim_id,xt_var_id,yt_var_id,time_var_id,ca_out_id -integer :: ca1_id,ca2_id,ca3_id -character*1 :: strid -type(GFS_grid_type),allocatable :: Grid(:) -type(GFS_diag_type),allocatable :: Diag(:) -type(GFS_statein_type),allocatable :: Statein(:) -type(GFS_coupling_type),allocatable :: Coupling(:) -include 'mpif.h' -include 'netcdf.inc' -real(kind=4) :: ts,undef - -integer :: cres,blksz,nblks,ierr,my_id,i,j,nx2,ny2,nx,ny,id -integer,target :: npx,npy -integer :: ng,layout(2),io_layout(2),commID,grid_type,ntiles -integer :: halo_update_type = 1 -logical,target :: nested -integer :: pe,npes,stackmax=4000000 - -real(kind=4),allocatable,dimension(:,:) :: workg -real(kind=4),allocatable,dimension(:) :: grid_xt,grid_yt -real(kind=8),pointer ,dimension(:,:) :: area -type(grid_box_type) :: grid_box -!type(time_type) :: Time ! current time -!type(time_type) :: Time_step ! atmospheric time step. -!type(time_type) :: Time_init ! reference time. -!---cellular automata control parameters -integer :: nca !< number of independent cellular automata -integer :: nlives !< cellular automata lifetime -integer :: ncells !< cellular automata finer grid -real :: nfracseed !< cellular automata seed probability -integer :: nseed !< cellular automata seed frequency -logical :: do_ca !< cellular automata main switch -logical :: ca_sgs !< switch for sgs ca -logical :: ca_global !< switch for global ca -logical :: ca_smooth !< switch for gaussian spatial filter -logical :: isppt_deep !< switch for combination with isppt_deep. OBS! Switches off SPPT on other tendencies! -logical :: isppt_pbl -logical :: isppt_shal -logical :: pert_flux -logical :: pert_trigger -integer :: iseed_ca !< seed for random number generation in ca scheme -integer :: nspinup !< number of iterations to spin up the ca -integer :: ca_amplitude -real :: nthresh !< threshold used for perturbed vertical velocity - -NAMELIST /gfs_physics_nml/ nca, ncells, nlives, nfracseed,nseed, nthresh, & - do_ca,ca_sgs, ca_global,iseed_ca,ca_smooth,isppt_pbl,isppt_shal,isppt_deep,nspinup,& - pert_trigger,pert_flux,ca_amplitude - -! default values -nca = 1 -ncells = 5 -nlives = 10 -nfracseed = 0.5 -nseed = 100000 -iseed_ca = 0 -nspinup = 1 -do_ca = .false. -ca_sgs = .false. -ca_global = .false. -ca_smooth = .false. -isppt_deep = .false. -isppt_shal = .false. -isppt_pbl = .false. -pert_trigger = .false. -pert_flux = .false. -ca_amplitude = 500. -nthresh = 0.0 - -! open namelist file -open (unit=565, file='input.nml', READONLY, status='OLD', iostat=ierr) -read(565,gfs_physics_nml) -close(565) -! define stuff -ng=3 ! ghost region -undef=9.99e+20 - -! initialize fms -call fms_init() -call mpp_init() -call fms_init -my_id=mpp_pe() - -call atmosphere_init_stub (grid_box, area) -!define domain -isd=Atm(1)%bd%isd -ied=Atm(1)%bd%ied -jsd=Atm(1)%bd%jsd -jed=Atm(1)%bd%jed -isc=Atm(1)%bd%isc -iec=Atm(1)%bd%iec -jsc=Atm(1)%bd%jsc -jec=Atm(1)%bd%jec -nx=Atm(1)%npx-1 -ny=Atm(1)%npy-1 -allocate(workg(nx,ny)) - -! for this simple test, nblocks = ny, blksz=ny -nblks=ny -blksz=nx -nthreads = omp_get_num_threads() -Model%me=my_id - -Model%nca = nca -Model%ncells = ncells -Model%nlives = nlives -Model%nfracseed = nfracseed -Model%nseed = nseed -Model%iseed_ca = iseed_ca -Model%nspinup = nspinup -Model%do_ca = do_ca -Model%ca_sgs = ca_sgs -Model%ca_global = ca_global -Model%ca_smooth = ca_smooth -Model%isppt_deep = isppt_deep -Model%isppt_pbl = isppt_pbl -Model%isppt_shal = isppt_shal -Model%pert_flux = pert_flux -Model%pert_trigger = pert_trigger -Model%nthresh = nthresh - -! setup GFS_init parameters - -!define model grid - -allocate(grid_xt(nx),grid_yt(ny)) -do i=1,nx - grid_xt(i)=i -enddo -do i=1,ny - grid_yt(i)=i -enddo - -!setup GFS_coupling -allocate(Diag(nblks)) -allocate(Coupling(nblks)) -allocate(Statein(nblks)) -write(strid,'(I1.1)') my_id+1 -fid=30+my_id -ierr=nf90_create('ca_out.tile'//strid//'.nc',cmode=NF90_CLOBBER,ncid=ncid) -ierr=NF90_DEF_DIM(ncid,"grid_xt",nx,xt_dim_id) -ierr=NF90_DEF_DIM(ncid,"grid_yt",ny,yt_dim_id) -ierr=NF90_DEF_DIM(ncid,"time",NF90_UNLIMITED,time_dim_id) - !> - Define the dimension variables. -ierr=NF90_DEF_VAR(ncid,"grid_xt",NF90_FLOAT,(/ xt_dim_id /), xt_var_id) -ierr=NF90_PUT_ATT(ncid,xt_var_id,"long_name","T-cell longitude") -ierr=NF90_PUT_ATT(ncid,xt_var_id,"cartesian_axis","X") -ierr=NF90_PUT_ATT(ncid,xt_var_id,"units","degrees_E") -ierr=NF90_DEF_VAR(ncid,"grid_yt",NF90_FLOAT,(/ yt_dim_id /), yt_var_id) -ierr=NF90_PUT_ATT(ncid,yt_var_id,"long_name","T-cell latitude") -ierr=NF90_PUT_ATT(ncid,yt_var_id,"cartesian_axis","Y") -ierr=NF90_PUT_ATT(ncid,yt_var_id,"units","degrees_N") -ierr=NF90_DEF_VAR(ncid,"time",NF90_FLOAT,(/ time_dim_id /), time_var_id) -ierr=NF90_PUT_ATT(ncid,time_var_id,"long_name","time") -ierr=NF90_PUT_ATT(ncid,time_var_id,"units","hours since 2014-08-01 00:00:00") -ierr=NF90_PUT_ATT(ncid,time_var_id,"cartesian_axis","T") -ierr=NF90_PUT_ATT(ncid,time_var_id,"calendar_type","JULIAN") -ierr=NF90_PUT_ATT(ncid,time_var_id,"calendar","JULIAN") -!ierr=NF90_DEF_VAR(ncid,"ca_out",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), ca_out_id) -!ierr=NF90_PUT_ATT(ncid,ca_out_id,"long_name","random pattern") -!ierr=NF90_PUT_ATT(ncid,ca_out_id,"units","None") -!ierr=NF90_PUT_ATT(ncid,ca_out_id,"missing_value",undef) -!ierr=NF90_PUT_ATT(ncid,ca_out_id,"_FillValue",undef) -!ierr=NF90_PUT_ATT(ncid,ca_out_id,"cell_methods","time: point") -ierr=NF90_DEF_VAR(ncid,"ca1",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), ca1_id) -ierr=NF90_PUT_ATT(ncid,ca1_id,"long_name","random pattern") -ierr=NF90_PUT_ATT(ncid,ca1_id,"units","None") -ierr=NF90_PUT_ATT(ncid,ca1_id,"missing_value",undef) -ierr=NF90_PUT_ATT(ncid,ca1_id,"_FillValue",undef) -ierr=NF90_PUT_ATT(ncid,ca1_id,"cell_methods","time: point") -ierr=NF90_DEF_VAR(ncid,"ca2",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), ca2_id) -ierr=NF90_PUT_ATT(ncid,ca2_id,"long_name","random pattern") -ierr=NF90_PUT_ATT(ncid,ca2_id,"units","None") -ierr=NF90_PUT_ATT(ncid,ca2_id,"missing_value",undef) -ierr=NF90_PUT_ATT(ncid,ca2_id,"_FillValue",undef) -ierr=NF90_PUT_ATT(ncid,ca2_id,"cell_methods","time: point") -ierr=NF90_DEF_VAR(ncid,"ca3",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), ca3_id) -ierr=NF90_PUT_ATT(ncid,ca3_id,"long_name","random pattern") -ierr=NF90_PUT_ATT(ncid,ca3_id,"units","None") -ierr=NF90_PUT_ATT(ncid,ca3_id,"missing_value",undef) -ierr=NF90_PUT_ATT(ncid,ca3_id,"_FillValue",undef) -ierr=NF90_PUT_ATT(ncid,ca3_id,"cell_methods","time: point") -ierr=NF90_ENDDEF(ncid) -ierr=NF90_PUT_VAR(ncid,xt_var_id,grid_xt) -ierr=NF90_PUT_VAR(ncid,yt_var_id,grid_yt) -! allocate diagnostics -DO i =1,nblks - allocate(Diag(i)%ca_out(blksz)) - allocate(Diag(i)%ca_deep(blksz)) - allocate(Diag(i)%ca_turb(blksz)) - allocate(Diag(i)%ca_shal(blksz)) - allocate(Diag(i)%ca_rad(blksz)) - allocate(Diag(i)%ca_micro(blksz)) - allocate(Diag(i)%ca1(blksz)) - allocate(Diag(i)%ca2(blksz)) - allocate(Diag(i)%ca3(blksz)) -! allocate coupling - allocate(Coupling(i)%cape(blksz)) - allocate(Coupling(i)%ca_out(blksz)) - allocate(Coupling(i)%ca_deep(blksz)) - allocate(Coupling(i)%ca_turb(blksz)) - allocate(Coupling(i)%ca_shal(blksz)) - allocate(Coupling(i)%ca_rad(blksz)) - allocate(Coupling(i)%ca_micro(blksz)) - allocate(Coupling(i)%ca1(blksz)) - allocate(Coupling(i)%ca2(blksz)) - allocate(Coupling(i)%ca3(blksz)) -! allocate coupling - allocate(Statein(i)%pgr(blksz)) - allocate(Statein(i)%qgrs(blksz,nlevs,1)) - allocate(Statein(i)%vvl(blksz,nlevs)) - allocate(Statein(i)%prsl(blksz,nlevs)) -ENDDO -ct=1 -do i=1,600 - ts=i/8.0 ! hard coded to write out hourly based on a 450 second time-step - call cellular_automata_global(i-1, Statein, Coupling, Diag, & - nblks, Model%levs, Model%nca, Model%ncells, & - Model%nlives, Model%nfracseed, Model%nseed, & - Model%nthresh, Model%ca_global, Model%ca_sgs, & - Model%iseed_ca, Model%ca_smooth, Model%nspinup, & - blksz) - if (mod(i,8).EQ.0) then - do j=1,ny - workg(:,j)=Diag(j)%ca1(:) - enddo - ierr=NF90_PUT_VAR(ncid,ca1_id,workg,(/1,1,ct/)) - do j=1,ny - workg(:,j)=Diag(j)%ca2(:) - enddo - ierr=NF90_PUT_VAR(ncid,ca2_id,workg,(/1,1,ct/)) - do j=1,ny - workg(:,j)=Diag(j)%ca3(:) - enddo - ierr=NF90_PUT_VAR(ncid,ca3_id,workg,(/1,1,ct/)) - ierr=NF90_PUT_VAR(ncid,time_var_id,ts,(/ct/)) - ct=ct+1 - if (my_id.EQ.0) write(6,fmt='(a,i5,4f6.3)') 'ca=',i,Diag(1)%ca1(1:4) - endif -enddo -!close(fid) -ierr=NF90_CLOSE(ncid) -end diff --git a/standalone_stochy.F90 b/standalone_stochy.F90 deleted file mode 100644 index d72e9005..00000000 --- a/standalone_stochy.F90 +++ /dev/null @@ -1,335 +0,0 @@ -program standalone_stochy - -use standalone_stochy_module -use stochastic_physics, only : init_stochastic_physics,run_stochastic_physics - -use atmosphere_stub_mod, only: Atm,atmosphere_init_stub -!use mpp_domains -use mpp_mod, only: mpp_set_current_pelist,mpp_get_current_pelist,mpp_init,mpp_pe,mpp_npes ,mpp_declare_pelist -use mpp_domains_mod, only: mpp_broadcast_domain,MPP_DOMAIN_TIME,mpp_domains_init ,mpp_domains_set_stack_size -use fms_mod, only: fms_init -use xgrid_mod, only: grid_box_type -use netcdf - -implicit none -type(GFS_control_type) :: Model -type(GFS_init_type) :: Init_parm -integer, parameter :: nlevs=64 -integer :: ntasks,fid -integer :: nthreads,omp_get_num_threads -integer :: ncid,xt_dim_id,yt_dim_id,time_dim_id,xt_var_id,yt_var_id,time_var_id,var_id_lat,var_id_lon,var_id_tile -integer :: varid1,varid2,varid3,varid4,varid_lon,varid_lat,varid_tile -integer :: zt_dim_id,zt_var_id -character*1 :: strid -type(GFS_grid_type),allocatable :: Grid(:) -type(GFS_coupling_type),allocatable :: Coupling(:) -! stochastic namelist fields -integer nssppt,nsshum,nsskeb,lon_s,lat_s,ntrunc -integer skeb_varspect_opt,skeb_npass -logical sppt_sfclimit - -real(kind=kind_dbl_prec) :: skeb_sigtop1,skeb_sigtop2, & - sppt_sigtop1,sppt_sigtop2,shum_sigefold, & - skeb_vdof -real(kind=kind_dbl_prec) skeb_diss_smooth,spptint,shumint,skebint,skebnorm -real(kind=kind_dbl_prec), dimension(5) :: skeb,skeb_lscale,skeb_tau -real(kind=kind_dbl_prec), dimension(5) :: sppt,sppt_lscale,sppt_tau -real(kind=kind_dbl_prec), dimension(5) :: shum,shum_lscale,shum_tau -integer,dimension(5) ::skeb_vfilt -integer(8),dimension(5) ::iseed_sppt,iseed_shum,iseed_skeb -logical stochini,sppt_logit,new_lscale -logical use_zmtnblck -include 'mpif.h' -include 'netcdf.inc' -real :: ak(nlevs+1),bk(nlevs+1) -real(kind=4) :: ts,undef - -data ak(:) /0.000, 0.000, 0.575, 5.741, 21.516, 55.712, 116.899, 214.015, 356.223, 552.720, 812.489, & - 1143.988, 1554.789, 2051.150, 2637.553, 3316.217, 4086.614, 4945.029, 5884.206, 6893.117, & - 7956.908, 9057.051, 10171.712, 11276.348, 12344.490, 13348.671, 14261.435, 15056.342, & - 15708.893, 16197.315, 16503.145, 16611.604, 16511.736, 16197.967, 15683.489, 14993.074, & - 14154.316, 13197.065, 12152.937, 11054.853, 9936.614, 8832.537, 7777.150, 6804.874, 5937.050,& - 5167.146, 4485.493, 3883.052, 3351.460, 2883.038, 2470.788, 2108.366, 1790.051, 1510.711, & - 1265.752, 1051.080, 863.058, 698.457, 554.424, 428.434, 318.266, 221.958, 137.790, 64.247,0.0 / -data bk(:) /1.00000000, 0.99467117, 0.98862660, 0.98174226, 0.97386760, 0.96482760, 0.95443410, 0.94249105, & - 0.92879730, 0.91315103, 0.89535499, 0.87522358, 0.85259068, 0.82731885, 0.79930973, 0.76851469, & - 0.73494524, 0.69868290, 0.65988702, 0.61879963, 0.57574666, 0.53113484, 0.48544332, 0.43921080, & - 0.39301825, 0.34746850, 0.30316412, 0.26068544, 0.22057019, 0.18329623, 0.14926878, 0.11881219, & - 0.09216691, 0.06947458, 0.05064684, 0.03544162, 0.02355588, 0.01463712, 0.00829402, 0.00410671, & - 0.00163591, 0.00043106, 0.00003697, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, & - 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, & - 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, & - 0.00000000 / -integer :: cres,blksz,nblks,ierr,my_id,i,j,k,nx2,ny2,nx,ny,id -integer,target :: npx,npy -integer :: ng,layout(2),io_layout(2),commID,grid_type,ntiles -integer :: halo_update_type = 1 -real :: dx,dy,pi,rd,cp -logical,target :: nested -logical :: write_this_tile -integer :: nargs,ntile_out,nlunit,pe,npes,stackmax=4000000 -character*80 :: fname -character*1 :: ntile_out_str -integer :: iret - -real(kind=4),allocatable,dimension(:,:) :: workg,tile_number -real(kind=4),allocatable,dimension(:,:,:) :: workg3d -real(kind=4),allocatable,dimension(:) :: grid_xt,grid_yt -real(kind=8),pointer ,dimension(:,:) :: area -real(kind=8) :: ex3d(nlevs+1),pressi(nlevs+1),pressl(nlevs),p1000,exn - -type(grid_box_type) :: grid_box - - namelist /nam_stochy/ntrunc,lon_s,lat_s,sppt,sppt_tau,sppt_lscale,sppt_logit, & - iseed_shum,iseed_sppt,shum,shum_tau,& - shum_lscale,stochini,skeb_varspect_opt,sppt_sfclimit, & - skeb,skeb_tau,skeb_vdof,skeb_lscale,iseed_skeb,skeb_vfilt,skeb_diss_smooth, & - skeb_sigtop1,skeb_sigtop2,skebnorm,sppt_sigtop1,sppt_sigtop2,& - shum_sigefold,spptint,shumint,skebint,skeb_npass,use_zmtnblck,new_lscale -write_this_tile=.false. -ntile_out_str='0' -nargs=iargc() -if (nargs.EQ.1) then - call getarg(1,ntile_out_str) -endif -read(ntile_out_str,'(I1.1)') ntile_out -open (unit=nlunit, file='input.nml', READONLY, status='OLD') -read(nlunit,nam_stochy) -close(nlunit) -Model%do_sppt=.false. -Model%do_shum=.false. -Model%do_skeb=.false. -if (sppt(1).GT.0) Model%do_sppt=.true. -if (shum(1).GT.0) Model%do_shum=.true. -if (skeb(1).GT.0) Model%do_skeb=.true. -! define stuff -ng=3 -pi=3.14159265359 -undef=9.99e+20 -p1000=100000.0 -!define mid-layer pressure -rd=287.0 -cp=1004.0 -DO k=1,nlevs - pressi(k)=ak(k)+p1000*bk(k) -ENDDO -ex3d=cp*(pressi/p1000)**(rd/cp) -DO k=1,nlevs - exn = (ex3d(k)*pressi(k)-ex3d(k+1)*pressi(k+1))/((cp+rd)*(pressi(k)-pressi(k+1))) - pressl(k)=p1000*exn**(cp/rd) -ENDDO - -call fms_init() -call mpp_init() -call fms_init -my_id=mpp_pe() -ntasks=mpp_npes() - -call atmosphere_init_stub (grid_box, area) -isd=Atm(1)%bd%isd -ied=Atm(1)%bd%ied -jsd=Atm(1)%bd%jsd -jed=Atm(1)%bd%jed -isc=Atm(1)%bd%isc -iec=Atm(1)%bd%iec -jsc=Atm(1)%bd%jsc -jec=Atm(1)%bd%jec -nx=Atm(1)%npx-1 -ny=Atm(1)%npy-1 -allocate(workg(nx,ny)) -allocate(tile_number(nx,ny)) -allocate(workg3d(nx,ny,nlevs)) -nblks=ny -blksz=nx -Allocate(Model%blksz(nblks)) -Model%blksz(:)=blksz -nthreads = omp_get_num_threads() -Model%me=my_id -Model%phour=0 -Model%kdt=1 -Model%dtp=900 -Model%fn_nml='input.nml' -Model%levs=nlevs -allocate(Init_parm%blksz(nblks)) -Init_parm%blksz(:)=blksz -! setup GFS_init parameters -allocate(Init_parm%ak(nlevs+1)) -allocate(Init_parm%bk(nlevs+1)) -Init_parm%ak=ak -Init_parm%bk=bk -Init_parm%nlunit=21 - -!define model grid -Model%nx=nx -Model%ny=ny -dx=360.0/Model%nx -dy=180.0/Model%ny -allocate(Init_parm%xlon(Model%nx,Model%ny)) -allocate(Init_parm%xlat(Model%nx,Model%ny)) -Init_parm%xlon(:,:)=Atm(1)%gridstruct%agrid(:,:,1) -Init_parm%xlat(:,:)=Atm(1)%gridstruct%agrid(:,:,2) - -allocate(Grid(nblks)) -do i=1,nblks - allocate(Grid(i)%xlat(blksz)) - allocate(Grid(i)%xlon(blksz)) -enddo -do j=1,nblks - Grid(j)%xlat(:)=Init_parm%xlat(:,j) - Grid(j)%xlon(:)=Init_parm%xlon(:,j) -enddo -allocate(grid_xt(nx),grid_yt(ny)) -do i=1,nx - grid_xt(i)=i -enddo -do i=1,ny - grid_yt(i)=i -enddo -!setup GFS_coupling -allocate(Coupling(nblks)) -call init_stochastic_physics(Model, Init_parm, ntasks, nthreads, iret) -if (iret .ne. 0) print *, 'ERROR init_stochastic_physics call' ! Draper - need proper error trapping here -call get_outfile(fname) -write(strid,'(I1.1)') my_id+1 -if (ntile_out.EQ.0) write_this_tile=.true. -if ((my_id+1).EQ.ntile_out) write_this_tile=.true. -print*,trim(fname)//'.tile'//strid//'.nc',write_this_tile -if (write_this_tile) then -fid=30+my_id -!ierr=nf90_create(trim(fname)//'.tile'//strid//'.nc',cmode=NF90_CLOBBER,ncid=ncid) -ierr=nf90_create(trim(fname)//'.tile'//strid//'.nc',cmode=NF90_CLOBBER,ncid=ncid) -ierr=NF90_DEF_DIM(ncid,"grid_xt",nx,xt_dim_id) -ierr=NF90_DEF_DIM(ncid,"grid_yt",ny,yt_dim_id) -if (Model%do_skeb)ierr=NF90_DEF_DIM(ncid,"p_ref",nlevs,zt_dim_id) -ierr=NF90_DEF_DIM(ncid,"time",NF90_UNLIMITED,time_dim_id) - !> - Define the dimension variables. -ierr=NF90_DEF_VAR(ncid,"grid_xt",NF90_FLOAT,(/ xt_dim_id /), xt_var_id) -ierr=NF90_PUT_ATT(ncid,xt_var_id,"long_name","T-cell longitude") -ierr=NF90_PUT_ATT(ncid,xt_var_id,"cartesian_axis","X") -ierr=NF90_PUT_ATT(ncid,xt_var_id,"units","degrees_E") -ierr=NF90_DEF_VAR(ncid,"grid_yt",NF90_FLOAT,(/ yt_dim_id /), yt_var_id) -ierr=NF90_PUT_ATT(ncid,yt_var_id,"long_name","T-cell latitude") -ierr=NF90_PUT_ATT(ncid,yt_var_id,"cartesian_axis","Y") -ierr=NF90_PUT_ATT(ncid,yt_var_id,"units","degrees_N") -ierr=NF90_DEF_VAR(ncid,"grid_lat",NF90_FLOAT,(/ xt_dim_id, yt_dim_id, time_dim_id /), var_id_lat) -ierr=NF90_PUT_ATT(ncid,var_id_lat,"long_name","T-cell latitudes") -ierr=NF90_PUT_ATT(ncid,var_id_lat,"units","degrees_N") -ierr=NF90_PUT_ATT(ncid,var_id_lat,"missing_value",undef) -ierr=NF90_PUT_ATT(ncid,var_id_lat,"_FillValue",undef) -ierr=NF90_DEF_VAR(ncid,"grid_lon",NF90_FLOAT,(/ xt_dim_id, yt_dim_id, time_dim_id /), var_id_lon) -ierr=NF90_PUT_ATT(ncid,var_id_lon,"long_name","T-cell longitudes") -ierr=NF90_PUT_ATT(ncid,var_id_lon,"units","degrees_N") -ierr=NF90_PUT_ATT(ncid,var_id_lon,"missing_value",undef) -ierr=NF90_PUT_ATT(ncid,var_id_lon,"_FillValue",undef) -ierr=NF90_DEF_VAR(ncid,"tile_num",NF90_FLOAT,(/ xt_dim_id, yt_dim_id, time_dim_id /), var_id_tile) -ierr=NF90_PUT_ATT(ncid,var_id_tile,"long_name","tile number") -ierr=NF90_PUT_ATT(ncid,var_id_tile,"missing_value",undef) -ierr=NF90_PUT_ATT(ncid,var_id_tile,"_FillValue",undef) -if (Model%do_skeb)then - ierr=NF90_DEF_VAR(ncid,"p_ref",NF90_FLOAT,(/ zt_dim_id /), zt_var_id) - ierr=NF90_PUT_ATT(ncid,zt_var_id,"long_name","reference pressure") - ierr=NF90_PUT_ATT(ncid,zt_var_id,"cartesian_axis","Z") - ierr=NF90_PUT_ATT(ncid,zt_var_id,"units","Pa") -endif -ierr=NF90_DEF_VAR(ncid,"time",NF90_FLOAT,(/ time_dim_id /), time_var_id) -ierr=NF90_DEF_VAR(ncid,"time",NF90_FLOAT,(/ time_dim_id /), time_var_id) -ierr=NF90_PUT_ATT(ncid,time_var_id,"long_name","time") -ierr=NF90_PUT_ATT(ncid,time_var_id,"units","hours since 2014-08-01 00:00:00") -ierr=NF90_PUT_ATT(ncid,time_var_id,"cartesian_axis","T") -ierr=NF90_PUT_ATT(ncid,time_var_id,"calendar_type","JULIAN") -ierr=NF90_PUT_ATT(ncid,time_var_id,"calendar","JULIAN") -if (Model%do_sppt)then - ierr=NF90_DEF_VAR(ncid,"sppt_wts",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), varid1) - ierr=NF90_PUT_ATT(ncid,varid1,"long_name","sppt pattern") - ierr=NF90_PUT_ATT(ncid,varid1,"units","None") - ierr=NF90_PUT_ATT(ncid,varid1,"missing_value",undef) - ierr=NF90_PUT_ATT(ncid,varid1,"_FillValue",undef) - ierr=NF90_PUT_ATT(ncid,varid1,"cell_methods","time: point") -endif -if (Model%do_shum)then - ierr=NF90_DEF_VAR(ncid,"shum_wts",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), varid2) - ierr=NF90_PUT_ATT(ncid,varid2,"long_name","shum pattern") - ierr=NF90_PUT_ATT(ncid,varid2,"units","None") - ierr=NF90_PUT_ATT(ncid,varid2,"missing_value",undef) - ierr=NF90_PUT_ATT(ncid,varid2,"_FillValue",undef) - ierr=NF90_PUT_ATT(ncid,varid2,"cell_methods","time: point") -endif -if (Model%do_skeb)then - ierr=NF90_DEF_VAR(ncid,"skebu_wts",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,zt_dim_id,time_dim_id/), varid3) - ierr=NF90_DEF_VAR(ncid,"skebv_wts",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,zt_dim_id,time_dim_id/), varid4) - ierr=NF90_PUT_ATT(ncid,varid3,"long_name","skeb u pattern") - ierr=NF90_PUT_ATT(ncid,varid3,"units","None") - ierr=NF90_PUT_ATT(ncid,varid3,"missing_value",undef) - ierr=NF90_PUT_ATT(ncid,varid3,"_FillValue",undef) - ierr=NF90_PUT_ATT(ncid,varid3,"cell_methods","time: point") - ierr=NF90_PUT_ATT(ncid,varid4,"long_name","skeb v pattern") - ierr=NF90_PUT_ATT(ncid,varid4,"units","None") - ierr=NF90_PUT_ATT(ncid,varid4,"missing_value",undef) - ierr=NF90_PUT_ATT(ncid,varid4,"_FillValue",undef) - ierr=NF90_PUT_ATT(ncid,varid4,"cell_methods","time: point") -endif -ierr=NF90_ENDDEF(ncid) -ierr=NF90_PUT_VAR(ncid,xt_var_id,grid_xt) -ierr=NF90_PUT_VAR(ncid,yt_var_id,grid_yt) -if (Model%do_skeb)then - ierr=NF90_PUT_VAR(ncid,zt_var_id,pressl) -endif -endif -! put lat lon and tile number -ierr=NF90_PUT_VAR(ncid,var_id_lon,Init_parm%xlon,(/1,1,1/)) -ierr=NF90_PUT_VAR(ncid,var_id_lat,Init_parm%xlat,(/1,1,1/)) -tile_number=my_id+1 -ierr=NF90_PUT_VAR(ncid,var_id_tile,tile_number,(/1,1,1/)) -do i=1,nblks - if (Model%do_sppt)allocate(Coupling(i)%sppt_wts(blksz,nlevs)) - if (Model%do_shum)allocate(Coupling(i)%shum_wts(blksz,nlevs)) - if (Model%do_skeb)allocate(Coupling(i)%skebu_wts(blksz,nlevs)) - if (Model%do_skeb)allocate(Coupling(i)%skebv_wts(blksz,nlevs)) -enddo -do i=1,200 - Model%kdt=i - ts=i/4.0 - call run_stochastic_physics(Model, Grid, Coupling, nthreads) - if (Model%me.EQ.0) print*,'sppt_wts=',i,Coupling(1)%sppt_wts(1,20) - if (write_this_tile) then - if (Model%do_sppt)then - do j=1,ny - workg(:,j)=Coupling(j)%sppt_wts(:,20) - enddo - ierr=NF90_PUT_VAR(ncid,varid1,workg,(/1,1,i/)) - endif - if (Model%do_shum)then - do j=1,ny - workg(:,j)=Coupling(j)%shum_wts(:,1) - enddo - ierr=NF90_PUT_VAR(ncid,varid2,workg,(/1,1,i/)) - endif - if (Model%do_skeb)then - do k=1,nlevs - do j=1,ny - workg3d(:,j,k)=Coupling(j)%skebu_wts(:,k) - enddo - enddo - ierr=NF90_PUT_VAR(ncid,varid3,workg3d,(/1,1,1,i/)) - do k=1,nlevs - do j=1,ny - workg3d(:,j,k)=Coupling(j)%skebv_wts(:,k) - enddo - enddo - ierr=NF90_PUT_VAR(ncid,varid4,workg3d,(/1,1,1,i/)) - endif - ierr=NF90_PUT_VAR(ncid,time_var_id,ts,(/i/)) - endif -enddo -if (write_this_tile) ierr=NF90_CLOSE(ncid) -end -subroutine get_outfile(fname) -use stochy_namelist_def -character*80,intent(out) :: fname -character*4 :: s_ntrunc,s_lat,s_lon - write(s_ntrunc,'(I4)') ntrunc - write(s_lat,'(I4)') lat_s - write(s_lon,'(I4)') lon_s - fname=trim('workg_T'//trim(adjustl(s_ntrunc))//'_'//trim(adjustl(s_lon))//'x'//trim(adjustl(s_lat))) - return -end diff --git a/standalone_stochy_module.F90 b/standalone_stochy_module.F90 deleted file mode 100644 index 39a67308..00000000 --- a/standalone_stochy_module.F90 +++ /dev/null @@ -1,92 +0,0 @@ -module standalone_stochy_module - -use kinddef -implicit none -public -integer :: isc,jsc,iec,jec,isd,ied,jsd,jed - -type GFS_diag_type - real (kind=kind_phys), allocatable :: ca_out (:) !< cellular automata fraction - real (kind=kind_phys), allocatable :: ca_deep (:) !< cellular automata fraction - real (kind=kind_phys), allocatable :: ca_turb (:) !< cellular automata fraction - real (kind=kind_phys), allocatable :: ca_shal (:) !< cellular automata fraction - real (kind=kind_phys), allocatable :: ca_rad (:) !< cellular automata fraction - real (kind=kind_phys), allocatable :: ca_micro (:) !< cellular automata fraction - real (kind=kind_phys), allocatable :: ca1 (:) - real (kind=kind_phys), allocatable :: ca2 (:) - real (kind=kind_phys), allocatable :: ca3 (:) -end type GFS_diag_type -type GFS_control_type - integer :: levs,me,nx,ny - integer,allocatable :: blksz(:) !< for explicit data blocking: block sizes of all blocks - real(kind=kind_phys) :: dtp !< physics timestep in seconds - real(kind=kind_phys) :: phour !< previous forecast hour - real(kind=kind_phys) :: sppt_amp !< amplitude of sppt (to go to cld scheme) - integer :: kdt !< current forecast iteration - logical :: do_sppt,do_shum,do_skeb,use_zmtnblck,do_rnda - integer :: skeb_npass,n_var_lndp, lndp_type - character(len=65) :: fn_nml !< namelist filename - character(len=256),allocatable :: input_nml_file(:) !< character string containing full namelist - real(kind=kind_phys) :: lndp_prt_list(6) ! max_n_var_lndp, max_nlndp - character(len=3) :: lndp_var_list(6) ! max_n_var_lndp - !---cellular automata control parameters - integer :: nca !< number of independent cellular automata - integer :: nlives !< cellular automata lifetime - integer :: ncells !< cellular automata finer grid - real(kind=kind_phys) :: nfracseed !< cellular automata seed probability - integer :: nseed !< cellular automata seed frequency - logical :: do_ca !< cellular automata main switch - logical :: ca_sgs !< switch for sgs ca - logical :: ca_global !< switch for global ca - logical :: ca_smooth !< switch for gaussian spatial filter - logical :: isppt_deep !< switch for combination with isppt_deep. OBS! Switches off SPPT on other tendencies! - logical :: isppt_pbl - logical :: isppt_shal ! - logical :: pert_flux ! - logical :: pert_trigger ! - integer :: iseed_ca !< seed for random number generation in ca scheme - integer :: ca_amplitude !< seed for random number generation in ca scheme - integer :: nspinup !< number of iterations to spin up the ca - real(kind=kind_phys) :: nthresh !< threshold used for perturbed vertical velocity -end type GFS_control_type - - type GFS_statein_type - real (kind=kind_phys), allocatable :: pgr (:) !< surface pressure (Pa) real - real (kind=kind_phys), allocatable :: qgrs (:,:,:) !< layer mean tracer concentration - real (kind=kind_phys), allocatable :: vvl (:,:) !< layer mean vertical velocity in pa/sec - real (kind=kind_phys), allocatable :: prsl (:,:) !< model layer mean pressure Pa -end type GFS_statein_type - - -type GFS_init_type - integer :: nlunit - real(kind=kind_phys),allocatable :: ak(:),bk(:),xlon(:,:),xlat(:,:) - integer,allocatable :: blksz(:) !< for explicit data blocking: block sizes of all blocks -end type GFS_init_type - -type GFS_grid_type - real (kind=kind_phys),allocatable :: xlat (:) !< grid latitude in radians, default to pi/2 -> - real (kind=kind_phys),allocatable :: xlon (:) !< grid longitude in radians, default to pi/2 -> -end type GFS_grid_type - -type GFS_coupling_type - real (kind=kind_phys),allocatable :: shum_wts (:,:) - real (kind=kind_phys),allocatable :: sppt_wts (:,:) - real (kind=kind_phys),allocatable :: sppt_pattern(:) - real (kind=kind_phys),allocatable :: skebu_wts (:,:) - real (kind=kind_phys),allocatable :: skebv_wts (:,:) - real (kind=kind_phys),allocatable :: sfc_wts (:,:) - real (kind=kind_phys), allocatable :: cape (:) !< cellular automata fraction - real (kind=kind_phys), allocatable :: ca_out (:) !< cellular automata fraction - real (kind=kind_phys), allocatable :: ca_deep (:) !< cellular automata fraction - real (kind=kind_phys), allocatable :: ca_turb (:) !< cellular automata fraction - real (kind=kind_phys), allocatable :: ca_shal (:) !< cellular automata fraction - real (kind=kind_phys), allocatable :: ca_rad (:) !< cellular automata fraction - real (kind=kind_phys), allocatable :: ca_micro (:) !< cellular automata fraction - real (kind=kind_phys), allocatable :: ca1 (:) - real (kind=kind_phys), allocatable :: ca2 (:) - real (kind=kind_phys), allocatable :: ca3 (:) - integer :: n_var_lndp=0 !< number of land sfc variables perturbations -end type GFS_coupling_type -end module standalone_stochy_module - diff --git a/stochastic_physics.F90 b/stochastic_physics.F90 index 67e4033f..28a08419 100644 --- a/stochastic_physics.F90 +++ b/stochastic_physics.F90 @@ -28,8 +28,8 @@ subroutine init_stochastic_physics(levs, blksz, dtp, sppt_amp, input_nml_file_in use stochy_data_mod, only : init_stochdata,gg_lats,gg_lons,nsppt, & rad2deg,INTTYP,wlon,rnlat,gis_stochy,vfact_skeb,vfact_sppt,vfact_shum,skeb_vpts,skeb_vwts,sl use stochy_namelist_def -use spectral_layout_mod,only:me,master,nodes,colrad_a,latg,lonf,skeblevs -use mpi_wrapper, only : mpi_wrapper_initialize,mype,npes,is_master +use spectral_transforms,only:colrad_a,latg,lonf,skeblevs +use mpi_wrapper, only : mpi_wrapper_initialize,mype,npes,is_rootpe implicit none integer, intent(out) :: iret @@ -63,11 +63,8 @@ subroutine init_stochastic_physics(levs, blksz, dtp, sppt_amp, input_nml_file_in ! Initialize MPI and OpenMP call mpi_wrapper_initialize(mpiroot,mpicomm) -me = mype -nodes = npes -master = mpiroot gis_stochy%nodes = npes -gis_stochy%me=me +gis_stochy%mype=mype gis_stochy%nx=maxval(blksz) nblks = size(blksz) gis_stochy%ny=nblks @@ -88,9 +85,8 @@ subroutine init_stochastic_physics(levs, blksz, dtp, sppt_amp, input_nml_file_in ! replace INTTYP=0 ! bilinear interpolation -gis_stochy%me=me -gis_stochy%nodes=nodes call init_stochdata(levs,dtp,input_nml_file_in,fn_nml,nlunit,iret) +print*,'back from init stochdata',iret if (iret .ne. 0) return ! check namelist entries for consistency if (do_sppt_in.neqv.do_sppt) then @@ -111,9 +107,11 @@ subroutine init_stochastic_physics(levs, blksz, dtp, sppt_amp, input_nml_file_in else if (lndp_type_in /= lndp_type) then write(0,'(*(a))') 'Logic error in stochastic_physics_init: incompatible', & & ' namelist settings lndp_type in physics and nam_sfcperts' + print*,'lndp_type',lndp_type_in,lndp_type iret = 20 return else if (n_var_lndp_in /= n_var_lndp) then + print*,'n_var_lndp',n_var_lndp_in , n_var_lndp write(0,'(*(a))') 'Logic error in stochastic_physics_init: incompatible', & & ' namelist settings n_var_lndp in physics nml, and lndp_* in nam_sfcperts' iret = 20 @@ -144,7 +142,7 @@ subroutine init_stochastic_physics(levs, blksz, dtp, sppt_amp, input_nml_file_in vfact_sppt(2)=vfact_sppt(3)*0.5 vfact_sppt(1)=0.0 endif - if (is_master()) then + if (is_rootpe()) then do k=1,levs print *,'sppt vert profile',k,sl(k),vfact_sppt(k) enddo @@ -164,7 +162,7 @@ subroutine init_stochastic_physics(levs, blksz, dtp, sppt_amp, input_nml_file_in else vfact_skeb(k) = 1.0 endif - if (is_master()) print *,'skeb vert profile',k,sl(k),vfact_skeb(k) + if (is_rootpe()) print *,'skeb vert profile',k,sl(k),vfact_skeb(k) enddo ! calculate vertical interpolation weights do k=1,skeblevs @@ -186,7 +184,7 @@ subroutine init_stochastic_physics(levs, blksz, dtp, sppt_amp, input_nml_file_in ENDDO ENDDO deallocate(skeb_vloc) -if (is_master()) then +if (is_rootpe()) then DO k=1,levs print*,'skeb vpts ',skeb_vpts(k,1),skeb_vwts(k,2) ENDDO @@ -202,7 +200,7 @@ subroutine init_stochastic_physics(levs, blksz, dtp, sppt_amp, input_nml_file_in if (sl(k).LT. 2*shum_sigefold) then vfact_shum(k)=0.0 endif - if (is_master()) print *,'shum vert profile',k,sl(k),vfact_shum(k) + if (is_rootpe()) print *,'shum vert profile',k,sl(k),vfact_shum(k) enddo endif ! get interpolation weights @@ -221,7 +219,6 @@ subroutine init_stochastic_physics(levs, blksz, dtp, sppt_amp, input_nml_file_in WLON=gg_lons(1)-(gg_lons(2)-gg_lons(1)) RNLAT=gg_lats(1)*2-gg_lats(2) - end subroutine init_stochastic_physics !!!!!!!!!!!!!!!!!!!! @@ -229,11 +226,11 @@ subroutine init_stochastic_physics_ocn(delt,geoLonT,geoLatT,nx,ny,nz,pert_epbl_i mpiroot, mpicomm, iret) use stochy_data_mod, only : init_stochdata_ocn,gg_lats,gg_lons,& rad2deg,INTTYP,wlon,rnlat,gis_stochy_ocn -use spectral_layout_mod , only : latg,lonf,colrad_a,me,nodes +use spectral_transforms , only : latg,lonf,colrad_a !use MOM_grid, only : ocean_grid_type use stochy_namelist_def use mersenne_twister, only: random_gauss -use mpi_wrapper, only : mpi_wrapper_initialize,mype,npes,is_master +use mpi_wrapper, only : mpi_wrapper_initialize,mype,npes,is_rootpe implicit none real,intent(in) :: delt @@ -248,10 +245,8 @@ subroutine init_stochastic_physics_ocn(delt,geoLonT,geoLatT,nx,ny,nz,pert_epbl_i integer :: k,latghf,km rad2deg=180.0/con_pi call mpi_wrapper_initialize(mpiroot,mpicomm) -me = mype -nodes=npes gis_stochy_ocn%nodes = npes -gis_stochy_ocn%me=me +gis_stochy_ocn%mype = mype gis_stochy_ocn%nx=nx gis_stochy_ocn%ny=ny allocate(gis_stochy_ocn%len(ny)) @@ -312,8 +307,7 @@ subroutine run_stochastic_physics(levs, kdt, fhour, blksz, sppt_wts, shum_wts, s get_random_pattern_sfc use stochy_namelist_def, only : do_shum,do_sppt,do_skeb,nssppt,nsshum,nsskeb,sppt_logit, & lndp_type, n_var_lndp -use mpi_wrapper, only: is_master -use spectral_layout_mod,only:me +use mpi_wrapper, only: is_rootpe implicit none ! Interface variables @@ -335,7 +329,6 @@ subroutine run_stochastic_physics(levs, kdt, fhour, blksz, sppt_wts, shum_wts, s character*120 :: sfile character*6 :: STRFH logical :: do_advance_pattern - if ( (.NOT. do_sppt) .AND. (.NOT. do_shum) .AND. (.NOT. do_skeb) .AND. (lndp_type==0 ) ) return ! Update number of threads in shared variables in spectral_layout_mod and set block-related variables @@ -408,7 +401,6 @@ subroutine run_stochastic_physics(levs, kdt, fhour, blksz, sppt_wts, shum_wts, s sfc_wts(blk,1:len,k) = tmpl_wts(1:len,blk,k) ENDDO ENDDO - if (is_master()) print*,'sfc_wts=',sfc_wts(1,1,:) deallocate(tmpl_wts) endif deallocate(tmp_wts) @@ -458,7 +450,7 @@ subroutine finalize_stochastic_physics() use stochy_data_mod, only : nshum,rpattern_shum,rpattern_sppt,nsppt,rpattern_skeb,nskeb,& vfact_sppt,vfact_shum,vfact_skeb, skeb_vwts,skeb_vpts, & rpattern_sfc, nlndp,gg_lats,gg_lons,sl,skebu_save,skebv_save,gis_stochy -use spectral_layout_mod, only : lat1s_h,lat1s_a ,lon_dims_a,wgt_a,sinlat_a,coslat_a,colrad_a,wgtcs_a,rcs2_a,lats_nodes_h,global_lats_h +use spectral_transforms, only : lat1s_a ,lon_dims_a,wgt_a,sinlat_a,coslat_a,colrad_a,rcs2_a implicit none if (allocated(gg_lats)) deallocate (gg_lats) @@ -487,24 +479,15 @@ subroutine finalize_stochastic_physics() deallocate(lat1s_a) deallocate(lon_dims_a) deallocate(wgt_a) -deallocate(wgtcs_a) deallocate(rcs2_a) deallocate(colrad_a) deallocate(sinlat_a) deallocate(coslat_a) -deallocate(lat1s_h) -deallocate(gis_stochy%lonsperlat) deallocate(gis_stochy%ls_node) deallocate(gis_stochy%ls_nodes) deallocate(gis_stochy%max_ls_nodes) -deallocate(gis_stochy%lats_nodes_a_fix) deallocate(gis_stochy%lats_nodes_a) deallocate(gis_stochy%global_lats_a) -deallocate(gis_stochy%TRIE_LS_SIZE) -deallocate(gis_stochy%TRIO_LS_SIZE) -deallocate(gis_stochy%TRIEO_LS_SIZE) -deallocate(gis_stochy%LS_MAX_NODE_GLOBAL) -deallocate(gis_stochy%LS_NODE_GLOBAL) deallocate(gis_stochy%epse) deallocate(gis_stochy%epso) deallocate(gis_stochy%epsedn) @@ -515,8 +498,6 @@ subroutine finalize_stochastic_physics() deallocate(gis_stochy%snnp1od) deallocate(gis_stochy%plnev_a) deallocate(gis_stochy%plnod_a) -deallocate(gis_stochy%pddev_a) -deallocate(gis_stochy%pddod_a) deallocate(gis_stochy%plnew_a) deallocate(gis_stochy%plnow_a) diff --git a/stochy_data_mod.F90 b/stochy_data_mod.F90 index 9247c4f9..f8448569 100644 --- a/stochy_data_mod.F90 +++ b/stochy_data_mod.F90 @@ -4,15 +4,13 @@ module stochy_data_mod ! set up and initialize stochastic random patterns. - use spectral_layout_mod, only: len_trie_ls,len_trio_ls,ls_dim,ls_max_node,& - skeblevs,levs,jcap,lonf,latg + use spectral_transforms, only: len_trie_ls,len_trio_ls,ls_dim,ls_max_node,& + skeblevs,levs,jcap,lonf,latg,initialize_spectral use stochy_namelist_def use constants_mod, only : radius - use spectral_layout_mod, only : me, nodes - use mpi_wrapper, only: mp_bcst, is_master + use mpi_wrapper, only: mp_bcst, is_rootpe, mype use stochy_patterngenerator_mod, only: random_pattern, patterngenerator_init,& getnoise, patterngenerator_advance,ndimspec,chgres_pattern,computevarspec_r - use initialize_spectral_mod, only: initialize_spectral use stochy_internal_state_mod ! use mersenne_twister_stochy, only : random_seed use mersenne_twister, only : random_seed @@ -33,7 +31,8 @@ module stochy_data_mod real*8, public,allocatable :: sl(:) real(kind=kind_dbl_prec),public, allocatable :: vfact_sppt(:),vfact_shum(:),vfact_skeb(:) - real(kind=kind_dbl_prec),public, allocatable :: skeb_vwts(:,:),skeb_vpts(:,:) + real(kind=kind_dbl_prec),public, allocatable :: skeb_vwts(:,:) + integer ,public, allocatable :: skeb_vpts(:,:) real(kind=kind_dbl_prec),public, allocatable :: gg_lats(:),gg_lons(:) real(kind=kind_dbl_prec),public :: wlon,rnlat,rad2deg real(kind=kind_dbl_prec),public, allocatable :: skebu_save(:,:,:),skebv_save(:,:,:) @@ -47,8 +46,7 @@ module stochy_data_mod subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) !\callgraph -! initialize random patterns. A spinup period of spinup_efolds times the -! temporal time scale is run for each pattern. +! initialize random patterns. use netcdf implicit none integer, intent(in) :: nlunit,nlevs @@ -59,7 +57,7 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) real :: ones(5) real :: rnn1 - integer :: nn,nspinup,k,nm,spinup_efolds,stochlun,ierr,n + integer :: nn,k,nm,stochlun,ierr,n integer :: locl,indev,indod,indlsod,indlsev integer :: l,jbasev,jbasod integer :: jcapin,varid1,varid2 @@ -72,20 +70,13 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) iret=0 ! read in namelist - call compns_stochy (me,size(input_nml_file,1),input_nml_file(:),fn_nml,nlunit,delt,iret) + + call compns_stochy (mype,size(input_nml_file,1),input_nml_file(:),fn_nml,nlunit,delt,iret) + if (iret/=0) return ! need to make sure that non-zero irets are being trapped. - if(is_master()) print*,'in init stochdata',nodes,lat_s if ( (.NOT. do_sppt) .AND. (.NOT. do_shum) .AND. (.NOT. do_skeb) .AND. (lndp_type==0) ) return -! initialize the specratl pattern generatore (including gaussian grid decomposition) -! if (nodes.GE.lat_s/2) then -! lat_s=(int(nodes/12)+1)*24 -! lon_s=lat_s*2 -! ntrunc=lat_s-2 -! if (is_master()) print*,'WARNING: spectral resolution is too low for number of mpi_tasks, resetting lon_s,lat_s,and ntrunc to',lon_s,lat_s,ntrunc -! endif - - call initialize_spectral(gis_stochy, iret) - if (iret/=0) return + call initialize_spectral(gis_stochy) + allocate(noise_e(len_trie_ls,2),noise_o(len_trio_ls,2)) ! determine number of random patterns to be used for each scheme. do n=1,size(sppt) @@ -95,7 +86,7 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) exit endif enddo - if (is_master()) print *,'nsppt = ',nsppt + if (is_rootpe()) print *,'nsppt = ',nsppt do n=1,size(shum) if (shum(n) > 0) then nshum=nshum+1 @@ -103,7 +94,7 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) exit endif enddo - if (is_master()) print *,'nshum = ',nshum + if (is_rootpe()) print *,'nshum = ',nshum do n=1,size(skeb) if (skeb(n) > 0) then nskeb=nskeb+1 @@ -111,7 +102,7 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) exit endif enddo - if (is_master()) print *,'nskeb = ',nskeb + if (is_rootpe()) print *,'nskeb = ',nskeb ! Draper: nlndp>1 was not properly coded. Hardcode to 1 for now !do n=1,size(lndp_z0) ! if (lndp_z0(n) > 0 .or. lndp_zt(n)>0 .or. lndp_hc(n)>0 .or. & @@ -122,7 +113,7 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) ! endif !enddo if (n_var_lndp>0) nlndp=1 - if (is_master()) print *,' nlndp = ', nlndp + if (is_rootpe()) print *,' nlndp = ', nlndp if (nsppt > 0) allocate(rpattern_sppt(nsppt)) if (nshum > 0) allocate(rpattern_shum(nshum)) @@ -131,7 +122,7 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) if (nlndp > 0) allocate(rpattern_sfc(nlndp)) ! if stochini is true, then read in pattern from a file - if (is_master()) then + if (is_rootpe()) then if (stochini) then print*,'opening stoch_ini' !OPEN(stochlun,file='INPUT/atm_stoch.res.bin',form='unformatted',iostat=ierr,status='old') @@ -151,9 +142,8 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) endif endif ! no spinup needed if initial patterns are defined correctly. - spinup_efolds = 0 if (nsppt > 0) then - if (is_master()) then + if (is_rootpe()) then print *, 'Initialize random pattern for SPPT' if (stochini) then ierr=NF90_INQ_VARID(stochlun,"sppt_seed", varid1) @@ -170,10 +160,10 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) end if endif endif + print*,'calling init',lonf,latg,jcap call patterngenerator_init(sppt_lscale(1:nsppt),spptint,sppt_tau(1:nsppt),sppt(1:nsppt),iseed_sppt,rpattern_sppt, & lonf,latg,jcap,gis_stochy%ls_node,nsppt,1,0,new_lscale) do n=1,nsppt - nspinup = spinup_efolds*sppt_tau(n)/spptint if (stochini) then call read_pattern(rpattern_sppt(n),jcapin,stochlun,1,n,varid1,varid2,.false.,ierr) if (ierr .NE. 0) then @@ -199,14 +189,11 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) rpattern_sppt(n)%spec_o(nn,1,1) = rpattern_sppt(n)%stdev*rpattern_sppt(n)%spec_o(nn,1,1)*rpattern_sppt(n)%varspectrum(nm) rpattern_sppt(n)%spec_o(nn,2,1) = rpattern_sppt(n)%stdev*rpattern_sppt(n)%spec_o(nn,2,1)*rpattern_sppt(n)%varspectrum(nm) enddo - do nn=1,nspinup - call patterngenerator_advance(rpattern_sppt(n),1,.false.) - enddo endif enddo endif if (nshum > 0) then - if (is_master()) then + if (is_rootpe()) then print *, 'Initialize random pattern for SHUM' if (stochini) then ierr=NF90_INQ_VARID(stochlun,"shum_seed", varid1) @@ -226,7 +213,6 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) call patterngenerator_init(shum_lscale(1:nshum),shumint,shum_tau(1:nshum),shum(1:nshum),iseed_shum,rpattern_shum, & lonf,latg,jcap,gis_stochy%ls_node,nshum,1,0,new_lscale) do n=1,nshum - nspinup = spinup_efolds*shum_tau(n)/shumint if (stochini) then call read_pattern(rpattern_shum(n),jcapin,stochlun,1,n,varid1,varid2,.false.,ierr) if (ierr .NE. 0) then @@ -252,9 +238,6 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) rpattern_shum(n)%spec_o(nn,1,1) = rpattern_shum(n)%stdev*rpattern_shum(n)%spec_o(nn,1,1)*rpattern_shum(n)%varspectrum(nm) rpattern_shum(n)%spec_o(nn,2,1) = rpattern_shum(n)%stdev*rpattern_shum(n)%spec_o(nn,2,1)*rpattern_shum(n)%varspectrum(nm) enddo - do nn=1,nspinup - call patterngenerator_advance(rpattern_shum(n),1,.false.) - enddo endif enddo endif @@ -263,7 +246,7 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) ! determine number of skeb levels to deal with temperoal/vertical correlations skeblevs=nint(skeb_tau(1)/skebint*skeb_vdof) ! backscatter noise. - if (is_master()) then + if (is_rootpe()) then print *, 'Initialize random pattern for SKEB' if (stochini) then ierr=NF90_INQ_VARID(stochlun,"skeb_seed", varid1) @@ -284,7 +267,6 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) lonf,latg,jcap,gis_stochy%ls_node,nskeb,skeblevs,skeb_varspect_opt,new_lscale) do n=1,nskeb do k=1,skeblevs - nspinup = spinup_efolds*skeb_tau(n)/skebint if (stochini) then call read_pattern(rpattern_skeb(n),jcapin,stochlun,k,n,varid1,varid2,.true.,ierr) if (ierr .NE. 0) then @@ -312,19 +294,16 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) enddo endif enddo - do nn=1,nspinup - call patterngenerator_advance(rpattern_skeb(n),skeblevs,.false.) - enddo enddo gis_stochy%kenorm_e=1. gis_stochy%kenorm_o=1. ! used to convert forcing pattern to wind field. if (skebnorm==0) then do locl=1,ls_max_node - l = gis_stochy%ls_node(locl) - jbasev = gis_stochy%ls_node(locl+ls_dim) + l = gis_stochy%ls_node(locl,1) + jbasev = gis_stochy%ls_node(locl,2) indev = indlsev(l,l) - jbasod = gis_stochy%ls_node(locl+2*ls_dim) + jbasod = gis_stochy%ls_node(locl,3) indod = indlsod(l+1,l) do n=l,jcap,2 rnn1 = n*(n+1.) @@ -337,14 +316,14 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) indod = indod + 1 enddo enddo - if (is_master()) print*,'using streamfunction ',maxval(gis_stochy%kenorm_e(:)),minval(gis_stochy%kenorm_e(:)) + if (is_rootpe()) print*,'using streamfunction ',maxval(gis_stochy%kenorm_e(:)),minval(gis_stochy%kenorm_e(:)) endif if (skebnorm==1) then do locl=1,ls_max_node - l = gis_stochy%ls_node(locl) - jbasev = gis_stochy%ls_node(locl+ls_dim) + l = gis_stochy%ls_node(locl,1) + jbasev = gis_stochy%ls_node(locl,2) indev = indlsev(l,l) - jbasod = gis_stochy%ls_node(locl+2*ls_dim) + jbasod = gis_stochy%ls_node(locl,3) indod = indlsod(l+1,l) do n=l,jcap,2 rnn1 = n*(n+1.) @@ -357,13 +336,13 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) indod = indod + 1 enddo enddo - if (is_master()) print*,'using kenorm ',maxval(gis_stochy%kenorm_e(:)),minval(gis_stochy%kenorm_e(:)) + if (is_rootpe()) print*,'using kenorm ',maxval(gis_stochy%kenorm_e(:)),minval(gis_stochy%kenorm_e(:)) endif ! set the even and odd (n-l) terms of the top row to zero do locl=1,ls_max_node - l = gis_stochy%ls_node(locl) - jbasev = gis_stochy%ls_node(locl+ls_dim) - jbasod = gis_stochy%ls_node(locl+2*ls_dim) + l = gis_stochy%ls_node(locl,1) + jbasev = gis_stochy%ls_node(locl,2) + jbasod = gis_stochy%ls_node(locl,3) if (mod(l,2) .eq. mod(jcap+1,2)) then gis_stochy%kenorm_e(indlsev(jcap+1,l)) = 0. endif @@ -375,7 +354,7 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) endif ! skeb > 0 ! mg, sfc-perts if (nlndp > 0) then - if (is_master()) then + if (is_rootpe()) then print *, 'Initialize random pattern for SFC-PERTS' if (stochini) then ierr=NF90_INQ_VARID(stochlun,"sfcpert_seed", varid1) @@ -396,9 +375,8 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) call patterngenerator_init(lndp_lscale(1:nlndp),delt,lndp_tau(1:nlndp),ones(1:nlndp),iseed_lndp,rpattern_sfc, & lonf,latg,jcap,gis_stochy%ls_node,nlndp,n_var_lndp,0,new_lscale) do n=1,nlndp - if (is_master()) print *, 'Initialize random pattern for LNDP PERTS' + if (is_rootpe()) print *, 'Initialize random pattern for LNDP PERTS' do k=1,n_var_lndp - nspinup = spinup_efolds*lndp_tau(n)/delt if (stochini) then call read_pattern(rpattern_sfc(n),jcapin,stochlun,k,n,varid1,varid2,.true.,ierr) if (ierr .NE. 0) then @@ -406,7 +384,7 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) iret = ierr return endif - if (is_master()) print *, 'lndp pattern read',n,k,minval(rpattern_sfc(n)%spec_o(:,:,k)), maxval(rpattern_sfc(n)%spec_o(:,:,k)) + if (is_rootpe()) print *, 'lndp pattern read',n,k,minval(rpattern_sfc(n)%spec_o(:,:,k)), maxval(rpattern_sfc(n)%spec_o(:,:,k)) else call getnoise(rpattern_sfc(n),noise_e,noise_o) do nn=1,len_trie_ls @@ -425,15 +403,12 @@ subroutine init_stochdata(nlevs,delt,input_nml_file,fn_nml,nlunit,iret) rpattern_sfc(n)%spec_o(nn,1,k) = rpattern_sfc(n)%stdev*rpattern_sfc(n)%spec_o(nn,1,k)*rpattern_sfc(n)%varspectrum(nm) rpattern_sfc(n)%spec_o(nn,2,k) = rpattern_sfc(n)%stdev*rpattern_sfc(n)%spec_o(nn,2,k)*rpattern_sfc(n)%varspectrum(nm) enddo - do nn=1,nspinup - call patterngenerator_advance(rpattern_sfc(n),k,.false.) - enddo - if (is_master()) print *, 'lndp pattern initialized, ',n, k, minval(rpattern_sfc(n)%spec_o(:,:,k)), maxval(rpattern_sfc(n)%spec_o(:,:,k)) + if (is_rootpe()) print *, 'lndp pattern initialized, ',n, k, minval(rpattern_sfc(n)%spec_o(:,:,k)), maxval(rpattern_sfc(n)%spec_o(:,:,k)) endif ! stochini enddo ! k, n_var_lndp enddo ! n, nlndp endif ! nlndp > 0 - if (is_master() .and. stochini) CLOSE(stochlun) + if (is_rootpe() .and. stochini) CLOSE(stochlun) deallocate(noise_e,noise_o) end subroutine init_stochdata @@ -461,9 +436,9 @@ subroutine init_stochdata_ocn(nlevs,delt,iret) iret=0 call compns_stochy_ocn (delt,iret) - if(is_master()) print*,'in init stochdata_ocn' + if(is_rootpe()) print*,'in init stochdata_ocn' if ( (.NOT. pert_epbl) .AND. (.NOT. do_ocnsppt) ) return - call initialize_spectral(gis_stochy_ocn, iret) + call initialize_spectral(gis_stochy_ocn) if (iret/=0) return allocate(noise_e(len_trie_ls,2),noise_o(len_trio_ls,2)) ! determine number of random patterns to be used for each scheme. @@ -491,7 +466,7 @@ subroutine init_stochdata_ocn(nlevs,delt,iret) if (nocnsppt > 0) allocate(rpattern_ocnsppt(nocnsppt)) ! if stochini is true, then read in pattern from a file - if (is_master()) then + if (is_rootpe()) then if (stochini) then print*,'opening stoch_ini' ierr=nf90_open('INPUT/ocn_stoch.res.nc',nf90_nowrite,ncid=stochlun) @@ -511,7 +486,7 @@ subroutine init_stochdata_ocn(nlevs,delt,iret) endif if (nepbl > 0) then - if (is_master()) then + if (is_rootpe()) then print *, 'Initialize random pattern for epbl' if (stochini) then ierr=NF90_INQ_VARID(stochlun,"epbl1_seed", varid1) @@ -605,7 +580,7 @@ subroutine init_stochdata_ocn(nlevs,delt,iret) endif if (nocnsppt > 0) then - if (is_master()) then + if (is_rootpe()) then if (stochini) then ierr=NF90_INQ_VARID(stochlun,"ocnsppt_seed", varid1) if (ierr .NE. 0) then @@ -621,7 +596,7 @@ subroutine init_stochdata_ocn(nlevs,delt,iret) end if endif endif - if (is_master()) print *, 'Initialize random pattern for ocnsppt' + if (is_rootpe()) print *, 'Initialize random pattern for ocnsppt' call patterngenerator_init(ocnsppt_lscale(1:nocnsppt),ocnspptint,ocnsppt_tau(1:nocnsppt),ocnsppt(1:nocnsppt),iseed_ocnsppt,rpattern_ocnsppt, & lonf,latg,jcap,gis_stochy_ocn%ls_node,nocnsppt,1,0,new_lscale) do n=1,nocnsppt @@ -679,7 +654,7 @@ subroutine read_pattern(rpattern,jcapin,lunptn,k,np,varid1,varid2,slice_of_3d,ir call random_seed(size=isize,stat=rpattern%rstate) ! get size of generator state seed array allocate(isave(isize)) ! read only on root process, and send to all tasks - if (is_master()) then + if (is_rootpe()) then allocate(pattern2din((jcapin+1)*(jcapin+2))) print*,'reading in random pattern at ',jcapin,ndimspec,size(pattern2din) !read(lunptn) pattern2din @@ -730,7 +705,7 @@ subroutine read_pattern(rpattern,jcapin,lunptn,k,np,varid1,varid2,slice_of_3d,ir rpattern%spec_o(nn,1,k) = pattern2d(nm) rpattern%spec_o(nn,2,k) = pattern2d(ndimspec+nm) enddo - !print*,'after scatter...',me,maxval(pattern2d_e),maxval(pattern2d_o) & + !print*,'after scatter...',mype,maxval(pattern2d_e),maxval(pattern2d_o) & ! ,minval(pattern2d_e),minval(pattern2d_o) deallocate(pattern2d,isave) end subroutine read_pattern diff --git a/stochy_internal_state_mod.F90 b/stochy_internal_state_mod.F90 index 9cd774d0..cbd8c443 100644 --- a/stochy_internal_state_mod.F90 +++ b/stochy_internal_state_mod.F90 @@ -19,7 +19,7 @@ module stochy_internal_state_mod !!uses: !------ - use spectral_layout_mod +! use spectral_layout_mod implicit none @@ -29,28 +29,15 @@ module stochy_internal_state_mod type,public::stochy_internal_state ! start type define ! ----------------------------------------------- - integer :: nodes - -! - integer lonf,latg,lats_node_a_max - - integer npe_single_member - - character(16) :: cfhour1 -!jws - integer :: num_file - character(32) ,allocatable :: filename_base(:) - integer :: ipt_lats_node_a + integer :: nodes integer :: lats_node_a - integer :: me -!jwe - - integer :: nblck,kdt -! real :: deltim + integer :: mype + integer :: lon_dim_a + integer :: lats_dim_a + integer :: ipt_lats_node_a - integer ,allocatable :: lonsperlat (:) - integer ,allocatable :: ls_node (:) - integer ,allocatable :: ls_nodes (:, :) + integer ,allocatable :: ls_node (:,:) + integer ,allocatable :: ls_nodes (:,:) integer ,allocatable :: max_ls_nodes (:) integer ,allocatable :: lats_nodes_a (:) @@ -58,8 +45,6 @@ module stochy_internal_state_mod integer ,allocatable :: global_lats_h (:) integer :: xhalo,yhalo - integer ,allocatable :: lats_nodes_a_fix (:) - real,allocatable :: epse (:) real,allocatable :: epso (:) real,allocatable :: epsedn(:) @@ -72,8 +57,6 @@ module stochy_internal_state_mod real,allocatable :: plnev_a(:,:) real,allocatable :: plnod_a(:,:) - real,allocatable :: pddev_a(:,:) - real,allocatable :: pddod_a(:,:) real,allocatable :: plnew_a(:,:) real,allocatable :: plnow_a(:,:) @@ -81,27 +64,10 @@ module stochy_internal_state_mod real,allocatable :: trie_ls(:,:,:) real,allocatable :: trio_ls(:,:,:) - INTEGER :: TRIEO_TOTAL_SIZE - INTEGER, ALLOCATABLE, DIMENSION(:) :: TRIE_LS_SIZE - INTEGER, ALLOCATABLE, DIMENSION(:) :: TRIO_LS_SIZE - INTEGER, ALLOCATABLE, DIMENSION(:) :: TRIEO_LS_SIZE - INTEGER, ALLOCATABLE, DIMENSION(:) :: LS_MAX_NODE_GLOBAL - INTEGER, ALLOCATABLE, DIMENSION(:, :) :: LS_NODE_GLOBAL - - -! - -!! - integer init,jpt,node,ibmsign,lon_dim - integer lotls - -! integer jdt,ksout,maxstp -! integer mdt,idt -! integer mods,n1,n2,ndgf,ndgi,nfiles,nflps integer nlunit - integer iret,ierr,iprint,k,l,locl,n + integer k,l,locl,n integer lan,lat integer nx,ny,nz integer, allocatable :: len(:) diff --git a/stochy_namelist_def.F90 b/stochy_namelist_def.F90 index adc3f022..b9d0ca22 100644 --- a/stochy_namelist_def.F90 +++ b/stochy_namelist_def.F90 @@ -27,14 +27,14 @@ module stochy_namelist_def real(kind=kind_dbl_prec), dimension(5) :: epbl,epbl_lscale,epbl_tau real(kind=kind_dbl_prec), dimension(5) :: ocnsppt,ocnsppt_lscale,ocnsppt_tau integer,dimension(5) ::skeb_vfilt - integer(8),dimension(5) ::iseed_sppt,iseed_shum,iseed_skeb,iseed_epbl,iseed_ocnsppt,iseed_epbl2 + integer(kind=kind_dbl_prec),dimension(5) ::iseed_sppt,iseed_shum,iseed_skeb,iseed_epbl,iseed_ocnsppt,iseed_epbl2 logical stochini,sppt_logit,new_lscale logical use_zmtnblck logical do_shum,do_sppt,do_skeb,pert_epbl,do_ocnsppt real(kind=kind_dbl_prec), dimension(5) :: lndp_lscale,lndp_tau integer n_var_lndp - integer(8),dimension(5) ::iseed_lndp + integer(kind=kind_dbl_prec),dimension(5) ::iseed_lndp integer lndp_type character(len=3), dimension(max_n_var_lndp) :: lndp_var_list real(kind=kind_dbl_prec), dimension(max_n_var_lndp) :: lndp_prt_list diff --git a/stochy_patterngenerator.F90 b/stochy_patterngenerator.F90 index ec41d4f3..7060765a 100644 --- a/stochy_patterngenerator.F90 +++ b/stochy_patterngenerator.F90 @@ -5,11 +5,11 @@ module stochy_patterngenerator_mod !> generate random patterns with specified temporal and spatial auto-correlation !! in spherical harmonic space. use kinddef - use spectral_layout_mod, only: len_trie_ls, len_trio_ls, ls_dim, ls_max_node + use spectral_transforms, only: len_trie_ls, len_trio_ls, ls_dim, ls_max_node ! use mersenne_twister_stochy, only: random_setseed,random_gauss,random_stat use mersenne_twister, only: random_setseed,random_gauss,random_stat ! DH* replacing this with mpi_wrapper changes results - look for value of iseed? - use mpi_wrapper,only: is_master, mp_bcst + use mpi_wrapper,only: is_rootpe, mp_bcst ! *DH implicit none private @@ -48,13 +48,13 @@ module stochy_patterngenerator_mod !>@details It populates array defining the zonal and total wavenumbers, amplitude, !! temporaral and spatial correlations. subroutine patterngenerator_init(lscale, delt, tscale, stdev, iseed, rpattern,& - nlon, nlat, jcap, ls_node, npatterns,& + nlon, nlat, jcap, ls_nodes, npatterns,& nlevs, varspect_opt,new_lscale) !\callgraph real(kind_dbl_prec), intent(in),dimension(npatterns) :: lscale,tscale,stdev real, intent(in) :: delt integer, intent(in) :: nlon,nlat,jcap,npatterns,varspect_opt - integer, intent(in) :: ls_node(ls_dim,3),nlevs + integer, intent(in) :: ls_nodes(ls_dim,3),nlevs logical, intent(in) :: new_lscale type(random_pattern), intent(out), dimension(npatterns) :: rpattern integer(8), intent(inout) :: iseed(npatterns) @@ -96,9 +96,9 @@ subroutine patterngenerator_init(lscale, delt, tscale, stdev, iseed, rpattern,& enddo enddo do j = 1, ls_max_node - l=ls_node(j,1) ! zonal wavenumber - jbasev=ls_node(j,2) - jbasod=ls_node(j,3) + l=ls_nodes(j,1) ! zonal wavenumber + jbasev=ls_nodes(j,2) + jbasod=ls_nodes(j,3) indev1 = indlsev(l,l) indod1 = indlsod(l+1,l) if (mod(l,2) .eq. mod(ntrunc+1,2)) then @@ -126,7 +126,6 @@ subroutine patterngenerator_init(lscale, delt, tscale, stdev, iseed, rpattern,& enddo enddo allocate(rpattern(np)%degree(ndimspec),rpattern(np)%order(ndimspec),rpattern(np)%lap(ndimspec)) -#ifdef __GFORTRAN__ j = 0 do m=0,ntrunc do n=m,ntrunc @@ -135,10 +134,6 @@ subroutine patterngenerator_init(lscale, delt, tscale, stdev, iseed, rpattern,& rpattern(np)%order(j) = m end do end do -#else - rpattern(np)%degree = (/((n,n=m,ntrunc),m=0,ntrunc)/) - rpattern(np)%order = (/((m,n=m,ntrunc),m=0,ntrunc)/) -#endif rpattern(np)%lap = -rpattern(np)%degree*(rpattern(np)%degree+1.0) rpattern(np)%tau = tscale(np) rpattern(np)%lengthscale = lscale(np) @@ -148,7 +143,7 @@ subroutine patterngenerator_init(lscale, delt, tscale, stdev, iseed, rpattern,& allocate(rpattern(np)%varspectrum(ndimspec)) allocate(rpattern(np)%varspectrum1d(0:ntrunc)) ! seed computed on root, then bcast to all tasks and set. - if (is_master()) then + if (is_rootpe()) then ! read(ens_nam(2:3),'(i2)') member_id ! print *,'ens_nam,member_id',trim(ens_nam),member_id if (iseed(np) == 0) then @@ -174,7 +169,7 @@ subroutine patterngenerator_init(lscale, delt, tscale, stdev, iseed, rpattern,& ! set seed (to be the same) on all tasks. Save random state. call random_setseed(rpattern(np)%seed,rpattern(np)%rstate) if (varspect_opt .ne. 0 .and. varspect_opt .ne. 1) then - if (is_master()) then + if (is_rootpe()) then print *,'WARNING: illegal value for varspect_opt (should be 0 or 1), using 0 (gaussian spectrum)...' endif call setvarspect(rpattern(np),0,new_lscale) diff --git a/sumfln_stochy.f b/sumfln_stochy.f deleted file mode 100644 index f4bd783f..00000000 --- a/sumfln_stochy.f +++ /dev/null @@ -1,278 +0,0 @@ -!>@brief The module 'sumfln_stochy_mod' contains the subroutine sumfln_stochy - module sumfln_stochy_mod - - implicit none - - contains - -!>@brief The subrountine 'sumfln_stochy' converts the spherical harmonics to fourier coefficients -!>@details This code is taken from the legacy spectral GFS - subroutine sumfln_stochy(flnev,flnod,lat1s,plnev,plnod, - & nvars,ls_node,latl2, - & workdim,nvarsdim,four_gr, - & ls_nodes,max_ls_nodes, - & lats_nodes,global_lats, - & lats_node,ipt_lats_node, - & lons_lat,londi,latl,nvars_0) -! - use spectral_layout_mod , only : len_trie_ls,len_trio_ls, - & ls_dim,ls_max_node,me, - & nodes,jcap - use kinddef - use mpi_wrapper, only : mp_alltoall - - implicit none -! - external esmf_dgemm -! - integer lat1s(0:jcap),latl2 -! - integer nvars,nvars_0 - integer :: npes - real(kind=kind_dbl_prec) flnev(len_trie_ls,2*nvars) - real(kind=kind_dbl_prec) flnod(len_trio_ls,2*nvars) -! - real(kind=kind_dbl_prec) plnev(len_trie_ls,latl2) - real(kind=kind_dbl_prec) plnod(len_trio_ls,latl2) -! - integer ls_node(ls_dim,3) -! -!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L -!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev -!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod -! -! local scalars -! ------------- -! - integer j, l, lat, lat1, n, kn, n2,indev,indod -! -! local arrays -! ------------ -! - real(kind=kind_dbl_prec), dimension(nvars*2,latl2) :: apev, apod -! xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -! - integer nvarsdim, latl, workdim, londi - &, lats_node, ipt_lats_node -! - real(kind=kind_dbl_prec) four_gr(londi,nvarsdim,workdim) -! - integer ls_nodes(ls_dim,nodes) - integer, dimension(nodes) :: max_ls_nodes, lats_nodes - integer, dimension(latl) :: global_lats, lons_lat - -!jfe integer global_lats(latg+2*jintmx+2*nypt*(nodes-1)) -! - real(kind=4),target,dimension(2,nvars,ls_dim*workdim,nodes):: - & workr,works -! real(kind=4),dimension(2*nvars*ls_dim*workdim*nodes):: -! & work1dr,work1ds - real(kind=4),pointer:: work1dr(:),work1ds(:) - integer, dimension(nodes) :: kpts, kptr, sendcounts, recvcounts, - & sdispls -! - integer ilat,ipt_ls, lmax,lval,jj,lonl,nv - integer node,nvar,arrsz,my_pe - integer ilat_list(nodes) ! for OMP buffer copy -! -! statement functions -! ------------------- -! - integer indlsev, jbasev, indlsod, jbasod -! - include 'function_indlsev' - include 'function_indlsod' -! - real(kind=kind_dbl_prec), parameter :: cons0=0.0d0, cons1=1.0d0 -! -! xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -! - arrsz=2*nvars*ls_dim*workdim*nodes - kpts = 0 -! write(0,*)' londi=',londi,'nvarsdim=',nvarsdim,'workdim=',workdim -! - do j = 1, ls_max_node ! start of do j loop ##################### -! - l = ls_node(j,1) - jbasev = ls_node(j,2) - jbasod = ls_node(j,3) - - indev = indlsev(l,l) - indod = indlsod(l+1,l) -! - lat1 = lat1s(l) - if ( kind_dbl_prec == 8 ) then !------------------------------------ - - n2 = 2*nvars - -! compute the even and odd components of the fourier coefficients -! -! compute the sum of the even real terms for each level -! compute the sum of the even imaginary terms for each level -! -! call dgemm('t','n',latl2-lat1+1, 2*(nvar_2-nvar_1+1), -! & (jcap+2-l)/2,cons1, !constant -! & plnev(indev,lat1), len_trio_ls, -! & flnev(indev,2*nvar_1-1),len_trio_ls,cons0, -! & apev(2*nvar_1-1,lat1),latl2) - call esmf_dgemm( - & 't', - & 'n', - & n2, - & latl2-lat1+1, - & (jcap+3-l)/2, - & cons1, - & flnev(indev,1), - & len_trie_ls, - & plnev(indev,lat1), - & len_trie_ls, - & cons0, - & apev(1,lat1), - & 2*nvars - & ) -! -! compute the sum of the odd real terms for each level -! compute the sum of the odd imaginary terms for each level -! -! call dgemm('t','n',latl2-lat1+1, 2*(nvar_2-nvar_1+1), -! & (jcap+2-l)/2,cons1, !constant -! & plnod(indod,lat1), len_trio_ls, -! & flnod(indod,2*nvar_1-1),len_trio_ls,cons0, -! & apod(2*nvar_1-1,lat1), latl2) - call esmf_dgemm( - & 't', - & 'n', - & n2, - & latl2-lat1+1, - & (jcap+2-l)/2, - & cons1, - & flnod(indod,1), - & len_trio_ls, - & plnod(indod,lat1), - & len_trio_ls, - & cons0, - & apod(1,lat1), - & 2*nvars - & ) -! - endif -! -ccxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx -! -! compute the fourier coefficients for each level -! ----------------------------------------------- -! - ilat_list(1) = 0 - do node = 1, nodes - 1 - ilat_list(node+1) = ilat_list(node) + lats_nodes(node) - end do -!$omp parallel do private(node,jj,ilat,lat,ipt_ls,nvar,kn,n2) - do node=1,nodes - do jj=1,lats_nodes(node) - ilat = ilat_list(node) + jj - lat = global_lats(ilat) - ipt_ls = min(lat,latl-lat+1) - if ( ipt_ls >= lat1s(ls_nodes(j,me+1)) ) then - kpts(node) = kpts(node) + 1 - kn = kpts(node) -! - if ( lat <= latl2 ) then -! northern hemisphere - do nvar=1,nvars - n2 = nvar + nvar - works(1,nvar,kn,node) = apev(n2-1,ipt_ls) - & + apod(n2-1,ipt_ls) - works(2,nvar,kn,node) = apev(n2, ipt_ls) - & + apod(n2, ipt_ls) - enddo - else -! southern hemisphere - do nvar=1,nvars - n2 = nvar + nvar - works(1,nvar,kn,node) = apev(n2-1,ipt_ls) - & - apod(n2-1,ipt_ls) - works(2,nvar,kn,node) = apev(n2, ipt_ls) - & - apod(n2, ipt_ls) - enddo - endif - endif - enddo - enddo -! - enddo ! end of do j loop ####################################### -! - kptr = 0 - do node=1,nodes - do l=1,max_ls_nodes(node) - lval = ls_nodes(l,node)+1 - do j=1,lats_node - lat = global_lats(ipt_lats_node-1+j) - if ( min(lat,latl-lat+1) >= lat1s(lval-1) ) then - kptr(node) = kptr(node) + 1 - endif - enddo - enddo - enddo -! -! - n2 = nvars + nvars -!$omp parallel do private(node) - do node=1,nodes - sendcounts(node) = kpts(node) * n2 - recvcounts(node) = kptr(node) * n2 - sdispls(node) = (node-1) * n2 * ls_dim * workdim - end do - work1dr(1:arrsz)=>workr - work1ds(1:arrsz)=>works - call mp_alltoall(work1ds, sendcounts, sdispls, - & work1dr,recvcounts,sdispls) - nullify(work1dr) - nullify(work1ds) -!$omp parallel do private(j,lat,lmax,nvar,lval,n2,lonl,nv) - do j=1,lats_node - lat = global_lats(ipt_lats_node-1+j) - lonl = lons_lat(lat) - lmax = min(jcap,lonl/2) - n2 = lmax + lmax + 3 -! write(0,*)' j=',j,' lat=',lat,' lmax=',lmax,' n2=',n2 -! &,' nvars=',nvars,' lonl=',lonl - if ( n2 <= lonl+2 ) then - do nvar=1,nvars - nv = nvars_0 + nvar - do lval = n2, lonl+2 -! write(0,*)' lval=',lval,' nvar=',nvar,nvars_0 -! &,' n2=',n2,' lonl=',lonl,' nv=',nv,' j=',j -! &,'size=',size(four_gr,1),size(four_gr,2),size(four_gr,3) - four_gr(lval,nv,j) = cons0 - enddo - enddo - endif - enddo -! - kptr = 0 -! write(0,*)' kptr=',kptr(1) -!! -!$omp parallel do private(node,l,lval,j,lat,nvar,kn,n2) - do node=1,nodes - do l=1,max_ls_nodes(node) - lval = ls_nodes(l,node)+1 - n2 = lval + lval - do j=1,lats_node - lat = global_lats(ipt_lats_node-1+j) - if ( min(lat,latl-lat+1) >= lat1s(lval-1) ) then - kptr(node) = kptr(node) + 1 - kn = kptr(node) - - do nvar=1,nvars - four_gr(n2-1,nvars_0+nvar,j) = workr(1,nvar,kn,node) - four_gr(n2, nvars_0+nvar,j) = workr(2,nvar,kn,node) - enddo - endif - enddo - enddo - enddo -! - return - end subroutine sumfln_stochy - - end module sumfln_stochy_mod diff --git a/unit_tests/atmosphere_stub.F90 b/unit_tests/atmosphere_stub.F90 new file mode 100644 index 00000000..e2b22cbf --- /dev/null +++ b/unit_tests/atmosphere_stub.F90 @@ -0,0 +1,392 @@ + +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +!>@brief The module 'atmosphere' provides the interface for the +!! Cubed-Sphere FV dynamical core + +module atmosphere_stub_mod + +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +!
Module NameFunctions Included
block_control_modblock_control_type
constants_modcp_air, rdgas, grav, rvgas, kappa, pstd_mks
field_manager_modMODEL_ATMOS
fms_modfile_exist, open_namelist_file,close_file, error_mesg, FATAL, +! check_nml_error, stdlog,write_version_number,set_domain, +! mpp_clock_id, mpp_clock_begin, mpp_clock_end, CLOCK_SUBCOMPONENT, +! clock_flag_default, nullify_domain
fv_arrays_modfv_atmos_type, R_GRID
fv_control_mod
fv_dynamics_modfv_dynamics
fv_eta_mod
fv_fill_modfill_gfs
fv_mp_modswitch_current_Atm
fv_nesting_modtwoway_nesting
fv_restart_modfv_restart, fv_write_restart
fv_sg_modfv_subgrid_z
fv_timing_modtiming_on, timing_off
fv_update_phys_modfv_update_phys
mpp_modmpp_error, stdout, FATAL, NOTE, input_nml_file, mpp_root_pe, +! mpp_npes, mpp_pe, mpp_chksum,mpp_get_current_pelist, +! mpp_set_current_pelist
mpp_domains_modmpp_get_data_domain, mpp_get_compute_domain, domain2d, mpp_update_domains
mpp_parameter_modEUPDATE, WUPDATE, SUPDATE, NUPDATE
tracer_manager_modget_tracer_index, get_number_tracers, NO_TRACER
xgrid_modgrid_box_type
+ +#include + +!----------------- +! FMS modules: +!----------------- +use block_control_mod, only: block_control_type +use constants_mod, only: cp_air, rdgas, grav, rvgas, kappa, pstd_mks +use fms_mod, only: file_exist, open_namelist_file, & + close_file, error_mesg, FATAL, & + check_nml_error, stdlog, & + write_version_number, & + set_domain, & + mpp_clock_id, mpp_clock_begin, & + mpp_clock_end, CLOCK_SUBCOMPONENT, & + clock_flag_default, nullify_domain +use mpp_mod, only: mpp_error, stdout, FATAL, WARNING, NOTE, & + input_nml_file, mpp_root_pe, & + mpp_npes, mpp_pe, mpp_chksum, & + mpp_get_current_pelist, & + mpp_set_current_pelist, mpp_sync +use mpp_parameter_mod, only: EUPDATE, WUPDATE, SUPDATE, NUPDATE +use mpp_domains_mod, only: domain2d, mpp_update_domains +use xgrid_mod, only: grid_box_type +use kinddef + +!----------------- +! FV core modules: +!----------------- +use fv_arrays_stub_mod, only: fv_atmos_type, R_GRID, fv_grid_bounds_type +use fv_control_stub_mod,only: fv_control_init, ngrids +use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_compute_domain + +implicit none +private + +!--- driver routines +public :: atmosphere_init_stub + +!--- utility routines +public :: atmosphere_resolution, & + atmosphere_control_data, atmosphere_scalar_field_halo + +!----------------------------------------------------------------------- +! version number of this module +! Include variable "version" to be written to log file. +#include +character(len=20) :: mod_name = 'fvGFS/atmosphere_mod' + +!---- private data ---- + public Atm, mygrid + + !These are convenience variables for local use only, and are set to values in Atm% + real :: dt_atmos + real :: zvir + integer :: npx, npy, npz + integer :: isc, iec, jsc, jec + integer :: isd, ied, jsd, jed + integer :: sec, seconds, days + integer, dimension(:), allocatable :: id_tracerdt_dyn + integer :: sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, cld_amt ! condensate species tracer indices + + integer :: mygrid = 1 + integer, allocatable :: pelist(:) + logical, allocatable :: grids_on_this_pe(:) + type(fv_atmos_type), allocatable, target :: Atm(:) + + integer :: id_udt_dyn, id_vdt_dyn + + real, parameter:: w0_big = 60. ! to prevent negative w-tracer diffusion + +!---dynamics tendencies for use in fv_subgrid_z and during fv_update_phys + real, allocatable, dimension(:,:,:) :: u_dt, v_dt, t_dt + real, allocatable :: pref(:,:), dum1d(:) + + +contains + + +!>@brief The subroutine 'atmosphere_init' is an API to initialize the FV3 dynamical core, +!! including the grid structures, memory, initial state (self-initialization or restart), + subroutine atmosphere_init_stub (Grid_box) + +#ifdef OPENMP + use omp_lib +#endif + + type(grid_box_type), intent(inout) :: Grid_box +!--- local variables --- + integer :: i, n +! integer :: itrac + logical :: do_atmos_nudge + character(len=32) :: tracer_name, tracer_units + real :: ps1, ps2 + integer :: nthreads, ierr + integer :: nlunit = 9999 + character (len = 64) :: fn_nml = 'input.nml' + + allocate(pelist(mpp_npes())) + call mpp_get_current_pelist(pelist) + + + call fv_control_init( Atm, dt_atmos, mygrid, grids_on_this_pe) ! allocates Atm components; sets mygrid + + +!----- write version and namelist to log file ----- + call write_version_number ( 'fvGFS/ATMOSPHERE_MOD', version ) + +!----------------------------------- + + npx = Atm(mygrid)%npx + npy = Atm(mygrid)%npy + npz = Atm(mygrid)%npz + + isc = Atm(mygrid)%bd%isc + iec = Atm(mygrid)%bd%iec + jsc = Atm(mygrid)%bd%jsc + jec = Atm(mygrid)%bd%jec + + isd = isc - Atm(mygrid)%bd%ng + ied = iec + Atm(mygrid)%bd%ng + jsd = jsc - Atm(mygrid)%bd%ng + jed = jec + Atm(mygrid)%bd%ng + + ! Allocate grid variables to be used to calculate gradient in 2nd order flux exchange + ! This data is only needed for the COARSEST grid. + !call switch_current_Atm(Atm(mygrid)) + call set_domain(Atm(mygrid)%domain) + + allocate(Grid_box%dx ( isc:iec , jsc:jec+1)) + allocate(Grid_box%dy ( isc:iec+1, jsc:jec )) + Grid_box%dx ( isc:iec , jsc:jec+1) = Atm(mygrid)%gridstruct%dx ( isc:iec, jsc:jec+1) + Grid_box%dy ( isc:iec+1, jsc:jec ) = Atm(mygrid)%gridstruct%dy ( isc:iec+1, jsc:jec ) + +#ifdef OPENMP + nthreads = omp_get_max_threads() +#else + nthreads = 1 +#endif +! --- initiate the start for a restarted regional forecast + + +#ifdef DEBUG + call nullify_domain() +#endif + + call set_domain(Atm(mygrid)%domain) + + end subroutine atmosphere_init_stub + + +!>@brief The subroutine 'atmospehre_resolution' is an API to return the local +!! extents of the current MPI-rank or the global extents of the current +!! cubed-sphere tile. + subroutine atmosphere_resolution (i_size, j_size, global) + integer, intent(out) :: i_size, j_size + logical, intent(in), optional :: global + logical :: local + + local = .true. + if( PRESENT(global) ) local = .NOT.global + + if( local ) then + i_size = iec - isc + 1 + j_size = jec - jsc + 1 + else + i_size = npx - 1 + j_size = npy - 1 + end if + + end subroutine atmosphere_resolution + + subroutine atmosphere_control_data (i1, i2, j1, j2, kt, p_hydro, hydro, tile_num) + integer, intent(out) :: i1, i2, j1, j2, kt + logical, intent(out), optional :: p_hydro, hydro + integer, intent(out), optional :: tile_num + i1 = Atm(mygrid)%bd%isc + i2 = Atm(mygrid)%bd%iec + j1 = Atm(mygrid)%bd%jsc + j2 = Atm(mygrid)%bd%jec + kt = Atm(mygrid)%npz + + if (present(tile_num)) tile_num = Atm(mygrid)%tile_of_mosaic + + end subroutine atmosphere_control_data + + + + subroutine set_atmosphere_pelist () + call mpp_set_current_pelist(Atm(mygrid)%pelist, no_sync=.TRUE.) + end subroutine set_atmosphere_pelist + + +!>@brief The subroutine 'atmosphere_scalar_field_halo' is an API to return halo information +!! of the current MPI_rank for an input scalar field. +!>@detail Up to three point haloes can be returned by this API which includes special handling for +!! the cubed-sphere tile corners. Output will be in (i,j,k) while input can be in (i,j,k) or +!! horizontally-packed form (ix,k). + subroutine atmosphere_scalar_field_halo (data, halo, isize, jsize, ksize, data_p) + !-------------------------------------------------------------------- + ! data - output array to return the field with halo (i,j,k) + ! optionally input for field already in (i,j,k) form + ! sized to include the halo of the field (+ 2*halo) + ! halo - size of the halo (must be less than 3) + ! ied - horizontal resolution in i-dir with haloes + ! jed - horizontal resolution in j-dir with haloes + ! ksize - vertical resolution + ! data_p - optional input field in packed format (ix,k) + !-------------------------------------------------------------------- + !--- interface variables --- + real(kind=kind_phys), dimension(1:isize,1:jsize,ksize), intent(inout) :: data !< output array to return the field with halo (i,j,k) + !< optionally input for field already in (i,j,k) form + !< sized to include the halo of the field (+ 2*halo) + integer, intent(in) :: halo !< size of the halo (must be less than 3) + integer, intent(in) :: isize !< horizontal resolution in i-dir with haloes + integer, intent(in) :: jsize !< horizontal resolution in j-dir with haloes + integer, intent(in) :: ksize !< vertical resolution + real(kind=kind_phys), dimension(:,:), optional, intent(in) :: data_p !< optional input field in packed format (ix,k) + !--- local variables --- + integer :: i, j, k + integer :: ic, jc + character(len=44) :: modname = 'atmosphere_mod::atmosphere_scalar_field_halo' + integer :: mpp_flags + + !--- perform error checking + if (halo .gt. 3) call mpp_error(FATAL, modname//' - halo.gt.3 requires extending the MPP domain to support') + ic = isize - 2 * halo + jc = jsize - 2 * halo + + !--- if packed data is present, unpack it into the two-dimensional data array + if (present(data_p)) then + if (ic*jc .ne. size(data_p,1)) call mpp_error(FATAL, modname//' - incorrect sizes for incoming & + &variables data and data_p') + data = 0. +!$OMP parallel do default (none) & +!$OMP shared (data, data_p, halo, ic, jc, ksize) & +!$OMP private (i, j, k) + do k = 1, ksize + do j = 1, jc + do i = 1, ic + data(i+halo, j+halo, k) = data_p(i + (j-1)*ic, k) + enddo + enddo + enddo + endif + + mpp_flags = EUPDATE + WUPDATE + SUPDATE + NUPDATE + if (halo == 1) then + call mpp_update_domains(data, Atm(mygrid)%domain_for_coupler, flags=mpp_flags, complete=.true.) + elseif (halo == 3) then + call mpp_update_domains(data, Atm(mygrid)%domain, flags=mpp_flags, complete=.true.) + else + call mpp_error(FATAL, modname//' - unsupported halo size') + endif + + !--- fill the halo points when at a corner of the cubed-sphere tile + !--- interior domain corners are handled correctly + if ( (isc==1) .or. (jsc==1) .or. (iec==npx-1) .or. (jec==npy-1) ) then + do k = 1, ksize + do j=1,halo + do i=1,halo + if ((isc== 1) .and. (jsc== 1)) data(halo+1-j ,halo+1-i ,k) = data(halo+i ,halo+1-j ,k) !SW Corner + if ((isc== 1) .and. (jec==npy-1)) data(halo+1-j ,halo+jc+i,k) = data(halo+i ,halo+jc+j,k) !NW Corner + if ((iec==npx-1) .and. (jsc== 1)) data(halo+ic+j,halo+1-i ,k) = data(halo+ic-i+1,halo+1-j ,k) !SE Corner + if ((iec==npx-1) .and. (jec==npy-1)) data(halo+ic+j,halo+jc+i,k) = data(halo+ic-i+1,halo+jc+j,k) !NE Corner + enddo + enddo + enddo + endif + + return + end subroutine atmosphere_scalar_field_halo + + +end module atmosphere_stub_mod diff --git a/unit_tests/compare_ca_output.F90 b/unit_tests/compare_ca_output.F90 new file mode 100644 index 00000000..3cc4f5e3 --- /dev/null +++ b/unit_tests/compare_ca_output.F90 @@ -0,0 +1,106 @@ +program compare_output + + +use netcdf + +implicit none + +integer, parameter :: CRES=96 +integer, parameter :: ntiles=6 +integer, parameter :: npz=3 +integer, parameter :: nexpt=3 +integer, allocatable :: layout_x(:),layout_y(:) + +real, allocatable :: truth(:,:,:),expt(:,:,:),diff(:,:,:),accum_error(:) + +integer :: i1,i2,j1,j2,nx,ny,ierr1,ierr2,ierr3,i,j,k,ncid,varid,ncid2,t,t2,var + +character*240 :: baseline_path +character*1 :: tile1 +character*2 :: tile2 +character*1 :: lx,ly +character*10 :: var_list_2d(2) + +baseline_path='/scratch2/BMC/gsienkf/Philip.Pegion/stochastic_physics_unit_tests/baseline_20210806/' + +var_list_2d(1)='ca_deep' +var_list_2d(2)='ca1' + +allocate(layout_x(nexpt)) +allocate(layout_y(nexpt)) +allocate(accum_error(nexpt)) +allocate(truth(CRES,CRES,20)) +layout_x(1)=1 +layout_x(2)=2 +layout_x(3)=4 +layout_y(1)=4 +layout_y(2)=2 +layout_y(3)=1 + +accum_error(:)=0.0 +! loop through 2-d vars (sppt,shum,landp) +do k=1,nexpt + nx=CRES/layout_x(k) + ny=CRES/layout_y(k) + allocate(expt(nx,ny,20)) + allocate(diff(nx,ny,20)) + do var=1,2 ! 2d-vars + t2=1 + do t=1,ntiles + write(tile1,fmt='(I1.1)') t + ierr1=nf90_open(trim(baseline_path)//'ca_out.tile'//tile1//'.nc',mode=nf90_nowrite,ncid=ncid) + print*,k,var,t,ierr1 + ierr2=nf90_inq_varid(ncid,trim(var_list_2d(var)),varid) + print*,'ierr2=',ierr2 + ierr3=nf90_get_var(ncid,varid,truth,count=(/CRES,CRES,20/)) + print*,'ierr3=',ierr3 + if (ierr1+ierr2+ierr3.NE.0) then + print*,'error reading in truth files',ierr1,ierr2,ierr3 + call exit(1) + endif + i1=1 + i2=i1+nx-1 + j1=1 + j2=j1+ny-1 + do j=1,layout_y(k) + do i=1,layout_x(k) + write(tile2,fmt='(I2.2)') t2 + write(lx,fmt='(I1)') layout_x(k) + write(ly,fmt='(I1)') layout_y(k) + ierr1=nf90_open('ca_layout_'//lx//'x'//ly//'/ca_out.tile'//tile2//'.nc',mode=nf90_nowrite,ncid=ncid2) + print*,'opened','ca_layout_'//lx//'x'//ly//'/ca_out.tile'//tile2//'.nc' + ierr2=nf90_inq_varid(ncid2,trim(var_list_2d(var)),varid) + ierr3=nf90_get_var(ncid2,varid,expt,count=(/nx,ny,20/)) + if (ierr1+ierr2+ierr3.NE.0) then + print*,'error reading in expt files',ierr1,ierr2,ierr3 + call exit(2) + endif + diff(:,:,:)=expt(:,:,:)-truth(i1:i2,j1:j2,:) + accum_error(k)=accum_error(k)+sum(abs(diff)) + i1=i1+nx + i2=i2+nx + if (i2.GT.CRES) then + i1=1 + i2=i1+nx-1 + j1=j1+ny + j2=j2+ny + endif + ierr1=nf90_close(ncid2) + t2=t2+1 + enddo + enddo + ierr1=nf90_close(ncid) + enddo + enddo + deallocate(expt) + deallocate(diff) +enddo + +if (sum(accum_error(:)) .EQ. 0.0 )then + print*,'all tests pass' +else + print*,'decomposition test fail',accum_error + call exit(3) +endif + +end diff --git a/unit_tests/compare_output.F90 b/unit_tests/compare_output.F90 new file mode 100644 index 00000000..3795b4c3 --- /dev/null +++ b/unit_tests/compare_output.F90 @@ -0,0 +1,162 @@ +program compare_output + + +use netcdf + +implicit none + +integer, parameter :: CRES=96 +integer, parameter :: ntiles=6 +integer, parameter :: npz=3 +integer, parameter :: nexpt=3 +integer, allocatable :: layout_x(:),layout_y(:) + +real, allocatable :: truth(:,:,:),expt(:,:,:),diff(:,:,:),accum_error(:) +real, allocatable :: truth_3d(:,:,:,:),expt_3d(:,:,:,:),diff_3d(:,:,:,:) + +integer :: i1,i2,j1,j2,nx,ny,ierr1,ierr2,ierr3,i,j,k,ncid,varid,ncid2,t,t2,var + +character*240 :: baseline_path +character*2 :: tile1,tile2 +character*1 :: lx,ly +character*10 :: var_list_2d(4) +character*10 :: var_list_3d(2) + +baseline_path='/scratch2/BMC/gsienkf/Philip.Pegion/stochastic_physics_unit_tests/baseline_20210806/' + +var_list_2d(1)='sppt_wts' +var_list_2d(2)='shum_wts' +var_list_2d(3)='vgf' +var_list_2d(4)='smc' +var_list_3d(1)='skebu_wts' +var_list_3d(2)='skebv_wts' + +allocate(layout_x(nexpt)) +allocate(layout_y(nexpt)) +allocate(accum_error(nexpt)) +allocate(truth(CRES,CRES,2)) +allocate(truth_3d(CRES,CRES,npz,2)) +layout_x(1)=1 +layout_x(2)=2 +layout_x(3)=4 +layout_y(1)=4 +layout_y(2)=2 +layout_y(3)=1 + +accum_error(:)=0.0 +! loop through 2-d vars (sppt,shum,landp) +do k=1,nexpt + nx=CRES/layout_x(k) + ny=CRES/layout_y(k) + allocate(expt(nx,ny,2)) + allocate(diff(nx,ny,2)) + do var=1,4 ! 2d-vars + t2=1 + do t=1,ntiles + write(tile1,fmt='(I2.2)') t + ierr1=nf90_open(trim(baseline_path)//'workg_T162_984x488.tile'//tile1//'.nc',mode=nf90_nowrite,ncid=ncid) + ierr2=nf90_inq_varid(ncid,trim(var_list_2d(var)),varid) + ierr3=nf90_get_var(ncid,varid,truth,count=(/CRES,CRES,2/)) + if (ierr1+ierr2+ierr3.NE.0) then + print*,'error reading in truth files' + call exit(1) + endif + i1=1 + i2=i1+nx-1 + j1=1 + j2=j1+ny-1 + do j=1,layout_y(k) + do i=1,layout_x(k) + write(tile2,fmt='(I2.2)') t2 + write(lx,fmt='(I1)') layout_x(k) + write(ly,fmt='(I1)') layout_y(k) + ierr1=nf90_open('layout_'//lx//'x'//ly//'/workg_T162_984x488.tile'//tile2//'.nc',mode=nf90_nowrite,ncid=ncid2) + ierr2=nf90_inq_varid(ncid2,trim(var_list_2d(var)),varid) + ierr3=nf90_get_var(ncid2,varid,expt,count=(/nx,ny,2/)) + if (ierr1+ierr2+ierr3.NE.0) then + print*,'error reading in expt files',ierr1,ierr2,ierr3 + call exit(2) + endif + diff(:,:,:)=expt(:,:,:)-truth(i1:i2,j1:j2,:) + accum_error(k)=accum_error(k)+sum(abs(diff)) + i1=i1+nx + i2=i2+nx + if (i2.GT.CRES) then + i1=1 + i2=i1+nx-1 + j1=j1+ny + j2=j2+ny + endif + ierr1=nf90_close(ncid2) + t2=t2+1 + enddo + enddo + ierr1=nf90_close(ncid) + enddo + enddo + deallocate(expt) + deallocate(diff) +enddo + +! loop through 3-d vars (sppt,shum,landp) +do k=1,nexpt + nx=CRES/layout_x(k) + ny=CRES/layout_y(k) + allocate(expt_3d(nx,ny,npz,2)) + allocate(diff_3d(nx,ny,npz,2)) + do var=1,2 + t2=1 + do t=1,ntiles + write(tile1,fmt='(I2.2)') t + ierr1=nf90_open(trim(baseline_path)//'workg_T162_984x488.tile'//tile1//'.nc',mode=nf90_nowrite,ncid=ncid) + ierr2=nf90_inq_varid(ncid,trim(var_list_3d(var)),varid) + ierr3=nf90_get_var(ncid,varid,truth_3d,count=(/CRES,CRES,npz,2/)) + if (ierr1+ierr2+ierr3.NE.0) then + print*,'error reading in truth files' + call exit(1) + endif + i1=1 + i2=i1+nx-1 + j1=1 + j2=j1+ny-1 + do j=1,layout_y(k) + do i=1,layout_x(k) + write(tile2,fmt='(I2.2)') t2 + write(lx,fmt='(I1)') layout_x(k) + write(ly,fmt='(I1)') layout_y(k) + ierr1=nf90_open('layout_'//lx//'x'//ly//'/workg_T162_984x488.tile'//tile2//'.nc',mode=nf90_nowrite,ncid=ncid2) + ierr2=nf90_inq_varid(ncid2,trim(var_list_3d(var)),varid) + ierr3=nf90_get_var(ncid2,varid,expt_3d,count=(/nx,ny,npz,2/)) + if (ierr1+ierr2+ierr3.NE.0) then + print*,'error reading in expt files',ierr1,ierr2,ierr3 + call exit(2) + endif + diff_3d(:,:,:,:)=expt_3d(:,:,:,:)-truth_3d(i1:i2,j1:j2,:,:) + accum_error(k)=accum_error(k)+sum(abs(diff_3d)) + i1=i1+nx + i2=i2+nx + if (i2.GT.CRES) then + i1=1 + i2=i1+nx-1 + j1=j1+ny + j2=j2+ny + endif + ierr1=nf90_close(ncid2) + t2=t2+1 + enddo + enddo + ierr1=nf90_close(ncid) + enddo + enddo + deallocate(expt_3d) + deallocate(diff_3d) +enddo + +if (sum(accum_error(:)) .EQ. 0.0 )then + print*,'all tests pass' +else + print*,'decomposition test fail',accum_error + call exit(3) +endif + +end diff --git a/unit_tests/compile_compare.sh b/unit_tests/compile_compare.sh new file mode 100755 index 00000000..244c6284 --- /dev/null +++ b/unit_tests/compile_compare.sh @@ -0,0 +1 @@ +mpif90 -C -traceback -o compare_output -I${NETCDF}/include compare_output.F90 -L${NETCDF}/lib -lnetcdff -lnetcdf -L${HDF5_LIBRARIES} -lhdf5_hl -lhdf5 -L${ZLIB_LIBRARIES} -lz diff --git a/unit_tests/compile_compare_ca.sh b/unit_tests/compile_compare_ca.sh new file mode 100755 index 00000000..54f8dc03 --- /dev/null +++ b/unit_tests/compile_compare_ca.sh @@ -0,0 +1 @@ +mpif90 -C -traceback -o compare_ca_output -I${NETCDF}/include compare_ca_output.F90 -L${NETCDF}/lib -lnetcdff -lnetcdf -L${HDF5_LIBRARIES} -lhdf5_hl -lhdf5 -L${ZLIB_LIBRARIES} -lz diff --git a/unit_tests/compile_standalone.hera_gnu b/unit_tests/compile_standalone.hera_gnu new file mode 100755 index 00000000..46dfed8b --- /dev/null +++ b/unit_tests/compile_standalone.hera_gnu @@ -0,0 +1,51 @@ +#!/bin/sh +compile_all=1 +DEBUG=YES +#DEBUG=NO +source ./module-setup.sh +module purge +module use $( pwd -P ) +if [ $DEBUG == 'YES' ]; then + module load modules.stoch_gnu_dbg +else + module load modules.stoch_gnu +fi + +rm standalone_stochy.x +FC=mpif90 +FMS_INC=${FMS_ROOT}/include_r4 +FMS_LIB=${FMS_ROOT}/lib +INCS="-I. -I${FMS_INC} -I${NETCDF}/include" +if [ $DEBUG == 'YES' ]; then + FLAGS="-DDEBUG -ggdb -fbacktrace -cpp -fcray-pointer -ffree-line-length-none -fno-range-check -fdefault-real-8 -fdefault-double-8 -g -O0 -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans -ffpe-trap=invalid,zero,overflow -fbounds-check -I. -fopenmp -c "$INCS +else + FLAGS="-ggdb -fbacktrace -cpp -fcray-pointer -ffree-line-length-none -fno-range-check -O2 -fdefault-real-8 -O2 -fPIC -fopenmp -c "$INCS +fi +cd .. +if [ $compile_all -eq 1 ];then + rm -f *.i90 *.i *.o *.mod lib*a + $FC ${FLAGS} kinddef.F90 + $FC ${FLAGS} mpi_wrapper.F90 + $FC ${FLAGS} unit_tests/fv_arrays_stub.F90 + $FC ${FLAGS} unit_tests/fv_mp_stub_mod.F90 + $FC ${FLAGS} unit_tests/fv_control_stub.F90 + $FC ${FLAGS} unit_tests/atmosphere_stub.F90 + $FC ${FLAGS} mersenne_twister.F90 + $FC ${FLAGS} stochy_internal_state_mod.F90 + $FC ${FLAGS} stochy_namelist_def.F90 + $FC ${FLAGS} spectral_transforms.F90 + $FC ${FLAGS} compns_stochy.F90 + $FC ${FLAGS} stochy_patterngenerator.F90 + $FC ${FLAGS} stochy_data_mod.F90 + $FC ${FLAGS} get_stochy_pattern.F90 + $FC ${FLAGS} lndp_apply_perts.F90 + $FC ${FLAGS} stochastic_physics.F90 +fi + ar rv libstochastic_physics.a *.o +if [ $DEBUG == 'YES' ]; then + $FC -fdec -ggdb -fbacktrace -cpp -fcray-pointer -ffree-line-length-none -fno-range-check -fdefault-real-8 -fdefault-double-8 -g -O0 -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans -ffpe-trap=invalid,zero,overflow -fbounds-check -I. -fopenmp -o unit_tests/standalone_stochy.x unit_tests/standalone_stochy.F90 ${INCS} -I${NETCDF}/include -L. -lstochastic_physics -L${FMS_LIB} -lfms_r4 -L${ESMF_LIB} -Wl,-rpath,${ESMF_LIB} -lesmf -L${NETCDF}/lib -lnetcdff -lnetcdf -L${HDF5_LIBRARIES} -lhdf5_hl -lhdf5 \ +-L${ZLIB_LIBRARIES} -lz -ldl +else + $FC -fdec -fbacktrace -cpp -fcray-pointer -ffree-line-length-none -fno-range-check -fdefault-real-8 -fdefault-double-8 -g -O2 -I. -fopenmp -o unit_tests/standalone_stochy.x unit_tests/standalone_stochy.F90 ${INCS} -I${NETCDF}/include -L. -lstochastic_physics -L${FMS_LIB} -lfms_r4 -L${ESMF_LIB} -Wl,-rpath,${ESMF_LIB} -lesmf -L${NETCDF}/lib -lnetcdff -lnetcdf -L${HDF5_LIBRARIES} -lhdf5_hl -lhdf5 \ +-L${ZLIB_LIBRARIES} -lz -ldl +fi diff --git a/unit_tests/compile_standalone.hera_intel b/unit_tests/compile_standalone.hera_intel new file mode 100755 index 00000000..8618d451 --- /dev/null +++ b/unit_tests/compile_standalone.hera_intel @@ -0,0 +1,46 @@ +#!/bin/sh +compile_all=1 +#DEBUG=YES +DEBUG=NO +source ./module-setup.sh +module purge +module use $( pwd -P ) +module load modules.hera.intel +rm standalone_stochy.x +FC=mpif90 +FMS_INC=${FMS_ROOT}/include_r8 +FMS_LIB=${FMS_ROOT}/lib +INCS="-I. -I${FMS_INC} -I${NETCDF}/include" +if [ $DEBUG == 'YES' ]; then + FLAGS=" -O0 -g -check all -link_mpi=dbg_mt -traceback -real-size 64 -qopenmp -c "$INCS +else + FLAGS=" -traceback -real-size 64 -qopenmp -c "$INCS +fi +cd .. +if [ $compile_all -eq 1 ];then + rm -f *.i90 *.i *.o *.mod lib*a + $FC ${FLAGS} kinddef.F90 + $FC ${FLAGS} mpi_wrapper.F90 + $FC ${FLAGS} unit_tests/fv_arrays_stub.F90 + $FC ${FLAGS} unit_tests/fv_mp_stub_mod.F90 + $FC ${FLAGS} unit_tests/fv_control_stub.F90 + $FC ${FLAGS} unit_tests/atmosphere_stub.F90 + $FC ${FLAGS} mersenne_twister.F90 + $FC ${FLAGS} stochy_internal_state_mod.F90 + $FC ${FLAGS} stochy_namelist_def.F90 + $FC ${FLAGS} spectral_transforms.F90 + $FC ${FLAGS} compns_stochy.F90 + $FC ${FLAGS} stochy_patterngenerator.F90 + $FC ${FLAGS} stochy_data_mod.F90 + $FC ${FLAGS} get_stochy_pattern.F90 + $FC ${FLAGS} lndp_apply_perts.F90 + $FC ${FLAGS} stochastic_physics.F90 +fi + ar rv libstochastic_physics.a *.o +if [ $DEBUG == 'YES' ]; then + $FC -traceback -g -C -real-size 64 -qopenmp -o unit_tests/standalone_stochy.x unit_tests/standalone_stochy.F90 ${INCS} -I${NETCDF}/include -L. -lstochastic_physics -L${FMS_LIB} -lfms_r8 -L${ESMF_LIB} -Wl,-rpath,${ESMF_LIB} -lesmf -L${NETCDF}/lib -lnetcdff -lnetcdf -L${HDF5_LIBRARIES} -lhdf5_hl -lhdf5 \ +-L${ZLIB_LIBRARIES} -lz +else + $FC -traceback -real-size 64 -qopenmp -o unit_tests/standalone_stochy.x unit_tests/standalone_stochy.F90 ${INCS} -I${NETCDF}/include -L. -lstochastic_physics -L${FMS_LIB} -lfms_r8 -L${ESMF_LIB} -Wl,-rpath,${ESMF_LIB} -lesmf -L${NETCDF}/lib -lnetcdff -lnetcdf -L${HDF5_LIBRARIES} -lhdf5_hl -lhdf5 \ +-L${ZLIB_LIBRARIES} -lz +fi diff --git a/unit_tests/compile_standalone_ca.hera.gnu b/unit_tests/compile_standalone_ca.hera.gnu new file mode 100755 index 00000000..8836c4b6 --- /dev/null +++ b/unit_tests/compile_standalone_ca.hera.gnu @@ -0,0 +1,53 @@ +#!/bin/sh +compile_all=1 +DEBUG=YES +#DEBUG=NO +source ./module-setup.sh +module purge +module use $( pwd -P ) +if [ $DEBUG == 'YES' ]; then + module load modules.stoch_gnu_dbg +else + module load modules.stoch_gnu +fi +#module list +rm standalone_ca.x +FC=mpif90 +FMS_INC=${FMS_ROOT}/include_r4 +FMS_LIB=${FMS_ROOT}/lib +INCS="-I. -I${FMS_INC} -I${NETCDF}/include" +if [ $DEBUG == 'YES' ]; then + FLAGS="-DDEBUG -ggdb -fbacktrace -cpp -fcray-pointer -ffree-line-length-none -fno-range-check -fdefault-real-8 -g -O0 -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans -ffpe-trap=invalid,zero,overflow -fbounds-check -fopenmp -c "$INCS + FLAGS2=$FLAGS +else + FLAGS="-fbacktrace -cpp -fcray-pointer -ffree-line-length-none -fno-range-check -fdefault-real-8 -fdefault-double-8 -g -O2 -fopenmp -c "$INCS + FLAGS2=$FLAGS +fi +cd .. +if [ $compile_all -eq 1 ];then + rm -f *.i90 *.i *.o *.mod lib*a + $FC ${FLAGS} kinddef.F90 + $FC ${FLAGS} mpi_wrapper.F90 + $FC ${FLAGS2} unit_tests/fv_arrays_stub.F90 + $FC ${FLAGS2} unit_tests/fv_mp_stub_mod.F90 + $FC ${FLAGS2} unit_tests/fv_control_stub.F90 + $FC ${FLAGS2} unit_tests/atmosphere_stub.F90 + $FC ${FLAGS2} random_numbers.F90 + $FC ${FLAGS} halo_exchange.fv3.F90 + $FC ${FLAGS} mersenne_twister.F90 + $FC ${FLAGS} plumes.F90 + $FC ${FLAGS} update_ca.F90 + $FC ${FLAGS} cellular_automata_sgs.F90 + $FC ${FLAGS} cellular_automata_global.F90 + ar rv libcellular_automata.a *.o +fi + $FC ${FLAGS} update_ca.F90 +exit +if [ $DEBUG == 'YES' ]; then + $FC -fdec -ggdb -fbacktrace -cpp -fcray-pointer -ffree-line-length-none -fno-range-check -fdefault-real-8 -fdefault-double-8 -g -O0 -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans -ffpe-trap=invalid,zero,overflow -fbounds-check -I. -fopenmp -o unit_tests/standalone_ca.x unit_tests/standalone_ca.F90 ${INCS} -I${NETCDF}/include -L. -lcellular_automata -L${FMS_LIB} -lfms_r4 -L${ESMF_LIB} -Wl,-rpath,${ESMF_LIB} -lesmf -L${NETCDF}/lib -lnetcdff -lnetcdf -L${HDF5_LIBRARIES} -lhdf5_hl -lhdf5 \ +-L${ZLIB_LIBRARIES} -lz -ldl +else + $FC -fdec -fbacktrace -cpp -fcray-pointer -ffree-line-length-none -fno-range-check -fdefault-real-8 -fdefault-double-8 -g -O2 -I. -fopenmp -o unit_tests/standalone_ca.x unit_tests/standalone_ca.F90 ${INCS} -I${NETCDF}/include -L. -lcellular_automata -L${FMS_LIB} -lfms_r4 -L${ESMF_LIB} -Wl,-rpath,${ESMF_LIB} -lesmf -L${NETCDF}/lib -lnetcdff -lnetcdf -L${HDF5_LIBRARIES} -lhdf5_hl -lhdf5 \ +-L${ZLIB_LIBRARIES} -lz -ldl +fi + diff --git a/unit_tests/compile_standalone_ca.hera.intel b/unit_tests/compile_standalone_ca.hera.intel new file mode 100755 index 00000000..54320d31 --- /dev/null +++ b/unit_tests/compile_standalone_ca.hera.intel @@ -0,0 +1,45 @@ +#!/bin/sh +compile_all=1 +#DEBUG=YES +DEBUG=NO +source ./module-setup.sh +module purge +module use $( pwd -P ) +module load modules.hera.intel +rm standalone_ca.x +FC=mpif90 +FMS_INC=${FMS_ROOT}/include_r8 +FMS_LIB=${FMS_ROOT}/lib +INCS="-I. -I${FMS_INC} -I${NETCDF}/include" +if [ $DEBUG == 'YES' ]; then + #FLAGS=" -g -C -traceback -real-size 64 -qopenmp -c "$INCS + FLAGS=" -O0 -g -check all -link_mpi=dbg_mt -traceback -real-size 64 -qopenmp -c "$INCS +else + FLAGS=" -traceback -real-size 64 -qopenmp -c "$INCS +fi +#FLAGS2=" -O0 -g -check all -link_mpi=dbg_mt -traceback -real-size 64 -qopenmp -c "$INCS +FLAGS2=" -traceback -real-size 64 -qopenmp -c "$INCS +cd .. +if [ $compile_all -eq 1 ];then + rm -f *.i90 *.i *.o *.mod lib*a + $FC ${FLAGS} kinddef.F90 + $FC ${FLAGS} mpi_wrapper.F90 + $FC ${FLAGS2} unit_tests/fv_arrays_stub.F90 + $FC ${FLAGS2} unit_tests/fv_mp_stub_mod.F90 + $FC ${FLAGS2} unit_tests/fv_control_stub.F90 + $FC ${FLAGS2} unit_tests/atmosphere_stub.F90 + $FC ${FLAGS2} random_numbers.F90 + $FC ${FLAGS} halo_exchange.fv3.F90 + $FC ${FLAGS} plumes.F90 + $FC ${FLAGS} update_ca.F90 + $FC ${FLAGS} cellular_automata_sgs.F90 + $FC ${FLAGS} cellular_automata_global.F90 + ar rv libcellular_automata.a *.o +fi +if [ $DEBUG == 'YES' ]; then + $FC -traceback -g -C -real-size 64 -qopenmp -o unit_tests/standalone_ca.x unit_tests/standalone_ca.F90 ${INCS} -I${NETCDF}/include -L. -lcellular_automata -L${FMS_LIB} -lfms_r8 -L${ESMF_LIB} -Wl,-rpath,${ESMF_LIB} -lesmf -L${NETCDF}/lib -lnetcdff -lnetcdf -L${HDF5_LIBRARIES} -lhdf5_hl -lhdf5 \ +-L${ZLIB_LIBRARIES} -lz +else + $FC -traceback -real-size 64 -qopenmp -o unit_tests/standalone_ca.x unit_tests/standalone_ca.F90 ${INCS} -I${NETCDF}/include -L. -lcellular_automata -L${FMS_LIB} -lfms_r8 -L${ESMF_LIB} -Wl,-rpath,${ESMF_LIB} -lesmf -L${NETCDF}/lib -lnetcdff -lnetcdf -L${HDF5_LIBRARIES} -lhdf5_hl -lhdf5 \ +-L${ZLIB_LIBRARIES} -lz +fi diff --git a/unit_tests/fv_arrays_stub.F90 b/unit_tests/fv_arrays_stub.F90 new file mode 100644 index 00000000..752b8129 --- /dev/null +++ b/unit_tests/fv_arrays_stub.F90 @@ -0,0 +1,351 @@ + module fv_arrays_stub_mod + +#include + use mpp_domains_mod, only: domain2d + use fms_io_mod, only: restart_file_type + use time_manager_mod, only: time_type + use mpp_mod, only: mpp_broadcast + use platform_mod, only: r8_kind + public + + integer, public, parameter :: R_GRID = r8_kind + + !Several 'auxiliary' structures are introduced here. These are for + ! the internal use by certain modules, and although fv_atmos_type + ! contains one of each of these structures all memory management + ! is performed by the module in question. + + +!>@brief The type 'fv_grid_type' is made up of grid-dependent information from fv_grid_tools and fv_grid_utils. +!>@details It should not contain any user options (that goes in a different structure) nor data which +!! is altered outside of those two modules. + type fv_grid_type + real(kind=R_GRID), allocatable, dimension(:,:,:) :: grid_64, agrid_64 + real(kind=R_GRID), allocatable, dimension(:,:) :: dx_64, dy_64 + real(kind=R_GRID), allocatable, dimension(:,:) :: dxc_64, dyc_64 + real(kind=R_GRID), allocatable, dimension(:,:) :: dxa_64, dya_64 + + real, allocatable, dimension(:,:,:) :: grid, agrid + + real, allocatable, dimension(:,:,:) :: e1,e2 + real, allocatable, dimension(:,:) :: dx, dy + real, allocatable, dimension(:,:) :: dxc, dyc + real, allocatable, dimension(:,:) :: dxa, dya + real, allocatable, dimension(:,:) :: rdx, rdy + real, allocatable, dimension(:,:) :: rdxc, rdyc + real, allocatable, dimension(:,:) :: rdxa, rdya + + real(kind=R_GRID), allocatable :: ee1(:,:,:) + real(kind=R_GRID), allocatable :: ee2(:,:,:) + real(kind=R_GRID), allocatable :: ec1(:,:,:) + real(kind=R_GRID), allocatable :: ec2(:,:,:) + real(kind=R_GRID), allocatable :: ew(:,:,:,:) + real(kind=R_GRID), allocatable :: es(:,:,:,:) + + + !- 3D Super grid to contain all geometrical factors -- + ! the 3rd dimension is 9 + real, allocatable :: sin_sg(:,:,:) + real, allocatable :: cos_sg(:,:,:) + !-------------------------------------------------- + + + integer, dimension(:,:,:), allocatable :: iinta, jinta, iintb, jintb + + !Scalar data + + integer :: npx_g, npy_g, ntiles_g ! global domain + + logical :: g_sum_initialized = .false. !< Not currently used but can be useful + logical:: sw_corner, se_corner, ne_corner, nw_corner + + real(kind=R_GRID) :: da_min, da_max, da_min_c, da_max_c + + real :: acapN, acapS + + logical :: latlon = .false. + logical :: cubed_sphere = .false. + logical :: have_south_pole = .false. + logical :: have_north_pole = .false. + logical :: stretched_grid = .false. + + logical :: square_domain = .false. + + + !! Convenience pointers + + integer, pointer :: grid_type !< Which type of grid to use. If 0, the equidistant gnomonic + !< cubed-sphere will be used. If 4, a doubly-periodic + !< f-plane cartesian grid will be used. If 5, a user-defined + !< orthogonal grid will be used. If -1, the grid is read + !< from INPUT/grid_spec.nc. Values 2, 3, 5, 6, and 7 are not + !< supported and will likely not run. The default value is 0. + + logical, pointer :: nested !< Whether this is a nested grid. .false. by default. + logical, pointer :: regional !< Is this a (stand-alone) limited area regional domain? + logical :: bounded_domain !< Is this a regional or nested domain? + + end type fv_grid_type + + type fv_flags_type + + !! FOR EACH VARIABLE IN FV_FLAGS: + !! 1. Must be defined here: + !! 2. Must be broadcast in fv_atmos_data + !! 3. If a namelist entry, a pointer must + !! be defined and associated in fv_control + !! 4. Must NOT appear in fv_current_grid_mod. + !! (this module will soon be removed) + !! 5. Must be referenced through Atm%flagstruct, + !! not Atm%, unless a convenience + !! pointer is defined + +!----------------------------------------------------------------------- +! Grid descriptor file setup +!----------------------------------------------------------------------- + character(len=16) :: restart_resolution = 'both' + character(len=80) :: grid_name = 'Gnomonic' + character(len=120):: grid_file = 'Inline' + integer :: grid_type = 0 !< -1: read from file; 0: ED Gnomonic +! !< 0: the "true" equal-distance Gnomonic grid +! !< 1: the traditional equal-distance Gnomonic grid +! !< 2: the equal-angular Gnomonic grid +! !< 3: the lat-lon grid -- to be implemented +! !< 4: double periodic boundary condition on Cartesian grid +! !< 5: a user-defined orthogonal grid for stand alone regional model + +!------------------------------------------ +! Model Domain parameters +!------------------------------------------ + integer :: npx !< Number of grid corners in the x-direction on one tile of the domain; + !< so one more than the number of grid cells across a tile. On the cubed sphere + !< this is one more than the number of cells across a cube face. Must be set. + integer :: npy !< Number of grid corners in the y-direction on one tile of the + !< domain. This value should be identical to npx on a cubed-sphere grid; + !< doubly periodic or nested grids do not have this restriction. Must be set. + integer :: npz !< Number of vertical levels. Each choice of npz comes with a + !< pre-defined set of hybrid sigma-pressure levels and model top + !< (see fv_eta.F90). Must be set. + integer :: ntiles = 1 !< Number of tiles on the domain. For the cubed sphere, this + !< should be 6, one tile for each face of the cubed sphere; normally for + !< most other domains (including nested grids) this should be set to 1. + !< Must be set. + integer :: ndims = 2 !< Lat-Lon Dims for Grid in Radians + + !>Convenience pointers + integer, pointer :: grid_number + + end type fv_flags_type + + + type fv_grid_bounds_type + + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + integer :: isc, iec, jsc, jec + + integer :: ng = 3 !default + + end type fv_grid_bounds_type + + type fv_atmos_type + + logical :: allocated = .false. + logical :: dummy = .false. ! same as grids_on_this_pe(n) + integer :: grid_number = 1 + character(len=32) :: nml_filename = "input.nml" + + !Timestep-related variables. + + type(time_type) :: Time_init, Time, Run_length, Time_end, Time_step_atmos + + logical :: grid_active = .true. !Always active for now + +!----------------------------------------------------------------------- +! Five prognostic state variables for the f-v dynamics +!----------------------------------------------------------------------- + !! Convenience pointers + integer, pointer :: npx, npy, npz, ng + + integer, allocatable, dimension(:) :: pelist + + type(fv_grid_bounds_type) :: bd + + type(fv_flags_type) :: flagstruct + type(domain2D) :: domain + + type(domain2D) :: domain_for_coupler !< domain used in coupled model with halo = 1. + + !global tile and tile_of_mosaic only have a meaning for the CURRENT pe + integer :: num_contact, npes_per_tile, global_tile, tile_of_mosaic, npes_this_grid + integer :: layout(2), io_layout(2) = (/ 1,1 /) !< layout: Processor layout on each tile. + !< The number of PEs assigned to a domain must equal + !< layout(1)*layout(2)*ntiles. Must be set. + !< io_layout: Layout of output files on each tile. 1,1 by default, + !< which combines all restart and history files on a tile into one file. + !< For 0,0, every process writes out its own restart and history files. + !< If not equal to 1,1, you will have to use mppnccombine to combine these + !< output files prior to post-processing, or if you want to change the + !< number of PEs. Both entries must divide the respective value in layout. + +!!!!!!!!!!!!!!!! +! From fv_grid_tools +!!!!!!!!!!!!!!!! + + + real :: ptop + + type(fv_grid_type) :: gridstruct + + + +!!!!!!!!!!!!!! +! From fv_io ! +!!!!!!!!!!!!!! + + !Hold on to coarse-grid global grid, so we don't have to waste processor time getting it again when starting to do grid nesting + real(kind=R_GRID), allocatable, dimension(:,:,:,:) :: grid_global + + integer :: atmos_axes(4) + + + end type fv_atmos_type + +contains + +!>@brief The subroutine 'allocate_fv_atmos_type' allocates the fv_atmos_type +!>@details It includes an option to define dummy grids that have scalar and +!! small arrays defined as null 3D arrays. + subroutine allocate_fv_atmos_type(Atm, isd_in, ied_in, jsd_in, jed_in, is_in, ie_in, js_in, je_in, & + npx_in, npy_in, npz_in, ndims_in, dummy, alloc_2d, ngrids_in) + + !WARNING: Before calling this routine, be sure to have set up the + ! proper domain parameters from the namelists (as is done in + ! fv_control.F90) + + implicit none + type(fv_atmos_type), intent(INOUT), target :: Atm + integer, intent(IN) :: isd_in, ied_in, jsd_in, jed_in, is_in, ie_in, js_in, je_in + integer, intent(IN) :: npx_in, npy_in, npz_in, ndims_in + logical, intent(IN) :: dummy, alloc_2d + integer, intent(IN) :: ngrids_in + integer:: isd, ied, jsd, jed, is, ie, js, je + integer:: npx, npy, npz, ndims, ng + + !For 2D utility arrays + integer:: isd_2d, ied_2d, jsd_2d, jed_2d, is_2d, ie_2d, js_2d, je_2d + integer:: npx_2d, npy_2d, npz_2d, ndims_2d, ng_2d + integer :: i,j,k, ns, n + + if (Atm%allocated) return + + if (dummy) then + isd = 0 + ied= -1 + jsd= 0 + jed= -1 + is= 0 + ie= -1 + js= 0 + je= -1 + npx= 1 + npy= 1 + npz= 1 + ndims= 1 + else + isd = isd_in + ied= ied_in + jsd= jsd_in + jed= jed_in + is= is_in + ie= ie_in + js= js_in + je= je_in + npx= npx_in + npy= npy_in + npz= npz_in + ndims= ndims_in + endif + + if ((.not. dummy) .or. alloc_2d) then + isd_2d = isd_in + ied_2d= ied_in + jsd_2d= jsd_in + jed_2d= jed_in + is_2d= is_in + ie_2d= ie_in + js_2d= js_in + je_2d= je_in + npx_2d= npx_in + npy_2d= npy_in + npz_2d= npz_in + ndims_2d= ndims_in + else + isd_2d = 0 + ied_2d= -1 + jsd_2d= 0 + jed_2d= -1 + is_2d= 0 + ie_2d= -1 + js_2d= 0 + je_2d= -1 + npx_2d= 1 + npy_2d= 1 + npz_2d= npz_in !for ak, bk, which are 1D arrays and thus OK to allocate + ndims_2d= 1 + endif + + + !Convenience pointers + Atm%npx => Atm%flagstruct%npx + Atm%npy => Atm%flagstruct%npy + Atm%npz => Atm%flagstruct%npz + + Atm%ng => Atm%bd%ng + Atm%flagstruct%ndims = ndims_in + + + allocate ( Atm%gridstruct% dx(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct% dx_64(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct%rdx(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct% dy(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct% dy_64(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct%rdy(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) + + allocate ( Atm%gridstruct% dxc(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct% dxc_64(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct%rdxc(isd_2d:ied_2d+1,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct% dyc(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct% dyc_64(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct%rdyc(isd_2d:ied_2d ,jsd_2d:jed_2d+1) ) + + allocate ( Atm%gridstruct% dxa(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct% dxa_64(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct%rdxa(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct% dya(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct% dya_64(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) + allocate ( Atm%gridstruct%rdya(isd_2d:ied_2d ,jsd_2d:jed_2d ) ) + + allocate ( Atm%gridstruct%grid (isd_2d:ied_2d+1,jsd_2d:jed_2d+1,1:ndims_2d) ) + allocate ( Atm%gridstruct%grid_64 (isd_2d:ied_2d+1,jsd_2d:jed_2d+1,1:ndims_2d) ) + allocate ( Atm%gridstruct%agrid(isd_2d:ied_2d ,jsd_2d:jed_2d ,1:ndims_2d) ) + allocate ( Atm%gridstruct%agrid_64(isd_2d:ied_2d ,jsd_2d:jed_2d ,1:ndims_2d) ) + + allocate ( Atm%gridstruct% e1(3,isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) + allocate ( Atm%gridstruct% e2(3,isd_2d:ied_2d+1,jsd_2d:jed_2d+1) ) + + allocate (Atm%gridstruct%iinta(4, isd_2d:ied_2d ,jsd_2d:jed_2d), & + Atm%gridstruct%jinta(4, isd_2d:ied_2d ,jsd_2d:jed_2d), & + Atm%gridstruct%iintb(4, is_2d:ie_2d+1 ,js_2d:je_2d+1), & + Atm%gridstruct%jintb(4, is_2d:ie_2d+1 ,js_2d:je_2d+1) ) + + !!Convenience pointers + Atm%gridstruct%grid_type => Atm%flagstruct%grid_type + Atm%flagstruct%grid_number => Atm%grid_number + + Atm%allocated = .true. + if (dummy) Atm%dummy = .true. + + end subroutine allocate_fv_atmos_type + +end module fv_arrays_stub_mod diff --git a/unit_tests/fv_control_stub.F90 b/unit_tests/fv_control_stub.F90 new file mode 100644 index 00000000..a09def89 --- /dev/null +++ b/unit_tests/fv_control_stub.F90 @@ -0,0 +1,1166 @@ + +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +!>@brief The module 'FV3_control' is for initialization and termination +!! of the model, and controls namelist parameters in FV3. +!---------------- +! FV control panel +!---------------- + +module fv_control_stub_mod + use constants_mod, only: pi=>pi_8, kappa, radius, grav, rdgas + use fms_mod, only: write_version_number, open_namelist_file, & + check_nml_error, close_file, file_exist, & + get_mosaic_tile_grid + use fms_io_mod, only: set_domain + use fms_io_mod, only: field_exist, read_data, & + get_global_att_value, get_var_att_value + use mpp_mod, only: FATAL, mpp_error, mpp_pe, stdlog, & + mpp_npes, mpp_get_current_pelist, & + input_nml_file, get_unit, WARNING, & + read_ascii_file + use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_compute_domain, mpp_get_tile_id + use tracer_manager_mod, only: tm_get_number_tracers => get_number_tracers, & + tm_get_tracer_index => get_tracer_index, & + tm_get_tracer_indices => get_tracer_indices, & + tm_set_tracer_profile => set_tracer_profile, & + tm_get_tracer_names => get_tracer_names, & + tm_check_if_prognostic=> check_if_prognostic,& + tm_register_tracers => register_tracers + + use fv_mp_stub_mod, only: mp_start, domain_decomp, mp_assign_gid + use fv_mp_stub_mod, only: broadcast_domains, setup_master, grids_master_procs + use fv_mp_stub_mod, only: MAX_NNEST, MAX_NTILE,fill_corners,XDir,YDir,ng + use mpp_domains_mod, only: domain2D + use mpp_domains_mod, only: mpp_get_global_domain + use mpp_domains_mod, only: mpp_get_C2F_index, mpp_get_F2C_index + use mpp_domains_mod, only: CENTER + use mpp_domains_mod, only: mpp_update_domains + use mpp_mod, only: mpp_send, mpp_sync, mpp_transmit, mpp_set_current_pelist, & + mpp_declare_pelist, mpp_root_pe, mpp_recv, mpp_sync_self, read_input_nml, & + mpp_max + use mosaic_mod, only : get_mosaic_ntiles + use fv_arrays_stub_mod, only: fv_atmos_type, allocate_fv_atmos_type,R_GRID + + implicit none + private + +#ifdef OVERLOAD_R4 + real :: too_big = 1.E8 +#else + real :: too_big = 1.E35 +#endif + public :: fv_control_init + + integer, public :: ngrids = 1 + integer :: commID, global_commID + + integer :: halo_update_type = 1 ! 1 for two-interfaces non-block + ! 2 for block + ! 3 for four-interfaces non-block +#ifdef NO_QUAD_PRECISION +! 64-bit precision (kind=8) + integer, parameter:: f_p = selected_real_kind(15) +#else +! Higher precision (kind=16) for grid geometrical factors: + integer, parameter:: f_p = selected_real_kind(20) +#endif + +! version number of this module +! Include variable "version" to be written to log file. +#include + + contains + +!------------------------------------------------------------------------------- + + subroutine fv_control_init(Atm, dt_atmos, this_grid, grids_on_this_pe) + + type(fv_atmos_type), allocatable, intent(inout), target :: Atm(:) + real, intent(in) :: dt_atmos + integer, intent(OUT) :: this_grid + logical, allocatable, intent(OUT) :: grids_on_this_pe(:) + + character(100) :: pe_list_name, errstring + integer :: n, npes, pecounter, i, num_family + integer, allocatable :: global_pelist(:) + integer, dimension(MAX_NNEST) :: grid_pes = 0 + integer, dimension(MAX_NNEST) :: all_npx = 0 + integer, dimension(MAX_NNEST) :: all_npy = 0 + integer, dimension(MAX_NNEST) :: all_ntiles = 0 + + real :: sdt + integer :: unit, ens_root_pe, tile_id(1) + integer :: ngrids + + !!!!!!!!!! POINTERS FOR READING NAMELISTS !!!!!!!!!! + + !------------------------------------------ + ! Model Domain parameters + ! See fv_arrays.F90 for descriptions + !------------------------------------------ + !CLEANUP module pointers + character(len=80) , pointer :: grid_name + character(len=120), pointer :: grid_file + integer, pointer :: grid_type + + integer , pointer :: npx + integer , pointer :: npy + + integer , pointer :: ntiles + integer , pointer :: ndims + real(kind=R_GRID), pointer :: deglon_start, deglon_stop, & ! boundaries of latlon patch + deglat_start, deglat_stop + real(kind=R_GRID), pointer :: deglat + + integer, pointer :: layout(:), io_layout(:) + logical :: nested + + !!!!!!!!!! END POINTERS !!!!!!!!!!!!!!!!!!!!!!!!!!!! + + this_grid = -1 ! default + call mp_assign_gid + ens_root_pe = mpp_root_pe() + + ! 2. Set up Atm and PElists + + ngrids = 1 + allocate(Atm(ngrids)) + Atm(1)%gridstruct%bounded_domain=.false. + npes = mpp_npes() ! now on global pelist + + allocate(global_pelist(npes)) + call mpp_get_current_pelist(global_pelist, commID=global_commID) ! for commID + + + allocate(grids_master_procs(ngrids)) + pecounter = 0 + allocate(grids_on_this_pe(ngrids)) + grids_on_this_pe(:) = .false. + + do n=1,ngrids + + if (ngrids == 1 .or. grid_pes(n) == 0) then + grid_pes(n) = npes - sum(grid_pes) + if (grid_pes(n) == 0) then + if ( n > 1 ) then + call mpp_error(FATAL, 'Only one zero entry in grid_pes permitted.') + else + grid_pes(n) = npes + endif + endif + endif + + allocate(Atm(n)%pelist(grid_pes(n))) + grids_master_procs(n) = pecounter + do i=1,grid_pes(n) + if (pecounter >= npes) then + if (mpp_pe() == 0) then + print*, 'ngrids = ', ngrids, ', grid_pes = ', grid_pes(1:ngrids) + endif + call mpp_error(FATAL, 'grid_pes assigns more PEs than are available.') + endif + Atm(n)%pelist(i) = pecounter + ens_root_pe + pecounter = pecounter + 1 + Atm(n)%npes_this_grid = grid_pes(n) + enddo + Atm(n)%grid_number = n + + !TODO: we are required to use PE name for reading INTERNAL namelist + ! and the actual file name for EXTERNAL namelists. Need to clean up this code + if (n == 1) then + pe_list_name = '' + else + write(pe_list_name,'(A4, I2.2)') 'nest', n + endif + call mpp_declare_pelist(Atm(n)%pelist, pe_list_name) + !If nest need to re-initialize internal NML + if (n > 1) then + Atm(n)%nml_filename = 'input_'//trim(pe_list_name)//'.nml' + else + Atm(n)%nml_filename = 'input.nml' + endif + enddo + + do n=1,ngrids + !ONE grid per pe + if (ANY(mpp_pe() == Atm(n)%pelist)) then + if (this_grid > 0) then + print*, mpp_pe(), this_grid, n + call mpp_error(FATAL, " Grid assigned to multiple pes") + endif + call mpp_set_current_pelist(Atm(n)%pelist) + call setup_master(Atm(n)%pelist) + this_grid = n + grids_on_this_pe(n) = .true. + endif + + enddo + + if (pecounter /= npes) then + if (mpp_pe() == 0) then + print*, 'npes = ', npes, ', grid_pes = ', grid_pes(1:ngrids) + call mpp_error(FATAL, 'grid_pes in fv_nest_Nml does not assign all of the available PEs') + endif + endif + + ! 3pre. + + ! 3. Read namelists, do option processing and I/O + + call set_namelist_pointers(Atm(this_grid)) + call read_namelist_fv_grid_nml + call read_namelist_fv_core_nml(Atm(this_grid)) ! do options processing here too? + + call mpp_get_current_pelist(Atm(this_grid)%pelist, commID=commID) ! for commID + call mp_start(commID,halo_update_type) + + ! 4. Set up domains + all_ntiles(this_grid) = ntiles + call mpp_max(all_ntiles, ngrids, global_pelist) + + all_npx(this_grid) = npx + call mpp_max(all_npx, ngrids, global_pelist) + + all_npy(this_grid) = npy + call mpp_max(all_npy, ngrids, global_pelist) + + do n=1,ngrids + if (n/=this_grid) then + Atm(n)%flagstruct%npx = all_npx(n) + Atm(n)%flagstruct%npy = all_npy(n) + Atm(n)%flagstruct%ntiles = all_ntiles(n) + endif + + enddo + + + ! 5. domain_decomp() + nested=.false. + call domain_decomp(Atm(this_grid)%flagstruct%npx,Atm(this_grid)%flagstruct%npy,Atm(this_grid)%flagstruct%ntiles,& + Atm(this_grid)%flagstruct%grid_type,nested, & + Atm(this_grid)%layout,Atm(this_grid)%io_layout,Atm(this_grid)%bd,Atm(this_grid)%tile_of_mosaic, & + Atm(this_grid)%gridstruct%square_domain,Atm(this_grid)%npes_per_tile,Atm(this_grid)%domain, & + Atm(this_grid)%domain_for_coupler,Atm(this_grid)%num_contact,Atm(this_grid)%pelist) + call set_domain(Atm(this_grid)%domain) + call broadcast_domains(Atm,Atm(this_grid)%pelist,size(Atm(this_grid)%pelist)) + do n=1,ngrids + tile_id = mpp_get_tile_id(Atm(n)%domain) + Atm(n)%global_tile = tile_id(1) ! only meaningful locally + Atm(n)%npes_per_tile = size(Atm(n)%pelist)/Atm(n)%flagstruct%ntiles ! domain decomp doesn't set this globally + enddo + + ! 6. Set up domain and Atm structure + do n=1,ngrids + call allocate_fv_atmos_type(Atm(n), & + Atm(n)%bd%isd, Atm(n)%bd%ied, & + Atm(n)%bd%jsd, Atm(n)%bd%jed, & + Atm(n)%bd%isc, Atm(n)%bd%iec, & + Atm(n)%bd%jsc, Atm(n)%bd%jec, & + Atm(n)%flagstruct%npx, Atm(n)%flagstruct%npy, Atm(n)%flagstruct%npz, & + Atm(n)%flagstruct%ndims, & + n/=this_grid, n==this_grid, ngrids) !TODO don't need both of the last arguments + enddo + call init_grid(Atm(this_grid), Atm(this_grid)%flagstruct%grid_name, Atm(this_grid)%flagstruct%grid_file, & + Atm(this_grid)%flagstruct%npx, Atm(this_grid)%flagstruct%npy, Atm(this_grid)%flagstruct%ndims, Atm(this_grid)%flagstruct%ntiles, ng) + + + contains +!>@brief The subroutine 'setup_namelist_pointers' associates the MODULE flag pointers +!! with the ARRAY flag variables for the grid active on THIS pe so the flags +!! can be read in from the namelist. + subroutine set_namelist_pointers(Atm) + type(fv_atmos_type), intent(INOUT), target :: Atm + + !This routine associates the MODULE flag pointers with the ARRAY flag variables for the grid active on THIS pe so the flags can be read in from the namelist. + + grid_type => Atm%flagstruct%grid_type + grid_name => Atm%flagstruct%grid_name + grid_file => Atm%flagstruct%grid_file + npx => Atm%flagstruct%npx + npy => Atm%flagstruct%npy + ntiles => Atm%flagstruct%ntiles + ndims => Atm%flagstruct%ndims + layout => Atm%layout + io_layout => Atm%io_layout + + end subroutine set_namelist_pointers + + + subroutine read_namelist_fv_grid_nml + + integer :: f_unit, ios, ierr + ! local version of these variables to allow PGI compiler to compile + character(len=80) :: grid_name = '' + character(len=120) :: grid_file = '' + namelist /fv_grid_nml/ grid_name, grid_file + + f_unit=open_namelist_file() + rewind (f_unit) + ! Read Main namelist + read (f_unit,fv_grid_nml,iostat=ios) + ierr = check_nml_error(ios,'fv_grid_nml') + call close_file (f_unit) + call write_version_number ( 'FV_CONTROL_MOD', version ) + unit = stdlog() + write(unit, nml=fv_grid_nml) + + !Basic option processing + if (len_trim(grid_file) /= 0) Atm(this_grid)%flagstruct%grid_file = grid_file + if (len_trim(grid_name) /= 0) Atm(this_grid)%flagstruct%grid_name = grid_name + + + end subroutine read_namelist_fv_grid_nml + + subroutine read_namelist_fv_core_nml(Atm) + + type(fv_atmos_type), intent(inout) :: Atm + integer :: f_unit, ios, ierr + real :: dim0 = 180. ! base dimension + real :: dt0 = 1800. ! base time step + real :: dimx, dl, dp, dxmin, dymin, d_fac + real :: umax = 350. ! max wave speed for grid_type>3 + + integer :: n0split + + ! local version of these variables to allow PGI compiler to compile + + namelist /fv_core_nml/npx, npy, ntiles, layout, io_layout, grid_type + + + f_unit = open_namelist_file(Atm%nml_filename) + ! Read FVCORE namelist + read (f_unit,fv_core_nml,iostat=ios) + ierr = check_nml_error(ios,'fv_core_nml') + call close_file(f_unit) + call write_version_number ( 'FV_CONTROL_MOD', version ) + unit = stdlog() + write(unit, nml=fv_core_nml) + + !*** single tile for Cartesian grids + if (grid_type>3) then + ntiles=1 + else + ntiles=6 + endif + + +197 format(A,l7) +198 format(A,i2.2,A,i4.4,'x',i4.4,'x',i1.1,'-',f9.3) +199 format(A,i3.3) + + end subroutine read_namelist_fv_core_nml + + end subroutine fv_control_init + +!>@brief The subroutine 'init_grid' reads the grid from the input file +!! and sets up grid descriptors. + subroutine init_grid(Atm, grid_name, grid_file, npx, npy, ndims, nregions, ng) +!-------------------------------------------------------- + type(fv_atmos_type), intent(inout), target :: Atm + character(len=80), intent(IN) :: grid_name + character(len=120),intent(IN) :: grid_file + integer, intent(IN) :: npx, npy + integer, intent(IN) :: ndims + integer, intent(IN) :: nregions + integer, intent(IN) :: ng +!-------------------------------------------------------- + real(kind=R_GRID) :: ys(npx,npy) + + real(kind=R_GRID) :: dp, dl + real(kind=R_GRID) :: x1,x2,y1,y2,z1,z2 + integer :: i,j,k,n,nreg + integer :: fileLun + + real(kind=R_GRID) :: p1(3), p2(3), p3(3), p4(3) + real(kind=R_GRID) :: dist,dist1,dist2, pa(2), pa1(2), pa2(2), pb(2) + real(kind=R_GRID) :: pt(3), pt1(3), pt2(3), pt3(3) + + real(kind=R_GRID) :: angN,angM,angAV,ang + real(kind=R_GRID) :: aspN,aspM,aspAV,asp + + real(kind=R_GRID) :: vec1(3), vec2(3), vec3(3), vec4(3) + real(kind=R_GRID) :: vecAvg(3), vec3a(3), vec3b(3), vec4a(3), vec4b(3) + real(kind=R_GRID) :: xyz1(3), xyz2(3) + + integer :: ios, ip, jp + + integer :: igrid + + integer :: tmplun + character(len=80) :: tmpFile + + real(kind=R_GRID), dimension(Atm%bd%is:Atm%bd%ie) :: sbuffer, nbuffer + real(kind=R_GRID), dimension(Atm%bd%js:Atm%bd%je) :: wbuffer, ebuffer + + real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid + + real(kind=R_GRID), pointer, dimension(:,:) :: sina, cosa + + integer, pointer, dimension(:,:,:) :: iinta, jinta, iintb, jintb + + integer, pointer :: ntiles_g, tile + logical, pointer :: sw_corner, se_corner, ne_corner, nw_corner + logical, pointer :: latlon, cubed_sphere, have_south_pole, have_north_pole + + type(domain2d), pointer :: domain + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + + is = Atm%bd%is + ie = Atm%bd%ie + js = Atm%bd%js + je = Atm%bd%je + isd = Atm%bd%isd + ied = Atm%bd%ied + jsd = Atm%bd%jsd + jed = Atm%bd%jed + + !!! Associate pointers + agrid => Atm%gridstruct%agrid_64 + grid => Atm%gridstruct%grid_64 + + iinta => Atm%gridstruct%iinta + jinta => Atm%gridstruct%jinta + iintb => Atm%gridstruct%iintb + jintb => Atm%gridstruct%jintb + ntiles_g => Atm%gridstruct%ntiles_g + sw_corner => Atm%gridstruct%sw_corner + se_corner => Atm%gridstruct%se_corner + ne_corner => Atm%gridstruct%ne_corner + nw_corner => Atm%gridstruct%nw_corner + latlon => Atm%gridstruct%latlon + cubed_sphere => Atm%gridstruct%cubed_sphere + have_south_pole => Atm%gridstruct%have_south_pole + have_north_pole => Atm%gridstruct%have_north_pole + + tile => Atm%tile_of_mosaic + + domain => Atm%domain + + ntiles_g = nregions + latlon = .false. + cubed_sphere = .true. + + call read_grid(Atm, grid_file, ndims, nregions, ng) + + call sorted_inta(isd, ied, jsd, jed, cubed_sphere, grid, iinta, jinta) + + agrid(:,:,:) = -1.e25 + + do j=js,je + do i=is,ie + call cell_center2(grid(iinta(1,i,j),jinta(1,i,j),1:2), & + grid(iinta(2,i,j),jinta(2,i,j),1:2), & + grid(iinta(3,i,j),jinta(3,i,j),1:2), & + grid(iinta(4,i,j),jinta(4,i,j),1:2), & + agrid(i,j,1:2) ) + enddo + enddo + call sorted_intb(isd, ied, jsd, jed, is, ie, js, je, npx, npy, & + cubed_sphere, agrid, iintb, jintb) + end subroutine init_grid + + +!------------------------------------------------------------------------------- + subroutine cell_center2(q1, q2, q3, q4, e2) + real(kind=R_GRID) , intent(in ) :: q1(2), q2(2), q3(2), q4(2) + real(kind=R_GRID) , intent(out) :: e2(2) +! Local + real(kind=R_GRID) p1(3), p2(3), p3(3), p4(3) + real(kind=R_GRID) ec(3) + real(kind=R_GRID) dd + integer k + + call latlon2xyz(q1, p1) + call latlon2xyz(q2, p2) + call latlon2xyz(q3, p3) + call latlon2xyz(q4, p4) + + do k=1,3 + ec(k) = p1(k) + p2(k) + p3(k) + p4(k) + enddo + dd = sqrt( ec(1)**2 + ec(2)**2 + ec(3)**2 ) + + do k=1,3 + ec(k) = ec(k) / dd + enddo + call cart_to_latlon(1, ec, e2(1), e2(2)) + + end subroutine cell_center2 +!>@brief The subroutine 'read_grid' reads the grid from the mosaic grid file. + subroutine read_grid(Atm, grid_file, ndims, nregions, ng) + type(fv_atmos_type), intent(inout), target :: Atm + character(len=*), intent(IN) :: grid_file + integer, intent(IN) :: ndims + integer, intent(IN) :: nregions + integer, intent(IN) :: ng + + real, allocatable, dimension(:,:) :: tmpx, tmpy + real(kind=R_GRID), pointer, dimension(:,:,:) :: grid + character(len=128) :: units = "" + character(len=256) :: atm_mosaic, atm_hgrid, grid_form + character(len=1024) :: attvalue + integer :: ntiles, i, j, stdunit + integer :: isc2, iec2, jsc2, jec2 + integer :: start(4), nread(4) + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + integer,save :: halo=3 ! for regional domain external tools + + is = Atm%bd%is + ie = Atm%bd%ie + js = Atm%bd%js + je = Atm%bd%je + isd = Atm%bd%isd + ied = Atm%bd%ied + jsd = Atm%bd%jsd + jed = Atm%bd%jed + grid => Atm%gridstruct%grid_64 + + if(.not. file_exist(grid_file)) call mpp_error(FATAL, 'fv_grid_tools(read_grid): file '// & + trim(grid_file)//' does not exist') + + !--- make sure the grid file is mosaic file. + if(field_exist(grid_file, 'atm_mosaic_file')) then + call read_data(grid_file, "atm_mosaic_file", atm_mosaic) + atm_mosaic = "INPUT/"//trim(atm_mosaic) + else + atm_mosaic = trim(grid_file) + endif + + call get_mosaic_tile_grid(atm_hgrid, atm_mosaic, Atm%domain) + + grid_form = "none" + if( get_global_att_value(atm_hgrid, "history", attvalue) ) then + if( index(attvalue, "gnomonic_ed") > 0) grid_form = "gnomonic_ed" + endif + if(grid_form .NE. "gnomonic_ed") call mpp_error(FATAL, & + "fv_grid_tools(read_grid): the grid should be 'gnomonic_ed' when reading from grid file, contact developer") + + ntiles = get_mosaic_ntiles(atm_mosaic) + if( .not. Atm%gridstruct%bounded_domain) then !<-- The regional setup has only 1 tile so do not shutdown in that case. + if(ntiles .NE. 6) call mpp_error(FATAL, & + 'fv_grid_tools(read_grid): ntiles should be 6 in mosaic file '//trim(atm_mosaic) ) + if(nregions .NE. 6) call mpp_error(FATAL, & + 'fv_grid_tools(read_grid): nregions should be 6 when reading from mosaic file '//trim(grid_file) ) + endif + + call get_var_att_value(atm_hgrid, 'x', 'units', units) + + !--- get the geographical coordinates of super-grid. + isc2 = 2*is-1; iec2 = 2*ie+1 + jsc2 = 2*js-1; jec2 = 2*je+1 + if( Atm%gridstruct%bounded_domain ) then + isc2 = 2*(isd+halo)-1; iec2 = 2*(ied+1+halo)-1 ! For the regional domain the cell corner locations must be transferred + jsc2 = 2*(jsd+halo)-1; jec2 = 2*(jed+1+halo)-1 ! from the entire supergrid to the compute grid, including the halo region. + endif + allocate(tmpx(isc2:iec2, jsc2:jec2) ) + allocate(tmpy(isc2:iec2, jsc2:jec2) ) + start = 1; nread = 1 + start(1) = isc2; nread(1) = iec2 - isc2 + 1 + start(2) = jsc2; nread(2) = jec2 - jsc2 + 1 + call read_data(atm_hgrid, 'x', tmpx, start, nread, no_domain=.TRUE.) !<-- tmpx (lon, deg east) is on the supergrid + call read_data(atm_hgrid, 'y', tmpy, start, nread, no_domain=.TRUE.) !<-- tmpy (lat, deg) is on the supergrid + + !--- geographic grid at cell corner + grid(isd: is-1, jsd:js-1,1:ndims)=0. + grid(isd: is-1, je+2:jed+1,1:ndims)=0. + grid(ie+2:ied+1,jsd:js-1,1:ndims)=0. + grid(ie+2:ied+1,je+2:jed+1,1:ndims)=0. + if(len_trim(units) < 6) call mpp_error(FATAL, & + "fv_grid_tools_mod(read_grid): the length of units must be no less than 6") + if(units(1:6) == 'degree') then + if( .not. Atm%gridstruct%bounded_domain) then + do j = js, je+1 + do i = is, ie+1 + grid(i,j,1) = tmpx(2*i-1,2*j-1)*pi/180. + grid(i,j,2) = tmpy(2*i-1,2*j-1)*pi/180. + enddo + enddo + else +! +!*** In the regional case the halo surrounding the domain was included in the read. +!*** Transfer the compute and halo regions to the compute grid. +! + do j = jsd, jed+1 + do i = isd, ied+1 + grid(i,j,1) = tmpx(2*i+halo+2,2*j+halo+2)*pi/180. + grid(i,j,2) = tmpy(2*i+halo+2,2*j+halo+2)*pi/180. + enddo + enddo + endif + + else if(units(1:6) == 'radian') then + do j = js, je+1 + do i = is, ie+1 + grid(i,j,1) = tmpx(2*i-1,2*j-1) + grid(i,j,2) = tmpy(2*i-1,2*j-1) + enddo + enddo + else + print*, 'units is ' , trim(units), len_trim(units), mpp_pe() + call mpp_error(FATAL, 'fv_grid_tools_mod(read_grid): units must start with degree or radian') + endif + + deallocate(tmpx, tmpy) + nullify(grid) + end subroutine read_grid + subroutine latlon2xyz(p, e, id) + + real(kind=R_GRID), intent(in) :: p(2) + real(kind=R_GRID), intent(out):: e(3) + integer, optional, intent(in):: id !< id=0 do nothing; id=1, right_hand + + integer n + real (f_p):: q(2) + real (f_p):: e1, e2, e3 + + do n=1,2 + q(n) = p(n) + enddo + + e1 = cos(q(2)) * cos(q(1)) + e2 = cos(q(2)) * sin(q(1)) + e3 = sin(q(2)) +!----------------------------------- +! Truncate to the desired precision: +!----------------------------------- + e(1) = e1 + e(2) = e2 + e(3) = e3 + + end subroutine latlon2xyz + subroutine cart_to_latlon(np, q, xs, ys) +! vector version of cart_to_latlon1 + integer, intent(in):: np + real(kind=R_GRID), intent(inout):: q(3,np) + real(kind=R_GRID), intent(inout):: xs(np), ys(np) +! local + real(kind=R_GRID), parameter:: esl=1.d-10 + real (f_p):: p(3) + real (f_p):: dist, lat, lon + integer i,k + + do i=1,np + do k=1,3 + p(k) = q(k,i) + enddo + dist = sqrt(p(1)**2 + p(2)**2 + p(3)**2) + do k=1,3 + p(k) = p(k) / dist + enddo + + if ( (abs(p(1))+abs(p(2))) < esl ) then + lon = real(0.,kind=f_p) + else + lon = atan2( p(2), p(1) ) ! range [-pi,pi] + endif + + if ( lon < 0.) lon = real(2.,kind=f_p)*pi + lon +! RIGHT_HAND system: + lat = asin(p(3)) + + xs(i) = lon + ys(i) = lat +! q Normalized: + do k=1,3 + q(k,i) = p(k) + enddo + enddo + + end subroutine cart_to_latlon + +subroutine sorted_inta(isd, ied, jsd, jed, cubed_sphere, bgrid, iinta, jinta) + integer, intent(in) :: isd, ied, jsd, jed + real(kind=R_GRID), intent(in), dimension(isd:ied+1,jsd:jed+1,2) :: bgrid + logical, intent(in) :: cubed_sphere + + integer, intent(out), dimension(4,isd:ied,jsd:jed) :: iinta, jinta + !------------------------------------------------------------------! + ! local variables ! + !------------------------------------------------------------------! + real, dimension(4) :: xsort, ysort + integer, dimension(4) :: isort, jsort + integer :: i, j + !------------------------------------------------------------------! + ! special treatment for cubed sphere ! + !------------------------------------------------------------------! + if (cubed_sphere) then + !---------------------------------------------------------------! + ! get order of indices for line integral around a-grid cell ! + !---------------------------------------------------------------! + do j=jsd,jed + do i=isd,ied + xsort(1)=bgrid(i ,j ,1); ysort(1)=bgrid(i ,j ,2); isort(1)=i ; jsort(1)=j + xsort(2)=bgrid(i ,j+1,1); ysort(2)=bgrid(i ,j+1,2); isort(2)=i ; jsort(2)=j+1 + xsort(3)=bgrid(i+1,j+1,1); ysort(3)=bgrid(i+1,j+1,2); isort(3)=i+1; jsort(3)=j+1 + xsort(4)=bgrid(i+1,j ,1); ysort(4)=bgrid(i+1,j ,2); isort(4)=i+1; jsort(4)=j + call sort_rectangle(iinta(1,i,j), jinta(1,i,j)) + enddo + enddo + else + !---------------------------------------------------------------! + ! default behavior for other grids ! + !---------------------------------------------------------------! + do j=jsd,jed + do i=isd,ied + iinta(i,j,1)=i ; jinta(i,j,1)=j + iinta(i,j,2)=i ; jinta(i,j,2)=j+1 + iinta(i,j,3)=i+1; jinta(i,j,3)=j+1 + iinta(i,j,4)=i+1; jinta(i,j,4)=j + enddo + enddo + endif + + contains + !------------------------------------------------------------------! + subroutine sort_rectangle(iind, jind) + integer, dimension(4), intent(inout) :: iind, jind + !----------------------------------------------------------------! + ! local variables ! + !----------------------------------------------------------------! + real, dimension(4) :: xsorted, ysorted + integer, dimension(4) :: isorted, jsorted + integer :: l, ll, lll + !----------------------------------------------------------------! + ! sort in east west ! + !----------------------------------------------------------------! + xsorted(:)=10. + ysorted(:)=10. + isorted(:)=0 + jsorted(:)=0 + + do l=1,4 + do ll=1,4 + if (xsort(l)@brief The subroutine 'sorted_intb' sorts cell corner indices in latlon space +!! based on grid locations in index space. +!>@details If not the grid is notcubed_sphere, it assumes that +!! the orientations in index and latlon space are identical. +!! i/jinta are indices of b-grid locations needed for line integrals +!! around an a-grid cell including ghosting. +!! i/jintb are indices of a-grid locations needed for line integrals +!! around a b-grid cell, no ghosting. + subroutine sorted_intb(isd, ied, jsd, jed, is, ie, js, je, npx, npy, & + cubed_sphere, agrid, iintb, jintb) + integer, intent(in) :: isd, ied, jsd, jed, is, ie, js, je, npx, npy + real(kind=R_GRID), intent(in), dimension(isd:ied,jsd:jed,2) :: agrid + logical, intent(in) :: cubed_sphere + + integer, dimension(4,is:ie+1,js:je+1), intent(out) :: iintb, jintb + !------------------------------------------------------------------! + ! local variables ! + !------------------------------------------------------------------! + real, dimension(4) :: xsort, ysort, xsorted, ysorted + integer, dimension(4) :: isort, jsort, isorted, jsorted + integer :: i, j, l, ll, lll + !------------------------------------------------------------------! + ! special treatment for cubed sphere ! + !------------------------------------------------------------------! + if (cubed_sphere) then + !---------------------------------------------------------------! + ! get order of indices for line integral around b-grid cell ! + !---------------------------------------------------------------! + do j=js,je+1 + do i=is,ie+1 + xsort(1)=agrid(i ,j ,1); ysort(1)=agrid(i ,j ,2); isort(1)=i ; jsort(1)=j + xsort(2)=agrid(i ,j-1,1); ysort(2)=agrid(i ,j-1,2); isort(2)=i ; jsort(2)=j-1 + xsort(3)=agrid(i-1,j-1,1); ysort(3)=agrid(i-1,j-1,2); isort(3)=i-1; jsort(3)=j-1 + xsort(4)=agrid(i-1,j ,1); ysort(4)=agrid(i-1,j ,2); isort(4)=i-1; jsort(4)=j + call sort_rectangle(iintb(1,i,j), jintb(1,i,j)) + enddo + enddo + !---------------------------------------------------------------! + ! take care of corner points ! + !---------------------------------------------------------------! + if ( (is==1) .and. (js==1) ) then + i=1 + j=1 + xsort(1)=agrid(i ,j ,1); ysort(1)=agrid(i ,j ,2); isort(1)=i ; jsort(1)=j + xsort(2)=agrid(i ,j-1,1); ysort(2)=agrid(i ,j-1,2); isort(2)=i ; jsort(2)=j-1 + xsort(3)=agrid(i-1,j ,1); ysort(3)=agrid(i-1,j ,2); isort(3)=i-1; jsort(3)=j + call sort_triangle() + iintb(4,i,j)=i-1; jintb(4,i,j)=j-1 + endif + + if ( (ie+1==npx) .and. (js==1) ) then + i=npx + j=1 + xsort(1)=agrid(i ,j ,1); ysort(1)=agrid(i ,j ,2); isort(1)=i ; jsort(1)=j + xsort(2)=agrid(i-1,j ,1); ysort(2)=agrid(i-1,j ,2); isort(2)=i-1; jsort(2)=j + xsort(3)=agrid(i-1,j-1,1); ysort(3)=agrid(i-1,j-1,2); isort(3)=i-1; jsort(3)=j-1 + call sort_triangle() + iintb(4,i,j)=i; jintb(4,i,j)=j-1 + endif + + if ( (ie+1==npx) .and. (je+1==npy) ) then + i=npx + j=npy + xsort(1)=agrid(i-1,j-1,1); ysort(1)=agrid(i-1,j-1,2); isort(1)=i-1; jsort(1)=j-1 + xsort(2)=agrid(i ,j-1,1); ysort(2)=agrid(i ,j-1,2); isort(2)=i ; jsort(2)=j-1 + xsort(3)=agrid(i-1,j ,1); ysort(3)=agrid(i-1,j ,2); isort(3)=i-1; jsort(3)=j + call sort_triangle() + iintb(4,i,j)=i; jintb(4,i,j)=j + endif + + if ( (is==1) .and. (je+1==npy) ) then + i=1 + j=npy + xsort(1)=agrid(i ,j ,1); ysort(1)=agrid(i ,j ,2); isort(1)=i ; jsort(1)=j + xsort(2)=agrid(i-1,j-1,1); ysort(2)=agrid(i-1,j-1,2); isort(2)=i-1; jsort(2)=j-1 + xsort(3)=agrid(i ,j-1,1); ysort(3)=agrid(i ,j-1,2); isort(3)=i ; jsort(3)=j-1 + call sort_triangle() + iintb(4,i,j)=i-1; jintb(4,i,j)=j + endif + else + !---------------------------------------------------------------! + ! default behavior for other grids ! + !---------------------------------------------------------------! + do j=js,je+1 + do i=is,ie+1 + iintb(1,i,j)=i ; jintb(1,i,j)=j + iintb(2,i,j)=i ; jintb(2,i,j)=j-1 + iintb(3,i,j)=i-1; jintb(3,i,j)=j-1 + iintb(4,i,j)=i-1; jintb(4,i,j)=j + enddo + enddo + endif + + contains + !------------------------------------------------------------------! + subroutine sort_rectangle(iind, jind) + + integer, dimension(4), intent(inout) :: iind, jind + !----------------------------------------------------------------! + ! local variables ! + !----------------------------------------------------------------! + real, dimension(4) :: xsorted, ysorted + integer, dimension(4) :: isorted, jsorted + !----------------------------------------------------------------! + ! sort in east west ! + !----------------------------------------------------------------! + xsorted(:)=10. + ysorted(:)=10. + isorted(:)=0 + jsorted(:)=0 + + do l=1,4 + do ll=1,4 + if (xsort(l) mpp_group_update_type + use mpp_domains_mod, only: nest_domain_type + use mpp_parameter_mod, only : WUPDATE, EUPDATE, SUPDATE, NUPDATE, XUPDATE, YUPDATE + use fv_arrays_stub_mod, only: fv_atmos_type, fv_grid_bounds_type + use fms_io_mod, only: set_domain + use mpp_mod, only : mpp_get_current_pelist, mpp_set_current_pelist + use mpp_domains_mod, only : mpp_get_domain_shift + use ensemble_manager_mod, only : get_ensemble_id + + implicit none + private + + integer, parameter:: ng = 3 ! Number of ghost zones required + integer, parameter :: MAX_NNEST=20, MAX_NTILE=50 + +#include "mpif.h" + integer, parameter :: XDir=1 + integer, parameter :: YDir=2 + integer :: commglobal, ierror, npes + + !need tile as a module variable so that some of the mp_ routines below will work + integer::tile + + integer, allocatable, dimension(:) :: npes_tile, tile1, tile2 + integer, allocatable, dimension(:) :: istart1, iend1, jstart1, jend1 + integer, allocatable, dimension(:) :: istart2, iend2, jstart2, jend2 + integer, allocatable, dimension(:,:) :: layout2D, global_indices + integer :: numthreads, gid, masterproc + + logical :: master + + integer :: this_pe_grid = 0 + integer, EXTERNAL :: omp_get_thread_num, omp_get_num_threads + + integer :: npes_this_grid + + !! CLEANUP: these are currently here for convenience + !! Right now calling switch_current_atm sets these to the value on the "current" grid + !! (as well as changing the "current" domain) + integer :: is, ie, js, je + integer :: isd, ied, jsd, jed + integer :: isc, iec, jsc, jec + + integer, allocatable :: grids_master_procs(:) + integer, dimension(MAX_NNEST) :: tile_fine = 0 !Global index of LAST tile in a mosaic + type(nest_domain_type) :: global_nest_domain !ONE structure for ALL levels of nesting + public commglobal + public mp_start, mp_assign_gid, mp_stop!, npes + public domain_decomp + public fill_corners, XDir, YDir + public switch_current_domain, switch_current_Atm, broadcast_domains + public setup_master + public start_group_halo_update, complete_group_halo_update + public group_halo_update_type, grids_master_procs, tile_fine + public global_nest_domain, MAX_NNEST, MAX_NTILE, ng + + interface start_group_halo_update + module procedure start_var_group_update_2d + module procedure start_var_group_update_3d + module procedure start_var_group_update_4d + module procedure start_vector_group_update_2d + module procedure start_vector_group_update_3d + end interface start_group_halo_update + + INTERFACE fill_corners + MODULE PROCEDURE fill_corners_2d_r4 + MODULE PROCEDURE fill_corners_2d_r8 + MODULE PROCEDURE fill_corners_xy_2d_r4 + MODULE PROCEDURE fill_corners_xy_2d_r8 + MODULE PROCEDURE fill_corners_xy_3d_r4 + MODULE PROCEDURE fill_corners_xy_3d_r8 + END INTERFACE + + INTERFACE fill_corners_agrid + MODULE PROCEDURE fill_corners_agrid_r4 + MODULE PROCEDURE fill_corners_agrid_r8 + END INTERFACE + + INTERFACE fill_corners_cgrid + MODULE PROCEDURE fill_corners_cgrid_r4 + MODULE PROCEDURE fill_corners_cgrid_r8 + END INTERFACE + + INTERFACE fill_corners_dgrid + MODULE PROCEDURE fill_corners_dgrid_r4 + MODULE PROCEDURE fill_corners_dgrid_r8 + END INTERFACE + + !! The routines aggregate elements from many processes into one process. + ! WARNING only works with one level (ldim == 1) + + integer :: halo_update_type = 1 + +contains + + subroutine mp_assign_gid + + gid = mpp_pe() + npes = mpp_npes() + + end subroutine mp_assign_gid + +!------------------------------------------------------------------------------- +! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +!>@brief The subroutine 'mp_start' starts SPMD processes + subroutine mp_start(commID, halo_update_type_in) + integer, intent(in), optional :: commID + integer, intent(in), optional :: halo_update_type_in + + integer :: ios + integer :: unit + + masterproc = mpp_root_pe() + commglobal = MPI_COMM_WORLD + if( PRESENT(commID) )then + commglobal = commID + end if + halo_update_type = halo_update_type_in + + numthreads = 1 +!$OMP PARALLEL +!$OMP MASTER +!$ numthreads = omp_get_num_threads() +!$OMP END MASTER +!$OMP END PARALLEL + + if ( mpp_pe()==mpp_root_pe() ) then + master = .true. + else + master = .false. + endif + + if (mpp_npes() > 1) call MPI_BARRIER(commglobal, ierror) + + end subroutine mp_start +! +! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!------------------------------------------------------------------------------- + + subroutine setup_master(pelist_local) + + integer, intent(IN) :: pelist_local(:) + + if (ANY(gid == pelist_local)) then + + masterproc = pelist_local(1) + master = (gid == masterproc) + + endif + + end subroutine setup_master + + +!------------------------------------------------------------------------------- +! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +!>@brief The subroutine 'mp_stop' stops all SPMD processes + subroutine mp_stop() + + call MPI_BARRIER(commglobal, ierror) + if (gid==masterproc) print*, 'Stopping PEs : ', npes + call fms_end() + ! call MPI_FINALIZE (ierror) + + end subroutine mp_stop +! +! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!------------------------------------------------------------------------------- + +!------------------------------------------------------------------------------- +! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! +!>@brief The subroutine 'domain_decomp' sets up the domain decomposition. + subroutine domain_decomp(npx,npy,nregions,grid_type,nested,layout,io_layout,bd,tile,square_domain,& + npes_per_tile,domain,domain_for_coupler,num_contact,pelist) + integer, intent(IN) :: npx,npy,grid_type + integer, intent(INOUT) :: nregions, tile + logical, intent(IN):: nested + integer, intent(INOUT) :: layout(2), io_layout(2) + + integer, allocatable :: pe_start(:), pe_end(:) + + integer :: nx,ny,n,num_alloc + character(len=32) :: type = "unknown" + logical :: is_symmetry + logical :: debug=.false. + integer, allocatable :: tile_id(:) + + integer i + integer :: npes_x, npes_y + + integer, intent(INOUT) :: pelist(:) + integer, intent(OUT) :: num_contact, npes_per_tile + logical, intent(OUT) :: square_domain + type(domain2D), intent(OUT) :: domain, domain_for_coupler + type(fv_grid_bounds_type), intent(INOUT) :: bd + + nx = npx-1 + ny = npy-1 + + npes_x = layout(1) + npes_y = layout(2) + + + call mpp_domains_init(MPP_DOMAIN_TIME) + + select case(nregions) + case ( 1 ) ! Lat-Lon "cyclic" + + select case (grid_type) + case (0,1,2) !Gnomonic nested grid + if (nested) then + type = "Cubed-sphere nested grid" + else + type = "Cubed-sphere, single face" + end if + nregions = 1 + num_contact = 0 + npes_per_tile = npes_x*npes_y !/nregions !Set up for concurrency + is_symmetry = .true. + call mpp_define_layout( (/1,npx-1,1,npy-1/), npes_per_tile, layout ) + + if ( npes_x == 0 ) then + npes_x = layout(1) + endif + if ( npes_y == 0 ) then + npes_y = layout(2) + endif + + if ( npes_x==npes_y .and. (npx-1)==((npx-1)/npes_x)*npes_x ) square_domain = .true. + + if ( (npx/npes_x < ng) .or. (npy/npes_y < ng) ) then + write(*,310) npes_x, npes_y, npx/npes_x, npy/npes_y + call mp_stop + call exit(1) + endif + + layout = (/npes_x,npes_y/) + case (3) ! Lat-Lon "cyclic" + type="Lat-Lon: cyclic" + nregions = 4 + num_contact = 8 + if( mod(npes,nregions) .NE. 0 ) then + call mpp_error(NOTE,'TEST_MPP_DOMAINS: for Cyclic mosaic, npes should be multiple of nregions. ' // & + 'No test is done for Cyclic mosaic. ' ) + return + end if + npes_per_tile = npes/nregions + call mpp_define_layout( (/1,npx-1,1,npy-1/), npes_per_tile, layout ) + layout = (/1,npes_per_tile/) ! force decomp only in Lat-Direction + case (4) ! Cartesian, double periodic + type="Cartesian: double periodic" + nregions = 1 + num_contact = 2 + npes_per_tile = npes/nregions + if(npes_x*npes_y == npes_per_tile) then + layout = (/npes_x,npes_y/) + else + call mpp_define_layout( (/1,npx-1,1,npy-1/), npes_per_tile, layout ) + endif + case (5) ! latlon patch + type="Lat-Lon: patch" + nregions = 1 + num_contact = 0 + npes_per_tile = npes/nregions + call mpp_define_layout( (/1,npx-1,1,npy-1/), npes_per_tile, layout ) + case (6) ! latlon strip + type="Lat-Lon: strip" + nregions = 1 + num_contact = 1 + npes_per_tile = npes/nregions + call mpp_define_layout( (/1,npx-1,1,npy-1/), npes_per_tile, layout ) + case (7) ! Cartesian, channel + type="Cartesian: channel" + nregions = 1 + num_contact = 1 + npes_per_tile = npes/nregions + call mpp_define_layout( (/1,npx-1,1,npy-1/), npes_per_tile, layout ) + end select + + case ( 6 ) ! Cubed-Sphere + type="Cubic: cubed-sphere" + if (nested) then + call mpp_error(FATAL, 'For a nested grid with grid_type < 3 nregions_domain must equal 1.') + endif + nregions = 6 + num_contact = 12 + !--- cubic grid always have six tiles, so npes should be multiple of 6 + npes_per_tile = npes_x*npes_y + call mpp_define_layout( (/1,npx-1,1,npy-1/), npes_per_tile, layout ) + + if ( npes_x == 0 ) then + npes_x = layout(1) + endif + if ( npes_y == 0 ) then + npes_y = layout(2) + endif + + if ( npes_x==npes_y .and. (npx-1)==((npx-1)/npes_x)*npes_x ) square_domain = .true. + + if ( (npx/npes_x < ng) .or. (npy/npes_y < ng) ) then + write(*,310) npes_x, npes_y, npx/npes_x, npy/npes_y + 310 format('Invalid layout, NPES_X:',i4.4,'NPES_Y:',i4.4,'ncells_X:',i4.4,'ncells_Y:',i4.4) + call mp_stop + call exit(1) + endif + + layout = (/npes_x,npes_y/) + case default + call mpp_error(FATAL, 'domain_decomp: no such test: '//type) + end select + + allocate(layout2D(2,nregions), global_indices(4,nregions), npes_tile(nregions) ) + allocate(pe_start(nregions),pe_end(nregions)) + npes_tile = npes_per_tile + do n = 1, nregions + global_indices(:,n) = (/1,npx-1,1,npy-1/) + layout2D(:,n) = layout + pe_start(n) = pelist(1) + (n-1)*layout(1)*layout(2) + pe_end(n) = pe_start(n) + layout(1)*layout(2) -1 + end do + num_alloc=max(1,num_contact) + allocate(tile1(num_alloc), tile2(num_alloc) ) + allocate(istart1(num_alloc), iend1(num_alloc), jstart1(num_alloc), jend1(num_alloc) ) + allocate(istart2(num_alloc), iend2(num_alloc), jstart2(num_alloc), jend2(num_alloc) ) + + is_symmetry = .true. + select case(nregions) + case ( 1 ) + + select case (grid_type) + case (0,1,2) !Gnomonic nested grid + !No contacts, don't need to do anything + case (3) ! Lat-Lon "cyclic" + !--- Contact line 1, between tile 1 (EAST) and tile 2 (WEST) + tile1(1) = 1; tile2(1) = 2 + istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1; jend1(1) = ny + istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = ny + !--- Contact line 2, between tile 1 (SOUTH) and tile 3 (NORTH) --- cyclic + tile1(2) = 1; tile2(2) = 3 + istart1(2) = 1; iend1(2) = nx; jstart1(2) = 1; jend1(2) = 1 + istart2(2) = 1; iend2(2) = nx; jstart2(2) = ny; jend2(2) = ny + !--- Contact line 3, between tile 1 (WEST) and tile 2 (EAST) --- cyclic + tile1(3) = 1; tile2(3) = 2 + istart1(3) = 1; iend1(3) = 1; jstart1(3) = 1; jend1(3) = ny + istart2(3) = nx; iend2(3) = nx; jstart2(3) = 1; jend2(3) = ny + !--- Contact line 4, between tile 1 (NORTH) and tile 3 (SOUTH) + tile1(4) = 1; tile2(4) = 3 + istart1(4) = 1; iend1(4) = nx; jstart1(4) = ny; jend1(4) = ny + istart2(4) = 1; iend2(4) = nx; jstart2(4) = 1; jend2(4) = 1 + !--- Contact line 5, between tile 2 (SOUTH) and tile 4 (NORTH) --- cyclic + tile1(5) = 2; tile2(5) = 4 + istart1(5) = 1; iend1(5) = nx; jstart1(5) = 1; jend1(5) = 1 + istart2(5) = 1; iend2(5) = nx; jstart2(5) = ny; jend2(5) = ny + !--- Contact line 6, between tile 2 (NORTH) and tile 4 (SOUTH) + tile1(6) = 2; tile2(6) = 4 + istart1(6) = 1; iend1(6) = nx; jstart1(6) = ny; jend1(6) = ny + istart2(6) = 1; iend2(6) = nx; jstart2(6) = 1; jend2(6) = 1 + !--- Contact line 7, between tile 3 (EAST) and tile 4 (WEST) + tile1(7) = 3; tile2(7) = 4 + istart1(7) = nx; iend1(7) = nx; jstart1(7) = 1; jend1(7) = ny + istart2(7) = 1; iend2(7) = 1; jstart2(7) = 1; jend2(7) = ny + !--- Contact line 8, between tile 3 (WEST) and tile 4 (EAST) --- cyclic + tile1(8) = 3; tile2(8) = 4 + istart1(8) = 1; iend1(8) = 1; jstart1(8) = 1; jend1(8) = ny + istart2(8) = nx; iend2(8) = nx; jstart2(8) = 1; jend2(8) = ny + is_symmetry = .false. + case (4) ! Cartesian, double periodic + !--- Contact line 1, between tile 1 (EAST) and tile 1 (WEST) + tile1(1) = 1; tile2(1) = 1 + istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1; jend1(1) = ny + istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = ny + !--- Contact line 2, between tile 1 (SOUTH) and tile 1 (NORTH) --- cyclic + tile1(2) = 1; tile2(2) = 1 + istart1(2) = 1; iend1(2) = nx; jstart1(2) = 1; jend1(2) = 1 + istart2(2) = 1; iend2(2) = nx; jstart2(2) = ny; jend2(2) = ny + case (5) ! latlon patch + + case (6) !latlon strip + !--- Contact line 1, between tile 1 (EAST) and tile 1 (WEST) + tile1(1) = 1; tile2(1) = 1 + istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1; jend1(1) = ny + istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = ny + case (7) ! Cartesian, channel + !--- Contact line 1, between tile 1 (EAST) and tile 1 (WEST) + tile1(1) = 1; tile2(1) = 1 + istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1; jend1(1) = ny + istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = ny + end select + + case ( 6 ) ! Cubed-Sphere + !--- Contact line 1, between tile 1 (EAST) and tile 2 (WEST) + tile1(1) = 1; tile2(1) = 2 + istart1(1) = nx; iend1(1) = nx; jstart1(1) = 1; jend1(1) = ny + istart2(1) = 1; iend2(1) = 1; jstart2(1) = 1; jend2(1) = ny + !--- Contact line 2, between tile 1 (NORTH) and tile 3 (WEST) + tile1(2) = 1; tile2(2) = 3 + istart1(2) = 1; iend1(2) = nx; jstart1(2) = ny; jend1(2) = ny + istart2(2) = 1; iend2(2) = 1; jstart2(2) = ny; jend2(2) = 1 + !--- Contact line 3, between tile 1 (WEST) and tile 5 (NORTH) + tile1(3) = 1; tile2(3) = 5 + istart1(3) = 1; iend1(3) = 1; jstart1(3) = 1; jend1(3) = ny + istart2(3) = nx; iend2(3) = 1; jstart2(3) = ny; jend2(3) = ny + !--- Contact line 4, between tile 1 (SOUTH) and tile 6 (NORTH) + tile1(4) = 1; tile2(4) = 6 + istart1(4) = 1; iend1(4) = nx; jstart1(4) = 1; jend1(4) = 1 + istart2(4) = 1; iend2(4) = nx; jstart2(4) = ny; jend2(4) = ny + !--- Contact line 5, between tile 2 (NORTH) and tile 3 (SOUTH) + tile1(5) = 2; tile2(5) = 3 + istart1(5) = 1; iend1(5) = nx; jstart1(5) = ny; jend1(5) = ny + istart2(5) = 1; iend2(5) = nx; jstart2(5) = 1; jend2(5) = 1 + !--- Contact line 6, between tile 2 (EAST) and tile 4 (SOUTH) + tile1(6) = 2; tile2(6) = 4 + istart1(6) = nx; iend1(6) = nx; jstart1(6) = 1; jend1(6) = ny + istart2(6) = nx; iend2(6) = 1; jstart2(6) = 1; jend2(6) = 1 + !--- Contact line 7, between tile 2 (SOUTH) and tile 6 (EAST) + tile1(7) = 2; tile2(7) = 6 + istart1(7) = 1; iend1(7) = nx; jstart1(7) = 1; jend1(7) = 1 + istart2(7) = nx; iend2(7) = nx; jstart2(7) = ny; jend2(7) = 1 + !--- Contact line 8, between tile 3 (EAST) and tile 4 (WEST) + tile1(8) = 3; tile2(8) = 4 + istart1(8) = nx; iend1(8) = nx; jstart1(8) = 1; jend1(8) = ny + istart2(8) = 1; iend2(8) = 1; jstart2(8) = 1; jend2(8) = ny + !--- Contact line 9, between tile 3 (NORTH) and tile 5 (WEST) + tile1(9) = 3; tile2(9) = 5 + istart1(9) = 1; iend1(9) = nx; jstart1(9) = ny; jend1(9) = ny + istart2(9) = 1; iend2(9) = 1; jstart2(9) = ny; jend2(9) = 1 + !--- Contact line 10, between tile 4 (NORTH) and tile 5 (SOUTH) + tile1(10) = 4; tile2(10) = 5 + istart1(10) = 1; iend1(10) = nx; jstart1(10) = ny; jend1(10) = ny + istart2(10) = 1; iend2(10) = nx; jstart2(10) = 1; jend2(10) = 1 + !--- Contact line 11, between tile 4 (EAST) and tile 6 (SOUTH) + tile1(11) = 4; tile2(11) = 6 + istart1(11) = nx; iend1(11) = nx; jstart1(11) = 1; jend1(11) = ny + istart2(11) = nx; iend2(11) = 1; jstart2(11) = 1; jend2(11) = 1 + !--- Contact line 12, between tile 5 (EAST) and tile 6 (WEST) + tile1(12) = 5; tile2(12) = 6 + istart1(12) = nx; iend1(12) = nx; jstart1(12) = 1; jend1(12) = ny + istart2(12) = 1; iend2(12) = 1; jstart2(12) = 1; jend2(12) = ny + end select + + if ( ANY(pelist == gid) ) then + allocate(tile_id(nregions)) + if( nested ) then + if( nregions .NE. 1 ) then + call mpp_error(FATAL, 'domain_decomp: nregions should be 1 for nested region, contact developer') + endif + tile_id(1) = 7 ! TODO need update for multiple nests + else + do n = 1, nregions + tile_id(n) = n + enddo + endif + call mpp_define_mosaic(global_indices, layout2D, domain, nregions, num_contact, tile1, tile2, & + istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, & + pe_start=pe_start, pe_end=pe_end, symmetry=is_symmetry, & + shalo = ng, nhalo = ng, whalo = ng, ehalo = ng, tile_id=tile_id, name = type) + call mpp_define_mosaic(global_indices, layout2D, domain_for_coupler, nregions, num_contact, tile1, tile2, & + istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, & + pe_start=pe_start, pe_end=pe_end, symmetry=is_symmetry, & + shalo = 1, nhalo = 1, whalo = 1, ehalo = 1, tile_id=tile_id, name = type) + deallocate(tile_id) + call mpp_define_io_domain(domain, io_layout) + call mpp_define_io_domain(domain_for_coupler, io_layout) + + endif + + deallocate(pe_start,pe_end) + deallocate(layout2D, global_indices, npes_tile) + deallocate(tile1, tile2) + deallocate(istart1, iend1, jstart1, jend1) + deallocate(istart2, iend2, jstart2, jend2) + + !--- find the tile number + tile = (gid-pelist(1))/npes_per_tile+1 + if (ANY(pelist == gid)) then + npes_this_grid = npes_per_tile*nregions + tile = tile + call mpp_get_compute_domain( domain, is, ie, js, je ) + call mpp_get_data_domain ( domain, isd, ied, jsd, jed ) + + bd%is = is + bd%js = js + bd%ie = ie + bd%je = je + + bd%isd = isd + bd%jsd = jsd + bd%ied = ied + bd%jed = jed + + bd%isc = is + bd%jsc = js + bd%iec = ie + bd%jec = je + + if (debug .and. nregions==1) then + tile=1 + write(*,200) tile, is, ie, js, je + ! call mp_stop + ! stop + endif +200 format(i4.4, ' ', i4.4, ' ', i4.4, ' ', i4.4, ' ', i4.4, ' ') + else + + bd%is = 0 + bd%js = 0 + bd%ie = -1 + bd%je = -1 + + bd%isd = 0 + bd%jsd = 0 + bd%ied = -1 + bd%jed = -1 + + bd%isc = 0 + bd%jsc = 0 + bd%iec = -1 + bd%jec = -1 + + endif + + end subroutine domain_decomp +! +! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!------------------------------------------------------------------------------- + +subroutine start_var_group_update_2d(group, array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete) + type(group_halo_update_type), intent(inout) :: group !< The data type that store information for group update + real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points exchanged + type(domain2D), intent(inout) :: domain !< contains domain information + integer, optional, intent(in) :: flags !< Optional integer indicating which directions the data should be sent + integer, optional, intent(in) :: position !< An optional argument indicating the position + integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo + logical, optional, intent(in) :: complete !< Optional argument indicating whether the halo updates + !! should be initiated immediately or wait for second pass_..._start call + real :: d_type + logical :: is_complete +! Arguments: +! (inout) group - The data type that store information for group update. +! This data will be used in do_group_pass. +! (inout) array - The array which is having its halos points exchanged. +! (in) domain - contains domain information. +! (in) flags - An optional integer indicating which directions the +! data should be sent. +! (in) position - An optional argument indicating the position. This is +! may be CORNER, but is CENTER by default. +! (in) complete - An optional argument indicating whether the halo updates +! should be initiated immediately or wait for second +! pass_..._start call. Omitting complete is the same as +! setting complete to .true. + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,array) + else + call mpp_create_group_update(group, array, domain, flags=flags, position=position, & + whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo) + endif + + is_complete = .TRUE. + if(present(complete)) is_complete = complete + if(is_complete .and. halo_update_type == 1) then + call mpp_start_group_update(group, domain, d_type) + endif + +end subroutine start_var_group_update_2d + + +subroutine start_var_group_update_3d(group, array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete) + type(group_halo_update_type), intent(inout) :: group !< The data type that store information for group update + real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points exchanged + type(domain2D), intent(inout) :: domain !< contains domain information + integer, optional, intent(in) :: flags !< Optional integer indicating which directions the data should be sent + integer, optional, intent(in) :: position !< An optional argument indicating the position + integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo + logical, optional, intent(in) :: complete !< Optional argument indicating whether the halo updates + !! should be initiated immediately or wait for second pass_..._start call + real :: d_type + logical :: is_complete + +! Arguments: +! (inout) group - The data type that store information for group update. +! This data will be used in do_group_pass. +! (inout) array - The array which is having its halos points exchanged. +! (in) domain - contains domain information. +! (in) flags - An optional integer indicating which directions the +! data should be sent. +! (in) position - An optional argument indicating the position. This is +! may be CORNER, but is CENTER by default. +! (in) complete - An optional argument indicating whether the halo updates +! should be initiated immediately or wait for second +! pass_..._start call. Omitting complete is the same as +! setting complete to .true. + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,array) + else + call mpp_create_group_update(group, array, domain, flags=flags, position=position, & + whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo) + endif + + is_complete = .TRUE. + if(present(complete)) is_complete = complete + if(is_complete .and. halo_update_type == 1 ) then + call mpp_start_group_update(group, domain, d_type) + endif + +end subroutine start_var_group_update_3d + +subroutine start_var_group_update_4d(group, array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete) + type(group_halo_update_type), intent(inout) :: group !< The data type that store information for group update + real, dimension(:,:,:,:), intent(inout) :: array !< The array which is having its halos points exchanged + type(domain2D), intent(inout) :: domain !< contains domain information + integer, optional, intent(in) :: flags !< Optional integer indicating which directions the data should be sent + integer, optional, intent(in) :: position !< An optional argument indicating the position + !! This is may be CORNER, but is CENTER by default + integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo + logical, optional, intent(in) :: complete !< Optional argument indicating whether the halo updates + !! should be initiated immediately or wait for second pass_..._start call + real :: d_type + logical :: is_complete + +! Arguments: +! (inout) group - The data type that store information for group update. +! This data will be used in do_group_pass. +! (inout) array - The array which is having its halos points exchanged. +! (in) domain - contains domain information. +! (in) flags - An optional integer indicating which directions the +! data should be sent. +! (in) position - An optional argument indicating the position. This is +! may be CORNER, but is CENTER by default. +! (in) complete - An optional argument indicating whether the halo updates +! should be initiated immediately or wait for second +! pass_..._start call. Omitting complete is the same as +! setting complete to .true. + + integer :: dirflag + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,array) + else + call mpp_create_group_update(group, array, domain, flags=flags, position=position, & + whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo) + endif + + is_complete = .TRUE. + if(present(complete)) is_complete = complete + if(is_complete .and. halo_update_type == 1 ) then + call mpp_start_group_update(group, domain, d_type) + endif + +end subroutine start_var_group_update_4d + + + +subroutine start_vector_group_update_2d(group, u_cmpt, v_cmpt, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete) + type(group_halo_update_type), intent(inout) :: group !< The data type that store information for group update + real, dimension(:,:), intent(inout) :: u_cmpt, v_cmpt !< The nominal zonal (u) and meridional (v) + !! components of the vector pair that + !! is having its halos points exchanged + type(domain2d), intent(inout) :: domain !< Contains domain decomposition information + integer, optional, intent(in) :: flags !< Optional integer indicating which directions the data should be sent + integer, optional, intent(in) :: gridtype !< An optional flag, which may be one of A_GRID, BGRID_NE, + !! CGRID_NE or DGRID_NE, indicating where the two components of th + !! vector are discretized + integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo + logical, optional, intent(in) :: complete !< Optional argument indicating whether the halo updates + !! should be initiated immediately or wait for second pass_..._start call + real :: d_type + logical :: is_complete + +! Arguments: +! (inout) group - The data type that store information for group update. +! This data will be used in do_group_pass. +! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which +! is having its halos points exchanged. +! (inout) v_cmpt - The nominal meridional (v) component of the vector pair +! which is having its halos points exchanged. +! (in) domain - Contains domain decomposition information. +! (in) flags - An optional integer indicating which directions the +! data should be sent. +! (in) gridtype - An optional flag, which may be one of A_GRID, BGRID_NE, +! CGRID_NE or DGRID_NE, indicating where the two components of the +! vector are discretized. +! (in) complete - An optional argument indicating whether the halo updates +! should be initiated immediately or wait for second +! pass_..._start call. Omitting complete is the same as +! setting complete to .true. + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) + else + call mpp_create_group_update(group, u_cmpt, v_cmpt, domain, & + flags=flags, gridtype=gridtype, & + whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo) + endif + + is_complete = .TRUE. + if(present(complete)) is_complete = complete + if(is_complete .and. halo_update_type == 1 ) then + call mpp_start_group_update(group, domain, d_type) + endif + +end subroutine start_vector_group_update_2d + +subroutine start_vector_group_update_3d(group, u_cmpt, v_cmpt, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete) + type(group_halo_update_type), intent(inout) :: group !< The data type that store information for group update + real, dimension(:,:,:), intent(inout) :: u_cmpt, v_cmpt !! The nominal zonal (u) and meridional (v) + !! components of the vector pair that + !! is having its halos points exchanged. + type(domain2d), intent(inout) :: domain !< Contains domain decomposition information + integer, optional, intent(in) :: flags !< Optional integer indicating which directions the data should be sent + integer, optional, intent(in) :: gridtype !< An optional flag, which may be one of A_GRID, BGRID_NE, + !! CGRID_NE or DGRID_NE, indicating where the two components of th + !! vector are discretized + integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo + logical, optional, intent(in) :: complete !< Optional argument indicating whether the halo updates + !! should be initiated immediately or wait for second pass_..._start call + real :: d_type + logical :: is_complete + +! Arguments: +! (inout) group - The data type that store information for group update. +! This data will be used in do_group_pass. +! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which +! is having its halos points exchanged. +! (inout) v_cmpt - The nominal meridional (v) component of the vector pair +! which is having its halos points exchanged. +! (in) domain - Contains domain decomposition information. +! (in) flags - An optional integer indicating which directions the +! data should be sent. +! (in) gridtype - An optional flag, which may be one of A_GRID, BGRID_NE, +! CGRID_NE or DGRID_NE, indicating where the two components of the +! vector are discretized. +! (in) complete - An optional argument indicating whether the halo updates +! should be initiated immediately or wait for second +! pass_..._start call. Omitting complete is the same as +! setting complete to .true. + + if (mpp_group_update_initialized(group)) then + call mpp_reset_group_update_field(group,u_cmpt, v_cmpt) + else + call mpp_create_group_update(group, u_cmpt, v_cmpt, domain, & + flags=flags, gridtype=gridtype, & + whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo) + endif + + is_complete = .TRUE. + if(present(complete)) is_complete = complete + if(is_complete .and. halo_update_type == 1) then + call mpp_start_group_update(group, domain, d_type) + endif + +end subroutine start_vector_group_update_3d + + +subroutine complete_group_halo_update(group, domain) + type(group_halo_update_type), intent(inout) :: group !< The data type that store information for group update + type(domain2d), intent(inout) :: domain !< Contains domain decomposition information + real :: d_type + +! Arguments: +! (inout) group - The data type that store information for group update. +! (in) domain - Contains domain decomposition information. + + if( halo_update_type == 1 ) then + call mpp_complete_group_update(group, domain, d_type) + else + call mpp_do_group_update(group, domain, d_type) + endif + +end subroutine complete_group_halo_update + + + +!Depreciated +subroutine broadcast_domains(Atm,current_pelist,current_npes) + + type(fv_atmos_type), intent(INOUT) :: Atm(:) + integer, intent(IN) :: current_npes + integer, intent(IN) :: current_pelist(current_npes) + + integer :: n, i + integer :: ens_root_pe, ensemble_id + + !I think the idea is that each process needs to properly be part of a pelist, + !the pelist on which the domain is currently defined is ONLY for the pes which have the domain. + + ! This is needed to set the proper pelist for the ensemble. The pelist + ! needs to include the non-nested+nested tile for the ensemble. + ensemble_id = get_ensemble_id() + ens_root_pe = (ensemble_id-1)*npes + + !Pelist needs to be set to ALL ensemble PEs for broadcast_domain to work + call mpp_set_current_pelist((/ (i,i=ens_root_pe,npes-1+ens_root_pe) /)) + do n=1,size(Atm) + call mpp_broadcast_domain(Atm(n)%domain) + call mpp_broadcast_domain(Atm(n)%domain_for_coupler) + end do + call mpp_set_current_pelist(current_pelist) + +end subroutine broadcast_domains + +!depreciated +subroutine switch_current_domain(new_domain,new_domain_for_coupler) + + type(domain2D), intent(in), target :: new_domain, new_domain_for_coupler + logical, parameter :: debug = .FALSE. + + !--- find the tile number + !tile = mpp_pe()/npes_per_tile+1 + !ntiles = mpp_get_ntile_count(new_domain) + call mpp_get_compute_domain( new_domain, is, ie, js, je ) + isc = is ; jsc = js + iec = ie ; jec = je + call mpp_get_data_domain ( new_domain, isd, ied, jsd, jed ) +! if ( npes_x==npes_y .and. (npx-1)==((npx-1)/npes_x)*npes_x ) square_domain = .true. + +! if (debug .AND. (gid==masterproc)) write(*,200) tile, is, ie, js, je +!200 format('New domain: ', i4.4, ' ', i4.4, ' ', i4.4, ' ', i4.4, ' ', i4.4, ' ') + + call set_domain(new_domain) + + +end subroutine switch_current_domain + +!depreciated +subroutine switch_current_Atm(new_Atm, switch_domain) + + type(fv_atmos_type), intent(IN), target :: new_Atm + logical, intent(IN), optional :: switch_domain + logical, parameter :: debug = .false. + logical :: swD + + + call mpp_error(FATAL, "switch_current_Atm depreciated. call set_domain instead.") + +!!$ if (debug .AND. (gid==masterproc)) print*, 'SWITCHING ATM STRUCTURES', new_Atm%grid_number +!!$ if (present(switch_domain)) then +!!$ swD = switch_domain +!!$ else +!!$ swD = .true. +!!$ end if +!!$ if (swD) call switch_current_domain(new_Atm%domain, new_Atm%domain_for_coupler) + +!!$ if (debug .AND. (gid==masterproc)) WRITE(*,'(A, 6I5)') 'NEW GRID DIMENSIONS: ', & +!!$ isd, ied, jsd, jed, new_Atm%npx, new_Atm%npy + +end subroutine switch_current_Atm + +!------------------------------------------------------------------------------- +! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !! +! + subroutine fill_corners_2d_r4(q, npx, npy, FILL, AGRID, BGRID) + real(kind=4), DIMENSION(isd:,jsd:), intent(INOUT):: q + integer, intent(IN):: npx,npy + integer, intent(IN):: FILL !< X-Dir or Y-Dir + logical, OPTIONAL, intent(IN) :: AGRID, BGRID + integer :: i,j + + if (present(BGRID)) then + if (BGRID) then + select case (FILL) + case (XDir) + do j=1,ng + do i=1,ng + if ((is== 1) .and. (js== 1)) q(1-i ,1-j ) = q(1-j ,i+1 ) !SW Corner + if ((is== 1) .and. (je==npy-1)) q(1-i ,npy+j) = q(1-j ,npy-i ) !NW Corner + if ((ie==npx-1) .and. (js== 1)) q(npx+i,1-j ) = q(npx+j,i+1 ) !SE Corner + if ((ie==npx-1) .and. (je==npy-1)) q(npx+i,npy+j) = q(npx+j,npy-i ) !NE Corner + enddo + enddo + case (YDir) + do j=1,ng + do i=1,ng + if ((is== 1) .and. (js== 1)) q(1-j ,1-i ) = q(i+1 ,1-j ) !SW Corner + if ((is== 1) .and. (je==npy-1)) q(1-j ,npy+i) = q(i+1 ,npy+j ) !NW Corner + if ((ie==npx-1) .and. (js== 1)) q(npx+j,1-i ) = q(npx-i,1-j ) !SE Corner + if ((ie==npx-1) .and. (je==npy-1)) q(npx+j,npy+i) = q(npx-i,npy+j ) !NE Corner + enddo + enddo + case default + do j=1,ng + do i=1,ng + if ((is== 1) .and. (js== 1)) q(1-i ,1-j ) = q(1-j ,i+1 ) !SW Corner + if ((is== 1) .and. (je==npy-1)) q(1-i ,npy+j) = q(1-j ,npy-i ) !NW Corner + if ((ie==npx-1) .and. (js== 1)) q(npx+i,1-j ) = q(npx+j,i+1 ) !SE Corner + if ((ie==npx-1) .and. (je==npy-1)) q(npx+i,npy+j) = q(npx+j,npy-i ) !NE Corner + enddo + enddo + end select + endif + elseif (present(AGRID)) then + if (AGRID) then + select case (FILL) + case (XDir) + do j=1,ng + do i=1,ng + if ((is== 1) .and. (js== 1)) q(1-i ,1-j ) = q(1-j ,i ) !SW Corner + if ((is== 1) .and. (je==npy-1)) q(1-i ,npy-1+j) = q(1-j ,npy-1-i+1) !NW Corner + if ((ie==npx-1) .and. (js== 1)) q(npx-1+i,1-j ) = q(npx-1+j,i ) !SE Corner + if ((ie==npx-1) .and. (je==npy-1)) q(npx-1+i,npy-1+j) = q(npx-1+j,npy-1-i+1) !NE Corner + enddo + enddo + case (YDir) + do j=1,ng + do i=1,ng + if ((is== 1) .and. (js== 1)) q(1-j ,1-i ) = q(i ,1-j ) !SW Corner + if ((is== 1) .and. (je==npy-1)) q(1-j ,npy-1+i) = q(i ,npy-1+j) !NW Corner + if ((ie==npx-1) .and. (js== 1)) q(npx-1+j,1-i ) = q(npx-1-i+1,1-j ) !SE Corner + if ((ie==npx-1) .and. (je==npy-1)) q(npx-1+j,npy-1+i) = q(npx-1-i+1,npy-1+j) !NE Corner + enddo + enddo + case default + do j=1,ng + do i=1,ng + if ((is== 1) .and. (js== 1)) q(1-j ,1-i ) = q(i ,1-j ) !SW Corner + if ((is== 1) .and. (je==npy-1)) q(1-j ,npy-1+i) = q(i ,npy-1+j) !NW Corner + if ((ie==npx-1) .and. (js== 1)) q(npx-1+j,1-i ) = q(npx-1-i+1,1-j ) !SE Corner + if ((ie==npx-1) .and. (je==npy-1)) q(npx-1+j,npy-1+i) = q(npx-1-i+1,npy-1+j) !NE Corner + enddo + enddo + end select + endif + endif + + end subroutine fill_corners_2d_r4 +! +! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ! +!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- +! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !! +! + subroutine fill_corners_2d_r8(q, npx, npy, FILL, AGRID, BGRID) + real(kind=8), DIMENSION(isd:,jsd:), intent(INOUT):: q + integer, intent(IN):: npx,npy + integer, intent(IN):: FILL ! /dev/null | cat ) +__ms_bash_test=$( eval 'if ( set | grep '$__ms_function_name' | grep -v name > /dev/null 2>&1 ) ; then echo t ; fi ' 2> /dev/null | cat ) + +if [[ ! -z "$__ms_ksh_test" ]] ; then + __ms_shell=ksh +elif [[ ! -z "$__ms_bash_test" ]] ; then + __ms_shell=bash +else + # Not bash or ksh, so assume sh. + __ms_shell=sh +fi + +if [[ -d /lfs3 ]] ; then + # We are on NOAA Jet + if ( ! eval module help > /dev/null 2>&1 ) ; then + source /apps/lmod/lmod/init/$__ms_shell + fi + module purge +elif [[ -d /scratch1 && ! -d /scratch ]] ; then + # We are on NOAA Hera + if ( ! eval module help > /dev/null 2>&1 ) ; then + source /apps/lmod/lmod/init/$__ms_shell + fi + module purge +elif [[ -d /work/noaa ]] ; then + # We are on Orion + if ( ! eval module help > /dev/null 2>&1 ) ; then + source /apps/lmod/init/$__ms_shell + fi + module purge +elif [[ -d /data ]] ; then + # We are on SSEC Wisconsin S4 + if ( ! eval module help > /dev/null 2>&1 ) ; then + source /usr/share/lmod/lmod/init/$__ms_shell + fi + module purge +elif [[ -d /gpfs/hps && -e /etc/SuSE-release ]] ; then + # We are on NOAA Luna or Surge + if ( ! eval module help > /dev/null 2>&1 ) ; then + source /opt/modules/default/init/$__ms_shell + fi + module purge + module purge + # Workaround until module issues are fixed: + unset _LMFILES_ + unset LOADEDMODULES + module use /opt/modulefiles + module use /opt/cray/ari/modulefiles + module use /opt/cray/craype/default/alt-modulefiles + module use /opt/cray/alt-modulefiles + module use /gpfs/hps/nco/ops/nwprod/modulefiles + module use /gpfs/hps/nco/ops/nwprod/lib/modulefiles + module use /usrx/local/prod/modulefiles +elif [[ -d /dcom && -d /hwrf ]] ; then + # We are on NOAA Tide or Gyre + if ( ! eval module help > /dev/null 2>&1 ) ; then + source /usrx/local/Modules/default/init/$__ms_shell + fi + module purge +elif [[ -L /usrx && "$( readlink /usrx 2> /dev/null )" =~ dell ]] ; then + # We are on NOAA Mars or Venus + if ( ! eval module help > /dev/null 2>&1 ) ; then + source /usrx/local/prod/lmod/lmod/init/$__ms_shell + fi + module purge +elif [[ -d /glade ]] ; then + # We are on NCAR Cheyenne + if ( ! eval module help > /dev/null 2>&1 ) ; then + . /glade/u/apps/ch/modulefiles/default/localinit/localinit.sh + fi + module purge +elif [[ -d /work/stampede ]] ; then + # We are on TACC Stampede + if ( ! eval module help > /dev/null 2>&1 ) ; then + source /opt/apps/lmod/lmod/init/bash + fi + module purge +elif [[ -d /lustre && -d /ncrc ]] ; then + # We are on GAEA. + if ( ! eval module help > /dev/null 2>&1 ) ; then + # We cannot simply load the module command. The GAEA + # /etc/profile modifies a number of module-related variables + # before loading the module command. Without those variables, + # the module command fails. Hence we actually have to source + # /etc/profile here. + source /etc/profile + __ms_source_etc_profile=yes + else + __ms_source_etc_profile=no + fi + module purge +# clean up after purge + unset _LMFILES_ + unset _LMFILES_000 + unset _LMFILES_001 + unset LOADEDMODULES + module load modules + if [[ -d /opt/cray/ari/modulefiles ]] ; then + module use -a /opt/cray/ari/modulefiles + fi + if [[ -d /opt/cray/pe/ari/modulefiles ]] ; then + module use -a /opt/cray/pe/ari/modulefiles + fi + if [[ -d /opt/cray/pe/craype/default/modulefiles ]] ; then + module use -a /opt/cray/pe/craype/default/modulefiles + fi + if [[ -s /etc/opt/cray/pe/admin-pe/site-config ]] ; then + source /etc/opt/cray/pe/admin-pe/site-config + fi + export NCEPLIBS=/lustre/f1/pdata/ncep_shared/NCEPLIBS/lib + if [[ -d "$NCEPLIBS" ]] ; then + module use $NCEPLIBS/modulefiles + fi + if [[ "$__ms_source_etc_profile" == yes ]] ; then + source /etc/profile + unset __ms_source_etc_profile + fi +elif [[ -d /Applications ]] ; then + # We are on a MacOSX system, nothing to do + echo "Platform: MacOSX" +elif [[ -e /etc/redhat-release ]] ; then + if grep -iq centos "/etc/redhat-release" ; then + # We are on CentOS Linux, nothing to do + echo "Platform: CentOS Linux" + else + echo WARNING: UNKNOWN PLATFORM 1>&2 + fi +elif [[ -e /etc/issue ]] ; then + if grep -iq ubuntu "/etc/issue" ; then + # We are on Ubuntu Linux, nothing to do + echo "Platform: Ubuntu Linux" + else + echo WARNING: UNKNOWN PLATFORM 1>&2 + fi +else + echo WARNING: UNKNOWN PLATFORM 1>&2 +fi + +unset __ms_shell +unset __ms_ksh_test +unset __ms_bash_test +unset $__ms_function_name +unset __ms_function_name diff --git a/unit_tests/modules.hera.intel b/unit_tests/modules.hera.intel new file mode 100644 index 00000000..88d05070 --- /dev/null +++ b/unit_tests/modules.hera.intel @@ -0,0 +1,26 @@ +#%Module + +proc ModulesHelp {} { + puts stderr "\tcit - loads modules required for building and running UFS Model on Hera/Intel" +} + +module-whatis "loads UFS Model prerequisites for Hera/Intel" + +module use /contrib/sutils/modulefiles +module load sutils + +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 jasper/2.0.22 +module load zlib/1.2.11 +module load png/1.6.35 + +module load hdf5/1.10.6 +module load netcdf/4.7.4 +module load pio/2.5.2 +module load esmf/8_2_0_beta_snapshot_14 +module load fms/2021.03-avx diff --git a/unit_tests/modules.orion.intel b/unit_tests/modules.orion.intel new file mode 100644 index 00000000..f9ccf9fd --- /dev/null +++ b/unit_tests/modules.orion.intel @@ -0,0 +1,35 @@ +#%Module + +proc ModulesHelp {} { + puts stderr "\tcit - loads modules required for building and running UFS Model on Orion/Intel" +} + +module-whatis "loads UFS Model prerequisites for Orion/Intel" + +module load contrib noaatools + +module load cmake/3.18.1 +module load python/3.7.5 + +module use /apps/contrib/NCEP/libs/hpc-stack/modulefiles/stack + +module load hpc/1.1.0 +module load hpc-intel/2018.4 +module load hpc-impi/2018.4 + +module load ufs_common + +setenv CC mpiicc +setenv CXX mpiicpc +setenv FC mpiifort +setenv CMAKE_Platform orion.intel + +module load jasper/2.0.22 +module load zlib/1.2.11 +module load png/1.6.35 + +module load hdf5/1.10.6 +module load netcdf/4.7.4 +module load pio/2.5.2 +module load esmf/8_1_1 +module load fms/2021.03 diff --git a/unit_tests/modules.stoch b/unit_tests/modules.stoch new file mode 100644 index 00000000..1b4c5399 --- /dev/null +++ b/unit_tests/modules.stoch @@ -0,0 +1,26 @@ +#%Module + +proc ModulesHelp {} { + puts stderr "\tcit - loads modules required for building and running UFS Model on Hera/Intel" +} + +module-whatis "loads UFS Model prerequisites for Hera/Intel" + +module use /contrib/sutils/modulefiles +module load sutils + +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 jasper/2.0.22 +module load zlib/1.2.11 +module load png/1.6.35 + +module load hdf5/1.10.6 +module load netcdf/4.7.4 +module load pio/2.5.2 +module load esmf/8_1_1 +module load fms/2020.04.03 diff --git a/unit_tests/modules.stoch_gnu b/unit_tests/modules.stoch_gnu new file mode 100644 index 00000000..70454aac --- /dev/null +++ b/unit_tests/modules.stoch_gnu @@ -0,0 +1,28 @@ +#%Module + +proc ModulesHelp {} { + puts stderr "\tcit - loads modules required for building and running UFS Model on Hera/Intel" +} + +module-whatis "loads UFS Model prerequisites for Hera/Intel" + +module use /contrib/sutils/modulefiles +module load sutils + +module use /scratch2/NCEPDEV/nwprod/hpc-stack/libs/hpc-stack/modulefiles/stack + +module load hpc/1.1.0 +module load hpc-gnu/9.2.0 +module load hpc-mpich/3.3.2 + +module load jasper/2.0.22 +module load zlib/1.2.11 +module load png/1.6.35 + +module load hdf5/1.10.6 +module load netcdf/4.7.4 +module load pio/2.5.2 +#module load esmf/8_1_1 +#module load fms/2020.04.03 +module load esmf/8_2_0_beta_snapshot_14 +module load fms/2021.03-avx diff --git a/unit_tests/modules.stoch_gnu_dbg b/unit_tests/modules.stoch_gnu_dbg new file mode 100644 index 00000000..c85964f0 --- /dev/null +++ b/unit_tests/modules.stoch_gnu_dbg @@ -0,0 +1,27 @@ +#%Module + +proc ModulesHelp {} { + puts stderr "\tcit - loads modules required for building and running UFS Model on Hera/Intel" +} + +module-whatis "loads UFS Model prerequisites for Hera/Intel" + +module use /contrib/sutils/modulefiles +module load sutils + +module use /scratch2/NCEPDEV/nwprod/hpc-stack/libs/hpc-stack/modulefiles/stack + +module load hpc/1.1.0 +module load hpc-gnu/9.2.0 +module load hpc-mpich/3.3.2 + +module load jasper/2.0.22 +module load zlib/1.2.11 +module load png/1.6.35 + +module load hdf5/1.10.6 +module load netcdf/4.7.4 +module load pio/2.5.2 +module load esmf/8_1_1-debug +#module load fms/2020.04.03 +module load fms/2021.03 diff --git a/unit_tests/run_ca.sh b/unit_tests/run_ca.sh new file mode 100755 index 00000000..ea58c52c --- /dev/null +++ b/unit_tests/run_ca.sh @@ -0,0 +1,69 @@ +#!/bin/sh +#SBATCH -e err +#SBATCH -o out +#SBATCH --account=gsienkf +#SBATCH --qos=debug +#SBATCH --nodes=10 +#SBATCH --ntasks-per-node=40 +#SBATCH --time=20 +#SBATCH --job-name="stoch_unit_tests" + +source ./module-setup.sh +module purge +module use $( pwd -P ) +module load modules.hera.intel +EXEC=standalone_ca.x + +ulimit -s unlimited +export OMP_STACKSIZE=512M +export KMP_AFFINITY=scatter +export OMP_NUM_THREADS=1 + +cp input.nml.noise input.nml +sed -i -e "s/NOISE/0/g" input.nml +echo "option 0 run 1" +sleep 5 +time srun --label -n 384 $EXEC >& stdout_option_0 +mkdir option_0 +mv ca_out* option_0 + +cp input.nml.noise input.nml +sed -i -e "s/NOISE/1/g" input.nml +echo "option 1 run 1" +sleep 5 +time srun --label -n 384 $EXEC >& stdout_option_1 +mkdir option_1 +mv ca_out* option_1 + +cp input.nml.noise input.nml +sed -i -e "s/NOISE/2/g" input.nml +echo "option 2 run 1" +sleep 5 +time srun --label -n 384 $EXEC >& stdout_option_2 +mkdir option_2 +mv ca_out* option_2 +exit + +cp input.nml.noise input.nml +sed -i -e "s/NOISE/2/g" input.nml +echo "option 2 run 2" +sleep 5 +time srun --label -n 384 $EXEC >& stdout_option_2b +mkdir option_2b +mv ca_out* option_2b + +cp input.nml.noise input.nml +sed -i -e "s/NOISE/1/g" input.nml +echo "option 1 run 2" +sleep 5 +time srun --label -n 384 $EXEC >& stdout_option_1b +mkdir option_1b +mv ca_out* option_1b + +cp input.nml.noise input.nml +sed -i -e "s/NOISE/0/g" input.nml +echo "option 0 run 2" +sleep 5 +time srun --label -n 384 $EXEC >& stdout_option_0b +mkdir option_0b +mv ca_out* option_0b diff --git a/unit_tests/run_standalone.sh b/unit_tests/run_standalone.sh new file mode 100755 index 00000000..2ec28588 --- /dev/null +++ b/unit_tests/run_standalone.sh @@ -0,0 +1,45 @@ +#!/bin/sh +#SBATCH -e err +#SBATCH -o out +#SBATCH --account=gsienkf +#SBATCH --qos=debug +#SBATCH --nodes=1 +#SBATCH --ntasks-per-node=40 +#SBATCH --time=20 +#SBATCH --job-name="stoch_unit_tests" + +RES=96 +NPX=`expr $RES + 1` +NPY=`expr $RES + 1` +source ./module-setup.sh +module purge +module use $( pwd -P ) +module load modules.stoch_gnu + +# compile codes +sh compile_standalone.hera_gnu +if [ ! -f standalone_stochy.x ];then + echo "compilation errors" + exit 1 +fi + +# copy input directory +if [ ! -d INPUT ]; then + cp -r /scratch2/BMC/gsienkf/Philip.Pegion/stochastic_physics_unit_tests/input_data INPUT +fi +mkdir -p RESTART + +# test 3 different domain decompositions and compare to baseline +#layout 1x4 +#cp input.nml.template input.nml +sed -i -e "s/LOX/1/g" input.nml +sed -i -e "s/LOY/4/g" input.nml +sed -i -e "s/NPX/$NPX/g" input.nml +sed -i -e "s/NPY/$NPY/g" input.nml +sed -i -e "s/RES/$RES/g" input.nml +sed -i -e "s/_STOCHINI_/.false./g" input.nml +export OMP_NUM_THREADS=2 +module list +time srun --label -n 24 standalone_stochy.x +mkdir stochy_out +mv workg* stochy_out diff --git a/unit_tests/run_unit_tests.sh b/unit_tests/run_unit_tests.sh new file mode 100755 index 00000000..ece1e32d --- /dev/null +++ b/unit_tests/run_unit_tests.sh @@ -0,0 +1,102 @@ +#!/bin/sh +#SBATCH -e err +#SBATCH -o out +#SBATCH --account=gsienkf +#SBATCH --qos=debug +#SBATCH --nodes=2 +#SBATCH --ntasks-per-node=40 +#SBATCH --time=20 +#SBATCH --job-name="stoch_unit_tests" + +RES=96 +NPX=`expr $RES + 1` +NPY=`expr $RES + 1` + +source ./module-setup.sh +module purge +module use $( pwd -P ) +module load modules.stoch + +# compile codes +sh compile_standalone.hera_intel +if [ ! -f standalone_stochy.x ];then + echo "compilation errors" + exit 1 +fi +sh compile_compare.sh + +# copy input directory +if [ ! -d INPUT ]; then + cp -r /scratch2/BMC/gsienkf/Philip.Pegion/stochastic_physics_unit_tests/input_data INPUT +fi +mkdir -p RESTART + +# test 3 different domain decompositions and compare to baseline +##layout 1x4 +cp input.nml.template input.nml +sed -i -e "s/LOX/1/g" input.nml +sed -i -e "s/LOY/4/g" input.nml +sed -i -e "s/NPX/$NPX/g" input.nml +sed -i -e "s/NPY/$NPY/g" input.nml + sed -i -e "s/RES/$RES/g" input.nml +sed -i -e "s/_STOCHINI_/.false./g" input.nml +export OMP_NUM_THREADS=1 +time srun --label -n 24 standalone_stochy.x >& stdout.1x4_layout +mkdir layout_1x4 +mv workg* layout_1x4 + +#layout 2x2 +export OMP_NUM_THREADS=2 +cp input.nml.template input.nml +sed -i -e "s/LOX/2/g" input.nml +sed -i -e "s/LOY/2/g" input.nml +sed -i -e "s/NPX/$NPX/g" input.nml +sed -i -e "s/NPY/$NPY/g" input.nml +sed -i -e "s/RES/$RES/g" input.nml +sed -i -e "s/_STOCHINI_/.false./g" input.nml +time srun -n 24 standalone_stochy.x >& stdout.2x2_layout +mkdir layout_2x2 +mv workg* layout_2x2 + +#layout 1x4 +export OMP_NUM_THREADS=1 +cp input.nml.template input.nml +sed -i -e "s/LOX/4/g" input.nml +sed -i -e "s/LOY/1/g" input.nml +sed -i -e "s/NPX/$NPX/g" input.nml +sed -i -e "s/NPY/$NPY/g" input.nml +sed -i -e "s/RES/$RES/g" input.nml +sed -i -e "s/_STOCHINI_/.false./g" input.nml +time srun -n 24 standalone_stochy.x >& stdout.4x1_layout +mkdir layout_4x1 +mv workg* layout_4x1 +# restart run +mv stochy_middle.nc INPUT/atm_stoch.res.nc +export OMP_NUM_THREADS=2 +cp input.nml.template input.nml +sed -i -e "s/LOX/4/g" input.nml +sed -i -e "s/LOY/1/g" input.nml +sed -i -e "s/NPX/$NPX/g" input.nml +sed -i -e "s/NPY/$NPY/g" input.nml +sed -i -e "s/RES/$RES/g" input.nml +sed -i -e "s/_STOCHINI_/.true./g" input.nml +time srun -n 24 standalone_stochy.x >& stdout.2x2_restart +rm workg* + +compare_output +if [ $? -ne 0 ];then + echo "unit tests failed" +else + diff stochy_final.nc stochy_final_2.nc + if [ $? -eq 0 ];then + echo "unit tests successful" +# rm -rf layout_* + rm logfile* + rm stochy*nc + rm ../*.o ../*.mod + rm ../libstochastic_physics.a + rm standalone_stochy.x + else + echo "restart test failed" + fi +fi diff --git a/unit_tests/run_unit_tests_ca.sh b/unit_tests/run_unit_tests_ca.sh new file mode 100755 index 00000000..77c4f04c --- /dev/null +++ b/unit_tests/run_unit_tests_ca.sh @@ -0,0 +1,134 @@ +#!/bin/sh +#SBATCH -e err +#SBATCH -o out +#SBATCH --account=gsienkf +#SBATCH --qos=debug +#SBATCH --nodes=2 +#SBATCH --ntasks-per-node=40 +#SBATCH --time=20 +#SBATCH --job-name="stoch_unit_tests" +RES=96 +NPX=`expr $RES + 1` +NPY=`expr $RES + 1` +DO_CA_SGS=.false. +DO_CA_GLOBAL=.true. + +source ./module-setup.sh +module purge +module use $( pwd -P ) +module load modules.stoch +EXEC=standalone_ca.x +# compile codes +#sh compile_standalone_ca.hera.intel +if [ ! -f $EXEC ];then + echo "compilation errors" + exit 1 +fi +#sh compile_compare_ca.sh + +# copy input directory +if [ ! -d INPUT ]; then + cp -r /scratch2/BMC/gsienkf/Philip.Pegion/stochastic_physics_unit_tests/input_data INPUT +fi +mkdir -p RESTART + + #layout 1x1 + cp input.nml.ca_template input.nml + sed -i -e "s/LOX/1/g" input.nml + sed -i -e "s/LOY/1/g" input.nml + sed -i -e "s/NPX/$NPX/g" input.nml + sed -i -e "s/NPY/$NPY/g" input.nml + sed -i -e "s/RES/$RES/g" input.nml + sed -i -e "s/CA_SGS/${DO_CA_SGS}/g" input.nml + sed -i -e "s/CA_GLOBAL/${DO_CA_GLOBAL}/g" input.nml + sed -i -e "s/WARM_START/.false./g" input.nml + export OMP_NUM_THREADS=1 + time srun --label -n 6 $EXEC >& stdout.1x1 + mkdir ca_layout_1x1 + mv ca_out* ca_layout_1x1 + ct=1 + while [ $ct -le 6 ];do + mv RESTART/mid_run.ca_data.tile${ct}.nc INPUT/ca_data.tile${ct}.nc + mv RESTART/ca_data.tile${ct}.nc RESTART/run1_end_ca_data.tile${ct}.nc + ct=`expr $ct + 1` + done + + cp input.nml.ca_template input.nml + sed -i -e "s/LOX/1/g" input.nml + sed -i -e "s/LOY/1/g" input.nml + sed -i -e "s/NPX/$NPX/g" input.nml + sed -i -e "s/NPY/$NPY/g" input.nml + sed -i -e "s/RES/$RES/g" input.nml + sed -i -e "s/CA_SGS/${DO_CA_SGS}/g" input.nml + sed -i -e "s/CA_GLOBAL/${DO_CA_GLOBAL}/g" input.nml + sed -i -e "s/WARM_START/.true./g" input.nml + time srun --label -n 6 $EXEC >& stdout.1x1_restart + mkdir ca_layout_1x1_restart + mv ca_out* ca_layout_1x1_restart + ct=1 + while [ $ct -le 6 ];do + diff RESTART/ca_data.tile${ct}.nc RESTART/run1_end_ca_data.tile${ct}.nc + if [ $? -ne 0 ];then + echo "restart test failed" + exit 1 + fi + ct=`expr $ct + 1` + done + if [ $? -eq 0 ];then + echo "unit test 1 successful" + fi + set OMP_NUM_THREADS=2 + cp input.nml.ca_template input.nml + sed -i -e "s/LOX/1/g" input.nml + sed -i -e "s/LOY/4/g" input.nml + sed -i -e "s/NPX/$NPX/g" input.nml + sed -i -e "s/NPY/$NPY/g" input.nml + sed -i -e "s/RES/$RES/g" input.nml + sed -i -e "s/CA_SGS/${DO_CA_SGS}/g" input.nml + sed -i -e "s/CA_GLOBAL/${DO_CA_GLOBAL}/g" input.nml + sed -i -e "s/WARM_START/.true./g" input.nml + time srun --label -n 24 $EXEC >& stdout.1x4_restart + mkdir ca_layout_1x4_restart + mv ca_out* ca_layout_1x4_restart + ct=1 + while [ $ct -le 6 ];do + diff RESTART/ca_data.tile${ct}.nc RESTART/run1_end_ca_data.tile${ct}.nc + if [ $? -ne 0 ];then + echo "restart test failed" + exit 1 + fi + ct=`expr $ct + 1` + done + if [ $? -eq 0 ];then + echo "unit test 2 successful" + fi + cp input.nml.ca_template input.nml + sed -i -e "s/LOX/1/g" input.nml + sed -i -e "s/LOY/4/g" input.nml + sed -i -e "s/NPX/$NPX/g" input.nml + sed -i -e "s/NPY/$NPY/g" input.nml + sed -i -e "s/RES/$RES/g" input.nml + sed -i -e "s/CA_SGS/${DO_CA_SGS}/g" input.nml + sed -i -e "s/CA_GLOBAL/${DO_CA_GLOBAL}/g" input.nml + sed -i -e "s/WARM_START/.false./g" input.nml + time srun --label -n 24 $EXEC >& stdout.1x4 + mkdir ca_layout_1x4 + mv ca_out* ca_layout_1x4 + ct=1 + while [ $ct -le 6 ];do + diff RESTART/ca_data.tile${ct}.nc RESTART/run1_end_ca_data.tile${ct}.nc + if [ $? -ne 0 ];then + echo "restart test failed" + exit 1 + fi + ct=`expr $ct + 1` + done + if [ $? -eq 0 ];then + echo "unit test 3 successful" + fi + diff ca_layout_1x4/ca_out.tile12.nc intel/ca_layout_1x4 + if [ $? -ne 0 ];then + echo "unit test 4 successful" + else + echo "unit test 4 failed" + fi diff --git a/unit_tests/standalone_ca.F90 b/unit_tests/standalone_ca.F90 new file mode 100644 index 00000000..498a558a --- /dev/null +++ b/unit_tests/standalone_ca.F90 @@ -0,0 +1,376 @@ +program standalone_ca_global + +use cellular_automata_global_mod, only : cellular_automata_global +use cellular_automata_sgs_mod, only : cellular_automata_sgs +use update_ca, only : write_ca_restart,read_ca_restart +use atmosphere_stub_mod, only: Atm,atmosphere_init_stub +!use mpp_domains +use mpp_mod, only: mpp_set_current_pelist,mpp_get_current_pelist,mpp_init,mpp_pe,mpp_npes ,mpp_declare_pelist,mpp_root_pe +use mpp_domains_mod, only: mpp_broadcast_domain,MPP_DOMAIN_TIME,mpp_domains_init ,mpp_domains_set_stack_size +use fms_mod, only: fms_init +!use time_manager_mod, only: time_type +use xgrid_mod, only: grid_box_type +use netcdf +use kinddef, only : kind_dbl_prec,kind_phys + + +implicit none +integer :: ntasks,fid,ct,levs,ntiles +integer :: ncid_in,varid,ncid,xt_dim_id,yt_dim_id,time_dim_id,xt_var_id,yt_var_id,time_var_id,ca_out_id +integer :: ca1_id,ca2_id,ca3_id,ca_deep_id!,ca_turb_id,ca_shal_id +integer :: root_pe,comm,dump_time +real(kind=kind_phys) :: dtf, nthresh +character*4 :: strid +character*1 :: tileid +character*4 :: CRES +!type(GFS_statein_type),allocatable :: Statein(:) +include 'mpif.h' +include 'netcdf.inc' +real(kind=4) :: ts,undef + +integer :: nblks,blksz,ierr,my_id,i,j,nx,ny,id,i1,i2 +integer :: isc,iec,jsc,jec,nb,npts +logical :: first_time_step +integer :: istart + +real(kind=4),allocatable,dimension(:,:) :: workg +real(kind=4),allocatable,dimension(:) :: grid_xt,grid_yt +type(grid_box_type) :: grid_box +!---cellular automata control parameters +integer :: nca !< number of independent cellular automata +integer :: tlives !< cellular automata lifetime +integer :: scells !< cellular automata finer grid +integer :: nca_g !< number of independent cellular automata +integer :: nlives_g !< cellular automata lifetime +integer :: ncells_g !< cellular automata finer grid +real(kind=kind_phys) :: nfracseed !< cellular automata seed probability +integer :: nseed !< cellular automata seed frequency +integer :: nseed_g !< cellular automata seed frequency +logical :: do_ca !< cellular automata main switch +logical :: ca_sgs !< switch for sgs ca +logical :: ca_global !< switch for global ca +logical :: ca_smooth !< switch for gaussian spatial filter +integer*8 :: iseed_ca !< seed for random number generation in ca scheme +integer :: nspinup !< number of iterations to spin up the ca +real(kind=kind_phys) :: rcell !< threshold used for CA scheme +real :: ca_amplitude !< amplitude of ca trigger perturbation +integer :: nsmooth !< number of passes through smoother +logical :: ca_closure !< logical switch for ca on closure +logical :: ca_entr !< logical switch for ca on entrainment +logical :: ca_trigger !< logical switch for ca on trigger +logical :: warm_start !< logical switch for ca on trigger + +real(kind=kind_phys), dimension(:,:), allocatable :: cond_in,condition, sst,lmsk,lake +real(kind=kind_phys), dimension(:,:), allocatable :: ca_deep, ca_turb, ca_shal + +real(kind=kind_phys), dimension(:,:), allocatable :: ca1, ca2, ca3 + +NAMELIST /gfs_physics_nml/ do_ca, ca_sgs, ca_global, nca, scells, tlives, nseed, & + nfracseed, rcell, ca_trigger, ca_entr, ca_closure, nca_g, & + ncells_g, nlives_g, nseed_g, ca_smooth, nspinup, iseed_ca, & + nsmooth, ca_amplitude, warm_start +! get mpi info, + +first_time_step=.true. +warm_start=.false. +dtf=720/12.0 +! default values +levs=63 +nca = 0 +nca_g = 0 +ncells_g = 1 +nlives_g = 1 +nfracseed = 0.5 +nseed = 100000 +iseed_ca = 0 +nspinup = 1 +do_ca = .false. +ca_sgs = .false. +ca_global = .false. +ca_smooth = .false. +ca_amplitude = 500. +rcell = 0.0 + +! open namelist file +open (unit=565, file='input.nml', status='OLD', iostat=ierr) +read(565,gfs_physics_nml) +close(565) +! define stuff +undef=9.99e+20 +print*,'ca_sgs,ca_global',ca_sgs,ca_global +if (.not. ca_sgs) then + nca=0 +endif +if (.not. ca_global) then + nca_g=0 +endif + +! initialize fms +!call fms_init() +call mpp_init() +call fms_init +root_pe=mpp_root_pe() +comm=MPI_COMM_WORLD +my_id=mpp_pe() +ntasks=mpp_npes() +ntiles=6 + +call atmosphere_init_stub (grid_box) +!define domain +isc=Atm(1)%bd%isc +iec=Atm(1)%bd%iec +jsc=Atm(1)%bd%jsc +jec=Atm(1)%bd%jec +write(CRES,'(I4)') Atm(1)%npx-1 +print*,'ATM npx,npy=',Atm(1)%npx,Atm(1)%npy + +nx=iec-isc+1 +ny=jec-jsc+1 +allocate(workg(nx,ny)) +print*,'after init',my_id,Atm(1)%tile_of_mosaic,isc,jec + +! for this simple test, nblocks = ny, blksz=ny +blksz=nx +nblks=ny + +! setup GFS_init parameters + +!define model grid + +allocate(grid_xt(nx),grid_yt(ny)) +do i=1,nx + grid_xt(i)=i +enddo +do i=1,ny + grid_yt(i)=i +enddo + +!setup GFS_coupling +if ( ntasks .GT. 1000) then + write(strid,'(I4.4)') my_id+1 +else if ( ntasks .GT. 100) then + write(strid,'(I3.3)') my_id+1 +else if ( ntasks .GT. 10) then + write(strid,'(I2.2)') my_id+1 +else + write(strid,'(I1.1)') my_id+1 +endif +fid=30+my_id +ierr=nf90_create('ca_out.tile'//trim(strid)//'.nc',cmode=NF90_CLOBBER,ncid=ncid) +ierr=NF90_DEF_DIM(ncid,"grid_xt",nx,xt_dim_id) +ierr=NF90_DEF_DIM(ncid,"grid_yt",ny,yt_dim_id) +ierr=NF90_DEF_DIM(ncid,"time",NF90_UNLIMITED,time_dim_id) + !> - Define the dimension variables. +ierr=NF90_DEF_VAR(ncid,"grid_xt",NF90_FLOAT,(/ xt_dim_id /), xt_var_id) +ierr=NF90_PUT_ATT(ncid,xt_var_id,"long_name","T-cell longitude") +ierr=NF90_PUT_ATT(ncid,xt_var_id,"cartesian_axis","X") +ierr=NF90_PUT_ATT(ncid,xt_var_id,"units","degrees_E") +ierr=NF90_DEF_VAR(ncid,"grid_yt",NF90_FLOAT,(/ yt_dim_id /), yt_var_id) +ierr=NF90_PUT_ATT(ncid,yt_var_id,"long_name","T-cell latitude") +ierr=NF90_PUT_ATT(ncid,yt_var_id,"cartesian_axis","Y") +ierr=NF90_PUT_ATT(ncid,yt_var_id,"units","degrees_N") +ierr=NF90_DEF_VAR(ncid,"time",NF90_FLOAT,(/ time_dim_id /), time_var_id) +ierr=NF90_PUT_ATT(ncid,time_var_id,"long_name","time") +ierr=NF90_PUT_ATT(ncid,time_var_id,"units","hours since 2014-08-01 00:00:00") +ierr=NF90_PUT_ATT(ncid,time_var_id,"cartesian_axis","T") +ierr=NF90_PUT_ATT(ncid,time_var_id,"calendar_type","JULIAN") +ierr=NF90_PUT_ATT(ncid,time_var_id,"calendar","JULIAN") +!ierr=NF90_DEF_VAR(ncid,"ca_out",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), ca_out_id) +!ierr=NF90_PUT_ATT(ncid,ca_out_id,"long_name","random pattern") +!ierr=NF90_PUT_ATT(ncid,ca_out_id,"units","None") +!ierr=NF90_PUT_ATT(ncid,ca_out_id,"missing_value",undef) +!ierr=NF90_PUT_ATT(ncid,ca_out_id,"_FillValue",undef) +!ierr=NF90_PUT_ATT(ncid,ca_out_id,"cell_methods","time: point") +if (ca_global) then + ierr=NF90_DEF_VAR(ncid,"ca1",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), ca1_id) + print*,'nc 1',ierr + ierr=NF90_PUT_ATT(ncid,ca1_id,"long_name","random pattern") + print*,'nc 2',ierr + ierr=NF90_PUT_ATT(ncid,ca1_id,"units","None") + print*,'nc 3',ierr + ierr=NF90_PUT_ATT(ncid,ca1_id,"missing_value",undef) + print*,'nc 4',ierr + ierr=NF90_PUT_ATT(ncid,ca1_id,"_FillValue",undef) + print*,'nc 5',ierr + ierr=NF90_PUT_ATT(ncid,ca1_id,"cell_methods","time: point") + print*,'nc 6',ierr + ierr=NF90_DEF_VAR(ncid,"ca2",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), ca2_id) + print*,'nc 7',ierr + ierr=NF90_PUT_ATT(ncid,ca2_id,"long_name","random pattern") + print*,'nc 8',ierr + ierr=NF90_PUT_ATT(ncid,ca2_id,"units","None") + print*,'nc 9',ierr + ierr=NF90_PUT_ATT(ncid,ca2_id,"missing_value",undef) + print*,'nc10',ierr + ierr=NF90_PUT_ATT(ncid,ca2_id,"_FillValue",undef) + print*,'nc11',ierr + ierr=NF90_PUT_ATT(ncid,ca2_id,"cell_methods","time: point") + print*,'nc12',ierr + ierr=NF90_DEF_VAR(ncid,"ca3",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), ca3_id) + print*,'nc13',ierr + ierr=NF90_PUT_ATT(ncid,ca3_id,"long_name","random pattern") + print*,'nc14',ierr + ierr=NF90_PUT_ATT(ncid,ca3_id,"units","None") + print*,'nc15',ierr + ierr=NF90_PUT_ATT(ncid,ca3_id,"missing_value",undef) + print*,'nc16',ierr + ierr=NF90_PUT_ATT(ncid,ca3_id,"_FillValue",undef) + print*,'nc17',ierr + ierr=NF90_PUT_ATT(ncid,ca3_id,"cell_methods","time: point") + print*,'nc18',ierr +endif +if (ca_sgs) then + ierr=NF90_DEF_VAR(ncid,"ca_deep",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), ca_deep_id) + print*,'ca_deep',ierr + ierr=NF90_PUT_ATT(ncid,ca_deep_id,"long_name","CA field for deep convection") + print*,'nc18',ierr + ierr=NF90_PUT_ATT(ncid,ca_deep_id,"units","None") + print*,'nc19',ierr + ierr=NF90_PUT_ATT(ncid,ca_deep_id,"missing_value",undef) + print*,'nc20',ierr + ierr=NF90_PUT_ATT(ncid,ca_deep_id,"_FillValue",undef) + print*,'nc21',ierr + ierr=NF90_PUT_ATT(ncid,ca_deep_id,"cell_methods","time: point") + print*,'nc22',ierr + !ierr=NF90_DEF_VAR(ncid,"ca_turb",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), ca_turb_id) + !ierr=NF90_PUT_ATT(ncid,ca_turb_id,"long_name","CA field for PBL") + !ierr=NF90_PUT_ATT(ncid,ca_turb_id,"long_name","random pattern") + !ierr=NF90_PUT_ATT(ncid,ca_turb_id,"units","None") + !ierr=NF90_PUT_ATT(ncid,ca_turb_id,"missing_value",undef) + !ierr=NF90_PUT_ATT(ncid,ca_turb_id,"_FillValue",undef) + !ierr=NF90_PUT_ATT(ncid,ca_turb_id,"cell_methods","time: point") + !ierr=NF90_DEF_VAR(ncid,"ca_shal",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), ca_shal_id) + !ierr=NF90_PUT_ATT(ncid,ca_shal_id,"long_name","CA field for shallow convection") + !ierr=NF90_PUT_ATT(ncid,ca_shal_id,"units","None") + !ierr=NF90_PUT_ATT(ncid,ca_shal_id,"missing_value",undef) + !ierr=NF90_PUT_ATT(ncid,ca_shal_id,"_FillValue",undef) + !ierr=NF90_PUT_ATT(ncid,ca_shal_id,"cell_methods","time: point") +endif +ierr=NF90_ENDDEF(ncid) + print*,'nc23',ierr +ierr=NF90_PUT_VAR(ncid,xt_var_id,grid_xt) + print*,'nc24',ierr +ierr=NF90_PUT_VAR(ncid,yt_var_id,grid_yt) + print*,'nc25',ierr +! allocate diagnostics +if(ca_global)then + allocate(ca1 (nblks,blksz)) + allocate(ca2 (nblks,blksz)) + allocate(ca3 (nblks,blksz)) +endif + +if(ca_sgs)then + allocate(ca_deep (nblks,blksz)) + allocate(ca_turb (nblks,blksz)) + allocate(ca_shal (nblks,blksz)) + allocate(condition (nblks,blksz)) + allocate(cond_in (isc:iec,jsc:jec)) + allocate(sst (nblks,blksz)) + allocate(lmsk (nblks,blksz)) + allocate(lake (nblks,blksz)) + sst(:,:)=303. + lmsk(:,:)=0. + lake(:,:)=0 +! read in condtion + write(tileid,'(I1)') Atm(1)%tile_of_mosaic + ierr=NF90_OPEN('INPUT/C'//trim(adjustl(CRES))//'_ca_condition.tile'//tileid//'.nc',NF90_NOWRITE,ncid_in) + if (ierr.NE.0) then + print*,'error INPUT/C'//trim(adjustl(CRES))//'_ca_condition.tile'//tileid//'.nc' + call MPI_ABORT(ierr) + endif + ierr=NF90_INQ_VARID(ncid_in,'ca_condition',varid) + if (ierr.NE.0) then + print*,'error gettinv varid for ca_condition' + call MPI_ABORT(ierr) + endif + ierr=NF90_GET_VAR(ncid_in,varid,cond_in,start=(/isc,jsc,1/),count=(/nx,ny,1/)) + if (ierr.NE.0) then + print*,'error getting var',isc,jsc,nx,ny + call MPI_ABORT(ierr) + endif + ierr=NF90_CLOSE(ncid_in) + + i1=isc + j=jsc + do nb=1,nblks + i2=i1+blksz-1 + if (i2 .le. iec) then + condition(nb,1:blksz) = cond_in(i1:i2,j) + i1=i1+blksz + else + npts=iec-i1+1 + condition(nb,1:npts) = cond_in(i1:iec,j) + if (j.LT. jec) then + condition(nb,npts+1:blksz) = cond_in(isc:isc+(blksz-npts+1),j+1) + endif + i1=npts+1 + j=j+1 + endif + if (i2.EQ.iec) then + i1=isc + j=j+1 + endif + end do +endif + +dump_time=50 +if (warm_start) then + istart=dump_time+1 + call read_ca_restart(Atm(1)%domain,scells,nca,ncells_g,nca_g) +else + istart=1 +endif +ct=1 +do i=istart,101 + ts=i/4.0 ! hard coded to write out hourly based on a 900 second time-step + if (ca_sgs) then + call cellular_automata_sgs(i,dtf,warm_start,first_time_step, & + sst,lmsk,lake,condition,ca_deep,ca_turb,ca_shal, & + Atm(1)%domain_for_coupler,nblks, & + isc,iec,jsc,jec,Atm(1)%npx,Atm(1)%npy, levs, & + nthresh,rcell,Atm(1)%tile_of_mosaic,nca,scells,tlives,nfracseed, & ! for new random number + nseed,iseed_ca ,nspinup,ca_trigger,blksz,root_pe,comm) + endif + if (ca_global) then + call cellular_automata_global(i,warm_start,first_time_step,ca1,ca2,ca3,Atm(1)%domain_for_coupler, & + nblks,isc,iec,jsc,jec,Atm(1)%npx,Atm(1)%npy,levs, & + nca_g,ncells_g,nlives_g,nfracseed,nseed_g, & + iseed_ca,Atm(1)%tile_of_mosaic, ca_smooth,nspinup,blksz, & + nsmooth,ca_amplitude,root_pe,comm) + endif + if (i.EQ. dump_time) call write_ca_restart('mid_run') + first_time_step=.false. + if (mod(i-1,5).eq.0) then + if (ca_global) then + workg(:,:)=TRANSPOSE(ca1(:,:)) + ierr=NF90_PUT_VAR(ncid,ca1_id,workg,(/1,1,ct/)) + print*,'put ca 1',ierr + workg(:,:)=TRANSPOSE(ca2(:,:)) + ierr=NF90_PUT_VAR(ncid,ca2_id,workg,(/1,1,ct/)) + workg(:,:)=TRANSPOSE(ca3(:,:)) + ierr=NF90_PUT_VAR(ncid,ca3_id,workg,(/1,1,ct/)) + endif + if (ca_sgs) then + workg(:,:)=TRANSPOSE(ca_deep(:,:)) + ierr=NF90_PUT_VAR(ncid,ca_deep_id,workg,(/1,1,ct/)) + print*,'put ca_deep',ierr + !workg(:,:)=TRANSPOSE(ca_turb(:,:)) + !ierr=NF90_PUT_VAR(ncid,ca_turb_id,workg,(/1,1,ct/)) + !workg(:,:)=ca_shal(:,:) + !workg(:,:)=cond_in(:,:) + !ierr=NF90_PUT_VAR(ncid,ca_shal_id,workg,(/1,1,ct/)) + endif + ierr=NF90_PUT_VAR(ncid,time_var_id,ts,(/ct/)) + ct=ct+1 + endif + if (ca_global) then + if (my_id.EQ.0) write(6,fmt='(a,i7,f8.3)') 'ca glob =',i,maxval(ca1) + endif + if (ca_sgs) then + if (my_id.EQ.0) write(6,fmt='(a,i7,f8.3)') 'ca sgs=',i,maxval(ca_deep) + endif +enddo +call write_ca_restart() +!close(fid) +ierr=NF90_CLOSE(ncid) +end diff --git a/unit_tests/standalone_stochy.F90 b/unit_tests/standalone_stochy.F90 new file mode 100644 index 00000000..d91e3683 --- /dev/null +++ b/unit_tests/standalone_stochy.F90 @@ -0,0 +1,367 @@ +program standalone_stochy + +use stochastic_physics, only : init_stochastic_physics,run_stochastic_physics +use get_stochy_pattern_mod, only : write_stoch_restart_atm + +use atmosphere_stub_mod, only: Atm,atmosphere_init_stub +!use mpp_domains +use mpp_mod, only: mpp_set_current_pelist,mpp_get_current_pelist,mpp_init,mpp_pe,mpp_npes ,mpp_declare_pelist,mpp_root_pe +use mpp_domains_mod, only: mpp_broadcast_domain,MPP_DOMAIN_TIME,mpp_domains_init ,mpp_domains_set_stack_size +use fms_mod, only: fms_init +use xgrid_mod, only: grid_box_type +use netcdf +use kinddef, only : kind_dbl_prec,kind_phys +use stochy_namelist_def, only : stochini + +implicit none +integer, parameter :: nlevs=3 +integer, parameter :: max_n_var_lndp = 6 +integer :: ntasks,fid +integer :: nthreads +integer :: ncid,xt_dim_id,yt_dim_id,time_dim_id,xt_var_id,yt_var_id,time_var_id,var_id_lat,var_id_lon,var_id_tile +integer :: varid1,varid2,varid3,varid4,varid_lon,varid_lat,varid_tile +integer :: varidl(max_n_var_lndp) +integer :: zt_dim_id,zt_var_id +character*2 :: strid + +character(len=3), dimension(max_n_var_lndp) :: lndp_var_list +real(kind=kind_dbl_prec), dimension(max_n_var_lndp) :: lndp_prt_list +include 'mpif.h' +include 'netcdf.inc' +real :: ak(nlevs+1),bk(nlevs+1) +real(kind=4) :: ts,undef + +data ak(1:4) /0.0, 306.1489, 13687.72 , 0.99/ +data bk(1:4) /1.0, 0.9284, 0.013348, 0.0/ +integer :: nb,blksz_1,nblks,ierr,my_id,i,j,k,l,nx,ny,id +integer :: isc,iec,jsc,jec,isd,ied,jsd,jed +integer :: halo_update_type = 1 +real :: dx,dy,pi,rd,cp +logical :: write_this_tile +integer :: nargs,ntile_out,nlunit,pe,npes,stackmax=4000000 +integer :: i1,i2,j1,npts,istart,tpt +character*80 :: fname +character*1 :: ntile_out_str +integer :: comm + +real(kind=4),allocatable,dimension(:,:) :: workg,tile_number +real(kind=4),allocatable,dimension(:,:,:) :: workg3d +real(kind=4),allocatable,dimension(:) :: grid_xt,grid_yt +real(kind=kind_phys), dimension(:,:), allocatable, save :: xlat +real(kind=kind_phys), dimension(:,:), allocatable, save :: xlon +real(kind=kind_dbl_prec) :: ex3d(nlevs+1),pressi(nlevs+1),pressl(nlevs),p1000,exn + +type(grid_box_type) :: grid_box +real (kind=kind_phys),allocatable :: shum_wts (:,:,:) +real (kind=kind_phys),allocatable :: sppt_wts (:,:,:) +real (kind=kind_phys),allocatable :: sppt_pattern(:,:) +real (kind=kind_phys),allocatable :: skebu_wts (:,:,:) +real (kind=kind_phys),allocatable :: skebv_wts (:,:,:) +real (kind=kind_phys),allocatable :: sfc_wts (:,:,:) +integer,allocatable :: blksz(:) +integer :: me !< MPI rank designator +integer :: root_pe !< MPI rank of root atmosphere processor +real(kind=kind_phys) :: dtp !< physics timestep in seconds +real(kind=kind_phys) :: fhour !< previous forecast hour +real(kind=kind_phys) :: sppt_amp !< amplitude of sppt (to go to cld scheme) +logical :: do_sppt,do_shum,do_skeb,use_zmtnblck +integer :: skeb_npass,n_var_lndp, lndp_type +character(len=65) :: fn_nml !< namelist filename +character(len=256),allocatable :: input_nml_file(:) !< character string containing full namelist + + namelist /gfs_physics_nml/do_sppt,do_skeb,do_shum,lndp_type,n_var_lndp +write_this_tile=.false. +ntile_out_str='0' +nlunit=23 +nargs=iargc() +if (nargs.EQ.1) then + call getarg(1,ntile_out_str) +endif +read(ntile_out_str,'(I1.1)') ntile_out +open (unit=nlunit, file='input.nml', status='OLD') +n_var_lndp=0 +lndp_type=0 +do_sppt=.false. +do_shum=.false. +do_skeb=.false. +read(nlunit,gfs_physics_nml) +close(nlunit) +! define stuff +pi=3.14159265359 +undef=9.99e+20 +p1000=100000.0 +!define mid-layer pressure +rd=287.0 +cp=1004.0 +DO k=1,nlevs + pressi(k)=ak(k)+p1000*bk(k) +ENDDO +ex3d=cp*(pressi/p1000)**(rd/cp) +DO k=1,3 !nlevs + exn = (ex3d(k)*pressi(k)-ex3d(k+1)*pressi(k+1))/((cp+rd)*(pressi(k)-pressi(k+1))) + pressl(k)=p1000*exn**(cp/rd) +ENDDO +pressl(4:)=0.01 + +call fms_init() +call mpp_init() +call fms_init +my_id=mpp_pe() +ntasks=mpp_npes() + +call atmosphere_init_stub (grid_box) +isd=Atm(1)%bd%isd +ied=Atm(1)%bd%ied +jsd=Atm(1)%bd%jsd +jed=Atm(1)%bd%jed +isc=Atm(1)%bd%isc +iec=Atm(1)%bd%iec +jsc=Atm(1)%bd%jsc +jec=Atm(1)%bd%jec +nx=iec-isc+1 +ny=jec-jsc+1 +allocate(workg(nx,ny)) +allocate(tile_number(nx,ny)) +allocate(workg3d(nx,ny,nlevs)) +print*,'nx,ny=',nx,ny +blksz_1=nx +nblks=nx*ny/blksz_1 +allocate(blksz(nblks)) +do i=1,nblks + blksz(i)=blksz_1 +enddo +nthreads = 1 +me=my_id +fhour=0 +dtp=600 +fn_nml='input.nml' +nlunit=21 + +!define model grid +dx=360.0/nx +dy=180.0/ny +allocate(xlat(nblks,blksz_1)) +allocate(xlon(nblks,blksz_1)) +i1=isc +j1=jsc +do nb=1,nblks + i2=i1+blksz_1-1 + if (i2 .le. iec) then + xlon(nb,1:blksz_1) = Atm(1)%gridstruct%agrid_64(i1:i2,j1,1) + xlat(nb,1:blksz_1) = Atm(1)%gridstruct%agrid_64(i1:i2,j1,2) + i1=i1+blksz_1 + else + npts=iec-i1+1 + xlon(nb,1:npts) = Atm(1)%gridstruct%agrid_64(i1:iec,j1,1) + xlat(nb,1:npts) = Atm(1)%gridstruct%agrid_64(i1:iec,j1,2) + if (j1.LT. jec) then + xlon(nb,npts+1:blksz_1) = Atm(1)%gridstruct%agrid_64(isc:isc+(blksz_1-npts+1),j1+1,1) + xlat(nb,npts+1:blksz_1) = Atm(1)%gridstruct%agrid_64(isc:isc+(blksz_1-npts+1),j1+1,2) + endif + i1=npts+1 + j1=j1+1 + endif + if (i2.EQ.iec) then + i1=isc + j1=j1+1 + endif +end do + +allocate(grid_xt(nx),grid_yt(ny)) +do i=1,nx + grid_xt(i)=i +enddo +do j=1,ny + grid_yt(j)=j +enddo +print*,'calling init_stochastic_physics',nlevs +root_pe=mpp_root_pe() +allocate(input_nml_file(1)) +input_nml_file='input.nml' +comm=MPI_COMM_WORLD +call init_stochastic_physics(nlevs, blksz, dtp, sppt_amp, & + input_nml_file, fn_nml, nlunit, xlon, xlat, do_sppt, do_shum, & + do_skeb, lndp_type, n_var_lndp, use_zmtnblck, skeb_npass, & + lndp_var_list, lndp_prt_list, & + ak, bk, nthreads, root_pe, comm, ierr) +if (ierr .ne. 0) print *, 'ERROR init_stochastic_physics call' ! Draper - need proper error trapping here +call get_outfile(fname) +write(strid,'(I2.2)') my_id+1 +if (ntile_out.EQ.0) write_this_tile=.true. +if ((my_id+1).EQ.ntile_out) write_this_tile=.true. +print*,trim(fname)//'.tile'//strid//'.nc',write_this_tile +if (write_this_tile) then + fid=30+my_id + ierr=nf90_create(trim(fname)//'.tile'//strid//'.nc',cmode=NF90_CLOBBER,ncid=ncid) + ierr=NF90_DEF_DIM(ncid,"grid_xt",nx,xt_dim_id) + ierr=NF90_DEF_DIM(ncid,"grid_yt",ny,yt_dim_id) + if (do_skeb)ierr=NF90_DEF_DIM(ncid,"p_ref",nlevs,zt_dim_id) + ierr=NF90_DEF_DIM(ncid,"time",NF90_UNLIMITED,time_dim_id) + !> - Define the dimension variables. + ierr=NF90_DEF_VAR(ncid,"grid_xt",NF90_FLOAT,(/ xt_dim_id /), xt_var_id) + ierr=NF90_PUT_ATT(ncid,xt_var_id,"long_name","T-cell longitude") + ierr=NF90_PUT_ATT(ncid,xt_var_id,"cartesian_axis","X") + ierr=NF90_PUT_ATT(ncid,xt_var_id,"units","degrees_E") + ierr=NF90_DEF_VAR(ncid,"grid_yt",NF90_FLOAT,(/ yt_dim_id /), yt_var_id) + ierr=NF90_PUT_ATT(ncid,yt_var_id,"long_name","T-cell latitude") + ierr=NF90_PUT_ATT(ncid,yt_var_id,"cartesian_axis","Y") + ierr=NF90_PUT_ATT(ncid,yt_var_id,"units","degrees_N") + ierr=NF90_DEF_VAR(ncid,"grid_lat",NF90_FLOAT,(/ xt_dim_id, yt_dim_id, time_dim_id /), var_id_lat) + ierr=NF90_PUT_ATT(ncid,var_id_lat,"long_name","T-cell latitudes") + ierr=NF90_PUT_ATT(ncid,var_id_lat,"units","degrees_N") + ierr=NF90_PUT_ATT(ncid,var_id_lat,"missing_value",undef) + ierr=NF90_PUT_ATT(ncid,var_id_lat,"_FillValue",undef) + ierr=NF90_DEF_VAR(ncid,"grid_lon",NF90_FLOAT,(/ xt_dim_id, yt_dim_id, time_dim_id /), var_id_lon) + ierr=NF90_PUT_ATT(ncid,var_id_lon,"long_name","T-cell longitudes") + ierr=NF90_PUT_ATT(ncid,var_id_lon,"units","degrees_N") + ierr=NF90_PUT_ATT(ncid,var_id_lon,"missing_value",undef) + ierr=NF90_PUT_ATT(ncid,var_id_lon,"_FillValue",undef) + ierr=NF90_DEF_VAR(ncid,"tile_num",NF90_FLOAT,(/ xt_dim_id, yt_dim_id, time_dim_id /), var_id_tile) + ierr=NF90_PUT_ATT(ncid,var_id_tile,"long_name","tile number") + ierr=NF90_PUT_ATT(ncid,var_id_tile,"missing_value",undef) + ierr=NF90_PUT_ATT(ncid,var_id_tile,"_FillValue",undef) + if (do_skeb)then + ierr=NF90_DEF_VAR(ncid,"p_ref",NF90_FLOAT,(/ zt_dim_id /), zt_var_id) + ierr=NF90_PUT_ATT(ncid,zt_var_id,"long_name","reference pressure") + ierr=NF90_PUT_ATT(ncid,zt_var_id,"cartesian_axis","Z") + ierr=NF90_PUT_ATT(ncid,zt_var_id,"units","Pa") + endif + ierr=NF90_DEF_VAR(ncid,"time",NF90_FLOAT,(/ time_dim_id /), time_var_id) + ierr=NF90_DEF_VAR(ncid,"time",NF90_FLOAT,(/ time_dim_id /), time_var_id) + ierr=NF90_PUT_ATT(ncid,time_var_id,"long_name","time") + ierr=NF90_PUT_ATT(ncid,time_var_id,"units","hours since 2014-08-01 00:00:00") + ierr=NF90_PUT_ATT(ncid,time_var_id,"cartesian_axis","T") + ierr=NF90_PUT_ATT(ncid,time_var_id,"calendar_type","JULIAN") + ierr=NF90_PUT_ATT(ncid,time_var_id,"calendar","JULIAN") + if (do_sppt)then + ierr=NF90_DEF_VAR(ncid,"sppt_wts",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), varid1) + ierr=NF90_PUT_ATT(ncid,varid1,"long_name","sppt pattern") + ierr=NF90_PUT_ATT(ncid,varid1,"units","None") + ierr=NF90_PUT_ATT(ncid,varid1,"missing_value",undef) + ierr=NF90_PUT_ATT(ncid,varid1,"_FillValue",undef) + ierr=NF90_PUT_ATT(ncid,varid1,"cell_methods","time: point") + endif + if (do_shum)then + ierr=NF90_DEF_VAR(ncid,"shum_wts",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), varid2) + ierr=NF90_PUT_ATT(ncid,varid2,"long_name","shum pattern") + ierr=NF90_PUT_ATT(ncid,varid2,"units","None") + ierr=NF90_PUT_ATT(ncid,varid2,"missing_value",undef) + ierr=NF90_PUT_ATT(ncid,varid2,"_FillValue",undef) + ierr=NF90_PUT_ATT(ncid,varid2,"cell_methods","time: point") + endif + if (do_skeb)then + ierr=NF90_DEF_VAR(ncid,"skebu_wts",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,zt_dim_id,time_dim_id/), varid3) + ierr=NF90_DEF_VAR(ncid,"skebv_wts",NF90_FLOAT,(/xt_dim_id, yt_dim_id ,zt_dim_id,time_dim_id/), varid4) + ierr=NF90_PUT_ATT(ncid,varid3,"long_name","skeb u pattern") + ierr=NF90_PUT_ATT(ncid,varid3,"units","None") + ierr=NF90_PUT_ATT(ncid,varid3,"missing_value",undef) + ierr=NF90_PUT_ATT(ncid,varid3,"_FillValue",undef) + ierr=NF90_PUT_ATT(ncid,varid3,"cell_methods","time: point") + ierr=NF90_PUT_ATT(ncid,varid4,"long_name","skeb v pattern") + ierr=NF90_PUT_ATT(ncid,varid4,"units","None") + ierr=NF90_PUT_ATT(ncid,varid4,"missing_value",undef) + ierr=NF90_PUT_ATT(ncid,varid4,"_FillValue",undef) + ierr=NF90_PUT_ATT(ncid,varid4,"cell_methods","time: point") + endif + if (lndp_type > 0)then + do l=1,n_var_lndp + ierr=NF90_DEF_VAR(ncid,lndp_var_list(l),NF90_FLOAT,(/xt_dim_id, yt_dim_id ,time_dim_id/), varidl(l)) + ierr=NF90_PUT_ATT(ncid,varidl(l),"long_name",lndp_var_list(l)//" pattern") + ierr=NF90_PUT_ATT(ncid,varidl(l),"units","None") + ierr=NF90_PUT_ATT(ncid,varidl(l),"missing_value",undef) + ierr=NF90_PUT_ATT(ncid,varidl(l),"_FillValue",undef) + ierr=NF90_PUT_ATT(ncid,varidl(l),"cell_methods","time: point") + enddo + endif + ierr=NF90_ENDDEF(ncid) + ierr=NF90_PUT_VAR(ncid,xt_var_id,grid_xt) + ierr=NF90_PUT_VAR(ncid,yt_var_id,grid_yt) + if (do_skeb)then + ierr=NF90_PUT_VAR(ncid,zt_var_id,pressl) + endif +endif +! put lat lon and tile number +!ierr=NF90_PUT_VAR(ncid,var_id_lon,transpose(xlon(isc:iec,jsc:iec)),(/1,1,1/)) +!ierr=NF90_PUT_VAR(ncid,var_id_lat,transpose(xlat(isc:iec,jsc:iec)),(/1,1,1/)) +ierr=NF90_PUT_VAR(ncid,var_id_lon,transpose(xlon(:,:)),(/1,1,1/)) +ierr=NF90_PUT_VAR(ncid,var_id_lat,transpose(xlat(:,:)),(/1,1,1/)) +tile_number=my_id+1 +ierr=NF90_PUT_VAR(ncid,var_id_tile,tile_number,(/1,1,1/)) +if (do_sppt)allocate(sppt_wts(nblks,blksz_1,nlevs)) +if (do_shum)allocate(shum_wts(nblks,blksz_1,nlevs)) +if (do_skeb)allocate(skebu_wts(nblks,blksz_1,nlevs)) +if (do_skeb)allocate(skebv_wts(nblks,blksz_1,nlevs)) +if (lndp_type > 0)allocate(sfc_wts(nblks,blksz_1,n_var_lndp)) +if (stochini) then + istart=11 +else + istart=1 +endif +tpt=1 +do i=istart,21 + ts=i/4.0 + call run_stochastic_physics(nlevs, i-1, fhour, blksz, & + sppt_wts=sppt_wts, shum_wts=shum_wts, skebu_wts=skebu_wts, skebv_wts=skebv_wts, sfc_wts=sfc_wts, & + nthreads=nthreads) + + if (me.EQ.0 .and. do_sppt) print*,'SPPT_WTS=',i,sppt_wts(1,1,2) + if (i.EQ. 10) call write_stoch_restart_atm('stochy_middle.nc') + if (i.eq.1 .OR. i.eq.20) then + if (me.EQ.0 .and. do_sppt) print*,'writing sppt_wts=',i,sppt_wts(1,1,2) + if (write_this_tile) then + if (do_sppt)then + do j=1,ny + workg(:,j)=sppt_wts(j,:,2) + enddo + ierr=NF90_PUT_VAR(ncid,varid1,workg,(/1,1,tpt/)) + endif + if (do_shum)then + do j=1,ny + workg(:,j)=shum_wts(j,:,1) + enddo + ierr=NF90_PUT_VAR(ncid,varid2,workg,(/1,1,tpt/)) + endif + if (do_skeb)then + do k=1,nlevs + do j=1,ny + workg3d(:,j,k)=skebu_wts(j,:,k) + enddo + enddo + ierr=NF90_PUT_VAR(ncid,varid3,workg3d,(/1,1,1,tpt/)) + do k=1,nlevs + do j=1,ny + workg3d(:,j,k)=skebv_wts(j,:,k) + enddo + enddo + ierr=NF90_PUT_VAR(ncid,varid4,workg3d,(/1,1,1,tpt/)) + endif + if (lndp_type > 0)then + do l=1,n_var_lndp + do j=1,ny + workg(:,j)=sfc_wts(j,:,l) + enddo + ierr=NF90_PUT_VAR(ncid,varidl(l),workg,(/1,1,tpt/)) + enddo + endif + ierr=NF90_PUT_VAR(ncid,time_var_id,ts,(/tpt/)) + endif + tpt=tpt+1 + endif +enddo +if (write_this_tile) ierr=NF90_CLOSE(ncid) +if (stochini) then + call write_stoch_restart_atm('stochy_final_2.nc') +else + call write_stoch_restart_atm('stochy_final.nc') +endif +end +subroutine get_outfile(fname) +use stochy_namelist_def +character*80,intent(out) :: fname +character*4 :: s_ntrunc,s_lat,s_lon + write(s_ntrunc,'(I4)') ntrunc + write(s_lat,'(I4)') lat_s + write(s_lon,'(I4)') lon_s + fname=trim('workg_T'//trim(adjustl(s_ntrunc))//'_'//trim(adjustl(s_lon))//'x'//trim(adjustl(s_lat))) + return +end diff --git a/update_ca.F90 b/update_ca.F90 index e77202ba..7205f912 100644 --- a/update_ca.F90 +++ b/update_ca.F90 @@ -3,11 +3,21 @@ module update_ca !read and write restart routines, to restart fields !on the ncellsxncells CA grid +use kinddef, only: kind_dbl_prec use halo_exchange, only: atmosphere_scalar_field_halo -use mersenne_twister, only: random_setseed,random_gauss,random_stat,random_number -use mpi_wrapper, only: mype,mp_reduce_sum,mp_bcst,mp_reduce_min,mp_reduce_max -use mpp_domains_mod -use mpp_mod +use random_numbers, only: random_01_CB +use mpi_wrapper, only: mype,mp_reduce_min,mp_reduce_max +use mpp_domains_mod, only: domain2D,mpp_get_global_domain,CENTER, mpp_get_data_domain, mpp_get_compute_domain,mpp_get_ntile_count,& + mpp_define_mosaic,mpp_get_layout,mpp_define_io_domain,mpp_get_io_domain_layout +use mpp_mod, only: mpp_error, mpp_pe, mpp_root_pe, & + NOTE, FATAL +use fms2_io_mod, only: FmsNetcdfDomainFile_t, unlimited, & + open_file, close_file, & + register_axis, register_restart_field, & + register_variable_attribute, register_field, & + read_restart, write_restart, write_data, & + get_global_io_domain_indices, variable_exists + implicit none @@ -16,18 +26,26 @@ module update_ca public update_cells_sgs public update_cells_global -integer,allocatable,save :: board(:,:,:), lives(:,:,:) +integer,allocatable :: board(:,:,:), lives(:,:,:) +integer,allocatable :: board_g(:,:,:), lives_g(:,:,:) +integer,public :: isdnx,iednx,jsdnx,jednx,nxncells,nyncells +integer,public :: iscnx,iecnx,jscnx,jecnx,nxncells_g,nyncells_g +integer,public :: isdnx_g,iednx_g,jsdnx_g,jednx_g +integer,public :: iscnx_g,iecnx_g,jscnx_g,jecnx_g +integer*8, public :: csum +type(domain2D),public :: domain_sgs,domain_global + contains !Compute CA domain:-------------------------------------------------------------------------- -subroutine define_ca_domain(fv_domain,domain_ncellx,ncells,nxncells,nyncells) +subroutine define_ca_domain(domain_in,domain_out,ncells,nxncells_local,nyncells_local) implicit none -type(domain2D),intent(inout) :: fv_domain -type(domain2D),intent(inout) :: domain_ncellx +type(domain2D),intent(inout) :: domain_in +type(domain2D),intent(inout) :: domain_out integer,intent(in) :: ncells -integer,intent(out) :: nxncells, nyncells +integer,intent(out) :: nxncells_local, nyncells_local integer :: halo1 = 1 integer :: layout(2) integer :: ntiles @@ -36,21 +54,17 @@ subroutine define_ca_domain(fv_domain,domain_ncellx,ncells,nxncells,nyncells) integer :: i, j, k, n integer :: nx, ny integer :: isc,iec,jsc,jec -integer :: isd,ied,jsd,jed -integer :: iscnx,iecnx,jscnx,jecnx -integer :: isdnx,iednx,jsdnx,jednx -integer :: nxc,nyc,nxch,nych - -!--- get params from fv domain mosaic for building domain_ncellx - call mpp_get_global_domain(fv_domain,xsize=nx,ysize=ny,position=CENTER) - call mpp_get_layout(fv_domain,layout) - ntiles = mpp_get_ntile_count(fv_domain) + +!--- get params from fv domain mosaic for building domain_out + call mpp_get_global_domain(domain_in,xsize=nx,ysize=ny,position=CENTER) + call mpp_get_layout(domain_in,layout) + ntiles = mpp_get_ntile_count(domain_in) !write(1000+mpp_pe(),*) "nx,ny: ",nx,ny !write(1000+mpp_pe(),*) "layout: ",layout -!--- define mosaic for domain_ncellx refined by 'ncells' from fv_domain - nxncells=nx*ncells+1 - nyncells=ny*ncells+1 +!--- define mosaic for domain_out refined by 'ncells' from domain_in + nxncells_local=nx*ncells+1 + nyncells_local=ny*ncells+1 allocate(pe_start(ntiles)) allocate(pe_end(ntiles)) @@ -58,85 +72,139 @@ subroutine define_ca_domain(fv_domain,domain_ncellx,ncells,nxncells,nyncells) pe_start(n) = mpp_root_pe() + (n-1)*layout(1)*layout(2) pe_end(n) = mpp_root_pe() + n*layout(1)*layout(2)-1 enddo - call define_cubic_mosaic(domain_ncellx, nxncells-1, nyncells-1, layout, pe_start, pe_end, halo1 ) + call define_cubic_mosaic(domain_out, nxncells_local-1, nyncells_local-1, layout, pe_start, pe_end, halo1 ) deallocate(pe_start) deallocate(pe_end) end subroutine define_ca_domain !--------------------------------------------------------------------------------------------- -subroutine write_ca_restart(fv_domain,scells,timestamp) +subroutine write_ca_restart(timestamp) !Write restart files -use fms_io_mod, only: restart_file_type, free_restart_type, & - register_restart_field, & - restore_state, save_restart implicit none -type(domain2d),intent(inout) :: fv_domain -type(domain2d) :: domain_ncellx -integer,intent(in) :: scells -character(len=32), optional, intent(in) :: timestamp -character(len=32) :: fn_phy = 'ca_data.nc' - -type(restart_file_type) :: CA_restart -real :: pi,re,dx -integer :: id_restart,ncells,nx,ny -integer :: nxncells, nyncells - -!Return if not allocated: -if(.not. allocated(board) .or. .not. allocated(lives))return - -call mpp_get_global_domain(fv_domain,xsize=nx,ysize=ny,position=CENTER) -!Set time and length scales: - pi=3.14159 - re=6371000. - dx=0.5*pi*re/real(nx) - ncells=int(dx/real(scells)) - ncells= MIN(ncells,10) +character(len=*), optional, intent(in) :: timestamp +character(len=32) :: fn_ca = 'ca_data.nc' -!Get CA domain -call define_ca_domain(fv_domain,domain_ncellx,ncells,nxncells, nyncells) +type(FmsNetcdfDomainFile_t) :: CA_restart +integer :: id_restart,ncells,nx,ny,i +integer :: is,ie,js,je,nca,nca_g -!Register restart field -id_restart = register_restart_field (CA_restart, fn_phy, "board", & - board(:,:,1), domain = domain_ncellx, mandatory=.false.) +integer, allocatable, dimension(:) :: buffer +character(7) :: indir='RESTART' +character(72) :: infile +logical :: amiopen +amiopen=.false. -id_restart = register_restart_field (CA_restart, fn_phy, "lives", & - lives(:,:,1), domain = domain_ncellx, mandatory=.false.) +!Return if not allocated: +if(.not. allocated(board) .and. .not. allocated(lives) .and. .not. allocated(board_g) .and. .not. allocated(lives_g))return + +infile=trim(indir)//'/'//trim(fn_ca) +if( present(timestamp) ) infile=trim(indir)//'/'//trim(timestamp)//'.'//trim(fn_ca) + !--- register axis +if (allocated(board)) then + amiopen=open_file(CA_restart, trim(infile), 'overwrite', domain=domain_sgs, is_restart=.true., dont_add_res_to_filename=.true.) + if( amiopen ) then + nca=SIZE(board,3) + call mpp_get_compute_domain (domain_sgs,is,ie,js,je) + call register_axis(CA_restart, 'xaxis_1', 'X') + call register_field(CA_restart, 'xaxis_1', 'double', (/'xaxis_1'/)) + call register_variable_attribute(CA_restart, 'xaxis_1', 'cartesian_axis', 'X', str_len=1) + call get_global_io_domain_indices(CA_restart, 'xaxis_1', is, ie, indices=buffer) + call write_data(CA_restart, "xaxis_1", buffer) + deallocate(buffer) + + call register_axis(CA_restart, 'yaxis_1', 'Y') + call register_field(CA_restart, 'yaxis_1', 'double', (/'yaxis_1'/)) + call register_variable_attribute(CA_restart, 'yaxis_1', 'cartesian_axis', 'Y', str_len=1) + call get_global_io_domain_indices(CA_restart, 'yaxis_1', js, je, indices=buffer) + call write_data(CA_restart, "yaxis_1", buffer) + deallocate(buffer) + + call register_axis(CA_restart, 'zaxis_1', nca ) + call register_field(CA_restart, 'zaxis_1', 'double', (/'zaxis_1'/)) + call register_variable_attribute(CA_restart, 'zaxis_1', 'cartesian_axis', 'Z', str_len=1) + allocate( buffer(nca) ) + do i=1, nca + buffer(i)=i + end do + call write_data(CA_restart, "zaxis_1", buffer) + deallocate(buffer) + call register_restart_field(CA_restart, "board", board(:,:,:), dimensions=(/'xaxis_1','yaxis_1','zaxis_1'/),is_optional=.false.) + call register_restart_field(CA_restart, "lives", lives(:,:,:), dimensions=(/'xaxis_1','yaxis_1','zaxis_1'/),is_optional=.false.) + call write_restart(CA_restart) + call close_file(CA_restart) + else + call mpp_error(FATAL, 'Error opening file '//trim(infile)) + endif +endif +if (allocated(board_g)) then + if ( amiopen) then + amiopen=open_file(CA_restart, trim(infile), 'append', domain=domain_global, is_restart=.true., dont_add_res_to_filename=.true.) + else + amiopen=open_file(CA_restart, trim(infile), 'overwrite', domain=domain_global, is_restart=.true., dont_add_res_to_filename=.true.) + endif + if( amiopen ) then + nca_g=SIZE(board_g,3) + call mpp_get_compute_domain (domain_global,is,ie,js,je) + call register_axis(CA_restart, 'xaxis_2', 'X') + call register_field(CA_restart, 'xaxis_2', 'double', (/'xaxis_2'/)) + call register_variable_attribute(CA_restart, 'xaxis_2', 'cartesian_axis', 'X', str_len=1) + call get_global_io_domain_indices(CA_restart, 'xaxis_2', is, ie, indices=buffer) + call write_data(CA_restart, "xaxis_2", buffer) + deallocate(buffer) + + call register_axis(CA_restart, 'yaxis_2', 'Y') + call register_field(CA_restart, 'yaxis_2', 'double', (/'yaxis_2'/)) + call register_variable_attribute(CA_restart, 'yaxis_2', 'cartesian_axis', 'Y', str_len=1) + call get_global_io_domain_indices(CA_restart, 'yaxis_2', js, je, indices=buffer) + call write_data(CA_restart, "yaxis_2", buffer) + deallocate(buffer) + + call register_axis(CA_restart, 'zaxis_2', nca_g) + call register_field(CA_restart, 'zaxis_2', 'double', (/'zaxis_2'/)) + call register_variable_attribute(CA_restart, 'zaxis_2', 'cartesian_axis', 'Z', str_len=1) + allocate( buffer(nca_g) ) + do i=1, nca_g + buffer(i)=i + end do + call write_data(CA_restart, "zaxis_2", buffer) + deallocate(buffer) + call register_restart_field(CA_restart, "board_g", board_g(:,:,:), dimensions=(/'xaxis_2','yaxis_2','zaxis_2'/),is_optional=.false.) + call register_restart_field(CA_restart, "lives_g", lives_g(:,:,:), dimensions=(/'xaxis_2','yaxis_2','zaxis_2'/),is_optional=.false.) + call write_restart(CA_restart) + call close_file(CA_restart) + else + call mpp_error(FATAL, 'Error opening file '//trim(infile)) + endif +endif -call save_restart(CA_restart, timestamp) end subroutine write_ca_restart -subroutine read_ca_restart(fv_domain,scells) +subroutine read_ca_restart(domain_in,scells,nca,ncells_g,nca_g) !Read restart files -use fms_io_mod, only: restart_file_type, free_restart_type, & - register_restart_field, & - restore_state, save_restart -use mpp_mod, only: mpp_error, mpp_pe, mpp_root_pe, & - mpp_chksum, NOTE, FATAL -use fms_mod, only: file_exist, stdout - implicit none -type(domain2d) :: domain_ncellx -type(restart_file_type) :: CA_restart -type(domain2D), intent(inout) :: fv_domain -integer,intent(in) :: scells -character(len=32) :: fn_phy = 'ca_data.nc' +type(FmsNetcdfDomainFile_t) :: CA_restart +type(domain2D), intent(inout) :: domain_in +integer,intent(in) :: scells,nca,nca_g,ncells_g +character(len=32) :: fn_ca = 'ca_data.nc' character(len=64) :: fname integer :: id_restart -integer :: nxncells, nyncells -integer :: isdnx,iednx,jsdnx,jednx -integer :: iscnx,iecnx,jscnx,jecnx -integer :: nxc,nyc,nca +integer :: nxc,nyc,i real :: pi,re,dx integer :: ncells,nx,ny +character(5) :: indir='INPUT' +logical :: amiopen +integer, allocatable, dimension(:) :: io_layout(:) + + -nca=1 -call mpp_get_global_domain(fv_domain,xsize=nx,ysize=ny,position=CENTER) +call mpp_get_global_domain(domain_in,xsize=nx,ysize=ny,position=CENTER) + !Set time and length scales: pi=3.14159 re=6371000. @@ -144,71 +212,107 @@ subroutine read_ca_restart(fv_domain,scells) ncells=int(dx/real(scells)) ncells= MIN(ncells,10) -!Get CA domain -call define_ca_domain(fv_domain,domain_ncellx,ncells,nxncells,nyncells) -call mpp_get_data_domain (domain_ncellx,isdnx,iednx,jsdnx,jednx) -call mpp_get_compute_domain (domain_ncellx,iscnx,iecnx,jscnx,jecnx) - -nxc = iecnx-iscnx+1 -nyc = jecnx-jscnx+1 - -if (.not. allocated(board))then - allocate(board(nxc,nyc,nca)) -endif -if (.not. allocated(lives))then - allocate(lives(nxc,nyc,nca)) + fname = trim(indir)//'/'//trim(fn_ca) + if (nca .gt. 0 ) then + allocate(io_layout(2)) + io_layout=mpp_get_io_domain_layout(domain_in) + call define_ca_domain(domain_in,domain_sgs,ncells,nxncells,nyncells) + call mpp_define_io_domain(domain_sgs, io_layout) + call mpp_get_compute_domain (domain_sgs,iscnx,iecnx,jscnx,jecnx) + amiopen=open_file(CA_restart, trim(fname), 'read', domain=domain_sgs, is_restart=.true., dont_add_res_to_filename=.true.) + if( amiopen ) then + call register_axis(CA_restart, 'xaxis_1', 'X') + call register_axis(CA_restart, 'yaxis_1', 'Y') + call register_axis(CA_restart, 'nca', nca) + !Get CA SGS domain + + nxc = iecnx-iscnx+1 + nyc = jecnx-jscnx+1 + if (.not. allocated(board))then + allocate(board(nxc,nyc,nca)) + endif + if (.not. allocated(lives))then + allocate(lives(nxc,nyc,nca)) + endif + + !Read restart + call register_restart_field(CA_restart, "board", board(:,:,:), dimensions=(/'xaxis_1','yaxis_1','zaxis_1'/),is_optional=.false.) + call register_restart_field(CA_restart, "lives", lives(:,:,:), dimensions=(/'xaxis_1','yaxis_1','zaxis_1'/),is_optional=.false.) + !--- read the CA restart data + call mpp_error(NOTE,'reading CA_sgs restart data from INPUT/ca_data.tile*.nc') + call read_restart(CA_restart) + call close_file(CA_restart) + else + call mpp_error(NOTE,'No CA_sgs restarts - cold starting CA') + endif endif -!Read restart -id_restart = register_restart_field (CA_restart, fn_phy, "board", & - board(:,:,1), domain = domain_ncellx, mandatory=.false.) - -id_restart = register_restart_field (CA_restart, fn_phy, "lives", & - lives(:,:,1), domain = domain_ncellx, mandatory=.false.) - -fname = 'INPUT/ca_data.tile1.nc' -if (file_exist(fname)) then - !--- read the CA restart data - call mpp_error(NOTE,'reading CA restart data from INPUT/ca_data.tile*.nc') - call restore_state(CA_restart) -else - call mpp_error(NOTE,'No CA restarts - cold starting CA') - return +if (nca_g .gt. 0 ) then + domain_global=domain_in + amiopen=open_file(CA_restart, trim(fname), 'read', domain=domain_global, is_restart=.true., dont_add_res_to_filename=.true.) + if( amiopen ) then + call register_axis(CA_restart, 'xaxis_2', 'X') + call register_axis(CA_restart, 'yaxis_2', 'Y') + call register_axis(CA_restart, 'nca_g', nca_g) + !call define_ca_domain(domain_in,domain_global,ncells_g,nxncells_g,nyncells_g) + call mpp_get_compute_domain (domain_global,iscnx_g,iecnx_g,jscnx_g,jecnx_g) + nxc = iecnx_g-iscnx_g+1 + nyc = jecnx_g-jscnx_g+1 + if (.not. allocated(board_g))then + allocate(board_g(nxc,nyc,nca_g)) + endif + if (.not. allocated(lives_g))then + allocate(lives_g(nxc,nyc,nca_g)) + endif + + !Read restart + call register_restart_field(CA_restart, "board_g", board_g(:,:,:), dimensions=(/'xaxis_2','yaxis_2','zaxis_2'/),is_optional=.false.) + call register_restart_field(CA_restart, "lives_g", lives_g(:,:,:), dimensions=(/'xaxis_2','yaxis_2','zaxis_2'/),is_optional=.false.) + call mpp_error(NOTE,'reading CA_global restart data from INPUT/ca_data.tile*.nc') + call read_restart(CA_restart) + call close_file(CA_restart) + + else + call mpp_error(NOTE,'No CA_global restarts - cold starting CA') + endif endif + end subroutine read_ca_restart -subroutine update_cells_sgs(kstep,initialize_ca,first_flag,restart,first_time_step,iseed_ca,nca,nxc,nyc,nxch,nych,nlon,& - nlat,nxncells,nyncells,isc,iec,jsc,jec, npx,npy,isdnx,iednx,jsdnx,jednx, & - iscnx,iecnx,jscnx,jecnx,domain_ncellx,CA,ca_plumes,iini,ilives_in,nlives, & - nfracseed,nseed,nspinup,nf,nca_plumes,ncells) +subroutine update_cells_sgs(kstep,initialize_ca,iseed_ca,first_flag,restart,first_time_step,nca,nxc,nyc,nxch,nych,nlon,& + nlat,isc,iec,jsc,jec, npx,npy, & + CA,ca_plumes,iini,ilives_in,nlives, & + nfracseed,nseed,nspinup,nf,nca_plumes,ncells,mytile) implicit none integer, intent(in) :: kstep,nxc,nyc,nlon,nlat,nxch,nych,nca,isc,iec,jsc,jec,npx,npy -integer, intent(in) :: iini(nxc,nyc,nca),iseed_ca,initialize_ca,ilives_in(nxc,nyc,nca) -integer, intent(in) :: nxncells,nyncells,isdnx,iednx,jsdnx,jednx,iscnx,iecnx,jscnx,jecnx +integer(kind=kind_dbl_prec), intent(in) :: iseed_ca +integer, intent(in) :: iini(nxc,nyc,nca),initialize_ca,ilives_in(nxc,nyc,nca) +integer, intent(in) :: mytile real, intent(out) :: CA(nlon,nlat) integer, intent(out) :: ca_plumes(nlon,nlat) integer, intent(in) :: nlives,nseed, nspinup, nf,ncells real, intent(in) :: nfracseed logical, intent(in) :: nca_plumes,restart,first_flag,first_time_step -type(domain2D), intent(inout) :: domain_ncellx -real, dimension(nlon,nlat) :: frac integer, allocatable :: V(:),L(:),B(:) integer, allocatable :: AG(:,:) integer :: inci, incj, i, j, k,sub,spinup,it,halo,k_in,isize,jsize -integer :: ih, jh,kend, count4,boardmax,livemax,ilivemax +integer :: ih, jh,kend, boardmax,livemax real, allocatable :: board_halo(:,:,:) -integer, dimension(nxc,nyc) :: neighbours, birth, newlives,thresh -integer, dimension(nxc,nyc) :: neg, newcell, oldlives, newval,temp,newseed +integer, dimension(nxc,nyc) :: neighbours, birth, thresh +integer, dimension(nxc,nyc) :: newcell, temp,newseed integer, dimension(ncells,ncells) :: onegrid -integer(8) :: count, count_rate, count_max, count_trunc +integer(8) :: nx_full,ny_full integer(8) :: iscale = 10000000000 logical, save :: start_from_restart -real, dimension(nxc,nyc) :: NOISE_B -real, dimension(nxc*nyc) :: noise1D2 +real, dimension(nxc,nyc) :: noise_b +integer(8) :: count, count_rate, count_max, count_trunc +integer :: count4 +integer*8 :: i1,j1 +real :: ncells2inv !------------------------------------------------------------------------------------------------ @@ -233,32 +337,6 @@ subroutine update_cells_sgs(kstep,initialize_ca,first_flag,restart,first_time_st allocate(board_halo(nxch,nych,1)) endif - !Step 1: Generate a new random number each time-step for "random seeding" - !each nseed timestep where mod(kstep,nseed) = 0 - - if (iseed_ca == 0) then - ! generate a random seed from system clock and ens member number - call system_clock(count, count_rate, count_max) - ! iseed is elapsed time since unix epoch began (secs) - ! truncate to 4 byte integer - count_trunc = iscale*(count/iscale) - count4 = count - count_trunc - else - ! don't rely on compiler to truncate integer(8) to integer(4) on - ! overflow, do wrap around explicitly. - count4 = mod(kstep + mype + iseed_ca + 2147483648, 4294967296) - 2147483648 - endif - call random_setseed(count4) - - noise1D2 = 0.0 - call random_number(noise1D2) - - !Put on 2D: - do j=1,nyc - do i=1,nxc - NOISE_B(i,j)=noise1D2(i+(j-1)*nxc) - enddo - enddo !Step 2: Initialize CA, if restart data exist (board,lives > 0) initialize from restart file, otherwise initialize at time- !step initialize_ca. @@ -266,9 +344,6 @@ subroutine update_cells_sgs(kstep,initialize_ca,first_flag,restart,first_time_st call mp_reduce_max(boardmax) livemax=maxval(lives) call mp_reduce_max(livemax) - ilivemax=maxval(ilives_in) - call mp_reduce_max(ilivemax) - if(restart .and. first_time_step .and. boardmax > 0 .and. livemax > 0)then !restart @@ -301,18 +376,34 @@ subroutine update_cells_sgs(kstep,initialize_ca,first_flag,restart,first_time_st newseed = 0 - !seed with new active cells each nseed time-step regardless of restart/cold start +!seed with new active cells each nseed time-step regardless of restart/cold start - if(mod(kstep,nseed)==0. .and. (kstep >= initialize_ca .or. start_from_restart))then +nx_full=int(ncells,kind=8)*int(npx-1,kind=8) +ny_full=int(ncells,kind=8)*int(npy-1,kind=8) +if(mod(kstep,nseed)==0. .and. (kstep >= initialize_ca .or. start_from_restart))then do j=1,nyc - do i=1,nxc - if(board(i,j,nf) == 0 .and. NOISE_B(i,j)>0.90 )then - newseed(i,j) = 1 - endif - board(i,j,nf) = board(i,j,nf) + newseed(i,j) - enddo + j1=j+(jsc-1)*ncells + do i=1,nxc + i1=i+(isc-1)*ncells + if (iseed_ca <= 0) then + !call system_clock(count, count_rate, count_max) + count_trunc = iscale*(count/iscale) + count4 = count - count_trunc + mytile *( i1+nx_full*(j1-1)) ! no need to multply by 7 since time will be different in sgs + else + count4 = mod((iseed_ca*nf+mytile)*(i1+nx_full*(j1-1))+ 2147483648, 4294967296) - 2147483648 + endif + noise_b(i,j)=real(random_01_CB(kstep,count4),kind=8) + enddo enddo - endif + do j=1,nyc + do i=1,nxc + if(board(i,j,nf) == 0 .and. noise_b(i,j)>0.90 )then + newseed(i,j) = 1 + endif + board(i,j,nf) = board(i,j,nf) + newseed(i,j) + enddo + enddo +endif !Step 3: Evolve CA @@ -321,26 +412,20 @@ subroutine update_cells_sgs(kstep,initialize_ca,first_flag,restart,first_time_st CA=0 neighbours=0 birth=0 - newlives=0 - neg=0 newcell=0 - oldlives=0 - newval=0 - frac=0 - board_halo=0 !--- copy board into the halo-augmented board_halo board_halo(1+halo:nxc+halo,1+halo:nyc+halo,1) = real(board(1:nxc,1:nyc,1),kind=8) - !write(1000+mpp_pe(),*) "board_halo pre: ",board_halo(:,:,1) +! write(1000+mpp_pe(),*) "board_halo pre: ",board_halo(20,1:50,1) !--- perform halo update call atmosphere_scalar_field_halo (board_halo, halo, nxch, nych, 1, & iscnx, iecnx, jscnx, jecnx, & - nxncells, nyncells, domain_ncellx) + nxncells, nyncells, domain_sgs) !--- output data to ensure proper update - !write(1000+mpp_pe(),*) "board_halo post: ",board_halo(:,:,1) + !write(1000+mpp_pe(),*) "board_halo post: ",board_halo(20,1:50,1) !--- Count the neighbours do j=1,nyc @@ -415,9 +500,10 @@ subroutine update_cells_sgs(kstep,initialize_ca,first_flag,restart,first_time_st inci=ncells incj=ncells sub=ncells-1 + ncells2inv=real(1.0/(ncells*ncells)) DO j=1,nlat DO i=1,nlon - CA(i,j)=(SUM(lives(inci-sub:inci,incj-sub:incj,nf)))/real(ncells*ncells) + CA(i,j)=(SUM(lives(inci-sub:inci,incj-sub:incj,nf)))*ncells2inv inci=inci+ncells ENDDO inci=ncells @@ -486,81 +572,46 @@ end subroutine update_cells_sgs !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -subroutine update_cells_global(kstep,first_time_step,iseed_ca,nca,nxc,nyc,nxch,nych,nlon,nlat,nxncells,nyncells,isc,iec,jsc,jec, & - npx,npy,iscnx,iecnx,jscnx,jecnx,domain_ncellx,CA,iini_g,ilives_g, & - nlives,ncells,nfracseed,nseed,nspinup,nf) +subroutine update_cells_global(kstep,first_time_step,iseed_ca,restart,nca,nxc,nyc,nxch,nych,nlon,nlat,isc,iec,jsc,jec, & + npx,npy,CA,iini_g,ilives_g, & + nlives,ncells,nfracseed,nseed,nspinup,nf,mytile) implicit none integer, intent(in) :: kstep,nxc,nyc,nlon,nlat,nxch,nych,nca,isc,iec,jsc,jec,npx,npy -integer, intent(in) :: iini_g(nxc,nyc,nca), ilives_g(nxc,nyc), iseed_ca,nxncells,nyncells +integer, intent(in) :: iini_g(nxc,nyc,nca), ilives_g(nxc,nyc) +integer(kind=kind_dbl_prec), intent(in) :: iseed_ca real, intent(out) :: CA(nlon,nlat) logical, intent(in) :: first_time_step -integer, intent(in) :: nlives, ncells, nseed, nspinup, nf,iscnx,iecnx,jscnx,jecnx +logical, intent(in) :: restart +integer, intent(in) :: nlives, ncells, nseed, nspinup, nf real, intent(in) :: nfracseed -type(domain2D), intent(inout) :: domain_ncellx -real, dimension(nlon,nlat) :: frac -integer,allocatable,save :: board_g(:,:,:), lives_g(:,:,:) +integer, intent(in) :: mytile integer,allocatable :: V(:),L(:) integer :: inci, incj, i, j, k ,sub,spinup,it,halo,k_in,isize,jsize -integer :: ih, jh, count4 +integer :: ih, jh,kend real, allocatable :: board_halo(:,:,:) -integer, dimension(nxc,nyc) :: neighbours, birth, newlives, thresh -integer, dimension(nxc,nyc) :: neg, newcell, oldlives, newval,temp,newseed -real, dimension(nxc,nyc) :: NOISE_B -real, dimension(nxc*nyc) :: noise1D2 +integer, dimension(nxc,nyc) :: neighbours, birth, thresh +integer, dimension(nxc,nyc) :: newcell, temp,newseed +real, dimension(nxc,nyc) :: noise_b integer(8) :: count, count_rate, count_max, count_trunc +integer :: count4 +integer(8) :: nx_full,ny_full integer(8) :: iscale = 10000000000 +integer*8 :: i1,j1 !------------------------------------------------------------------------------------------------- + halo=1 isize=nlon+2*halo jsize=nlat+2*halo k_in=1 - if (.not. allocated(board_g))then - allocate(board_g(nxc,nyc,nca)) - endif - if (.not. allocated(lives_g))then - allocate(lives_g(nxc,nyc,nca)) - endif - if(.not. allocated(board_halo))then - allocate(board_halo(nxch,nych,1)) - endif + if (.not. allocated(board_g)) allocate(board_g(nxc,nyc,nca)) + if (.not. allocated(lives_g)) allocate(lives_g(nxc,nyc,nca)) + if (.not. allocated(board_halo)) allocate(board_halo(nxch,nych,1)) - !Generate a new random number each time-step for "random seeding" - !each nseed timestep - if (iseed_ca == 0) then - ! generate a random seed from system clock and ens member number - call system_clock(count, count_rate, count_max) - ! iseed is elapsed time since unix epoch began (secs) - ! truncate to 4 byte integer - count_trunc = iscale*(count/iscale) - count4 = count - count_trunc - else - ! don't rely on compiler to truncate integer(8) to integer(4) on - ! overflow, do wrap around explicitly. - count4 = mod(mype + iseed_ca + 2147483648, 4294967296) - 2147483648 - endif - call random_setseed(count4) - - noise1D2 = 0.0 - call random_number(noise1D2) - - !random numbers: - noise1D2 = 0.0 - - call random_number(noise1D2) - - !Put on 2D: - do j=1,nyc - do i=1,nxc - NOISE_B(i,j)=noise1D2(i+(j-1)*nxc) - enddo - enddo - - - if(first_time_step)then + if(first_time_step .and. .not. restart)then do j=1,nyc do i=1,nxc board_g(i,j,nf) = iini_g(i,j,nf) @@ -570,21 +621,38 @@ subroutine update_cells_global(kstep,first_time_step,iseed_ca,nca,nxc,nyc,nxch,n endif - !Seed with new CA cells at each nseed step - newseed=0 +!Seed with new CA cells at each nseed step +newseed=0 +if(mod(kstep,nseed) == 0)then + nx_full=int(npx-1,kind=8) + ny_full=int(npy-1,kind=8) + !random numbers: + do j=1,nyc + j1=j+(jsc-1)*ncells + do i=1,nxc + i1=i+(isc-1)*ncells + if (iseed_ca <= 0) then + !call system_clock(count, count_rate, count_max) + count_trunc = iscale*(count/iscale) + count4 = count - count_trunc + mytile *( i1+nx_full*(j1-1)) ! no need to multply by 7 since time will be different in sgs + else + count4 = mod(iseed_ca*nf+(7*mytile)*(i1+nx_full*(j1-1))+ 2147483648, 4294967296) - 2147483648 + endif + noise_b(i,j)=real(random_01_CB(kstep,count4),kind=8) + enddo + enddo - if(mod(kstep,nseed) == 0)then do j=1,nyc - do i=1,nxc - if(board_g(i,j,nf) == 0 .and. NOISE_B(i,j)>0.75 )then - newseed(i,j)=1 - endif - board_g(i,j,nf) = board_g(i,j,nf) + newseed(i,j) - enddo + do i=1,nxc + if(board_g(i,j,nf) == 0 .and. noise_b(i,j)>0.75 )then + newseed(i,j)=1 + endif + board_g(i,j,nf) = board_g(i,j,nf) + newseed(i,j) + enddo enddo - endif +endif - if(first_time_step)then + if(first_time_step .and. .not. restart)then spinup=nspinup else spinup = 1 @@ -596,12 +664,8 @@ subroutine update_cells_global(kstep,first_time_step,iseed_ca,nca,nxc,nyc,nxch,n neighbours=0 birth=0 - newlives=0 - neg=0 newcell=0 - oldlives=0 - newval=0 - frac=0 + CA=0 board_halo=0 !The input to scalar_field_halo needs to be 1D. @@ -609,13 +673,13 @@ subroutine update_cells_global(kstep,first_time_step,iseed_ca,nca,nxc,nyc,nxch,n ! in order to have updated values in the halo region. !--- copy board into the halo-augmented board_halo - board_halo(1+halo:nxc+halo,1+halo:nyc+halo,1) = real(board_g(1:nxc,1:nyc,1),kind=8) + board_halo(1+halo:nxc+halo,1+halo:nyc+halo,1) = real(board_g(1:nxc,1:nyc,nf),kind=8) !write(1000+mpp_pe(),*) "board_halo pre: ",board_halo(:,:,1) !--- perform halo update call atmosphere_scalar_field_halo (board_halo, halo, nxch, nych, 1, & - iscnx, iecnx, jscnx, jecnx, & - nxncells, nyncells, domain_ncellx) + iscnx_g, iecnx_g, jscnx_g, jecnx_g, & + nxncells_g, nyncells_g, domain_global) do j=1,nyc do i=1,nxc @@ -689,7 +753,7 @@ subroutine update_cells_global(kstep,first_time_step,iseed_ca,nca,nxc,nyc,nxch,n sub=ncells-1 DO j=1,nlat DO i=1,nlon - CA(i,j)=(SUM(lives_g(inci-sub:inci,incj-sub:incj,nf)))/(ncells*ncells) + CA(i,j)=(SUM(lives_g(inci-sub:inci,incj-sub:incj,nf)))/real(ncells*ncells) inci=inci+ncells ENDDO inci=ncells