diff --git a/cicecore/cicedyn/analysis/ice_diagnostics.F90 b/cicecore/cicedyn/analysis/ice_diagnostics.F90 index d4e7066fb..23f39634f 100644 --- a/cicecore/cicedyn/analysis/ice_diagnostics.F90 +++ b/cicecore/cicedyn/analysis/ice_diagnostics.F90 @@ -1706,7 +1706,7 @@ subroutine print_state(plabel,i,j,iblk) ! dynamics (transport and/or ridging) causes the floe size distribution to become non-normal ! if (tr_fsd) then ! if (abs(sum(trcrn(i,j,nt_fsd:nt_fsd+nfsd-1,n,iblk))-c1) > puny) & -! print*,'afsdn not normal', & +! write(nu_diag,*) 'afsdn not normal', & ! sum(trcrn(i,j,nt_fsd:nt_fsd+nfsd-1,n,iblk)), & ! trcrn(i,j,nt_fsd:nt_fsd+nfsd-1,n,iblk) ! endif diff --git a/cicecore/cicedyn/analysis/ice_history.F90 b/cicecore/cicedyn/analysis/ice_history.F90 index 0ecc2ee5a..bad038c3b 100644 --- a/cicecore/cicedyn/analysis/ice_history.F90 +++ b/cicecore/cicedyn/analysis/ice_history.F90 @@ -93,6 +93,7 @@ subroutine init_hist (dt) integer (kind=int_kind), dimension(max_nstrm) :: & ntmp integer (kind=int_kind) :: nml_error ! namelist i/o error flag + character(len=*), parameter :: subname = '(init_hist)' !----------------------------------------------------------------- @@ -121,25 +122,27 @@ subroutine init_hist (dt) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=__FILE__, line=__LINE__) - call get_fileunit(nu_nml) if (my_task == master_task) then - open (nu_nml, file=nml_filename, status='old',iostat=nml_error) + write(nu_diag,*) subname,' Reading icefields_nml' + + call get_fileunit(nu_nml) + open (nu_nml, file=trim(nml_filename), status='old',iostat=nml_error) if (nml_error /= 0) then - nml_error = -1 - else - nml_error = 1 + call abort_ice(subname//'ERROR: icefields_nml open file '// & + trim(nml_filename), & + file=__FILE__, line=__LINE__) endif + + nml_error = 1 do while (nml_error > 0) read(nu_nml, nml=icefields_nml,iostat=nml_error) end do - if (nml_error == 0) close(nu_nml) - endif - call release_fileunit(nu_nml) - - call broadcast_scalar(nml_error, master_task) - if (nml_error /= 0) then - close (nu_nml) - call abort_ice(subname//'ERROR: reading icefields_nml') + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: icefields_nml reading ', & + file=__FILE__, line=__LINE__) + endif + close(nu_nml) + call release_fileunit(nu_nml) endif ! histfreq options ('1','h','d','m','y') diff --git a/cicecore/cicedyn/analysis/ice_history_bgc.F90 b/cicecore/cicedyn/analysis/ice_history_bgc.F90 index 1ae572b30..2924cabcf 100644 --- a/cicecore/cicedyn/analysis/ice_history_bgc.F90 +++ b/cicecore/cicedyn/analysis/ice_history_bgc.F90 @@ -282,7 +282,8 @@ subroutine init_hist_bgc_2D tr_bgc_N, tr_bgc_C, tr_bgc_chl, & tr_bgc_DON, tr_bgc_Fe, tr_bgc_hum, & skl_bgc, solve_zsal, z_tracers - character(len=*), parameter :: subname = '(init_hist_bgc_2D)' + + character(len=*), parameter :: subname = '(init_hist_bgc_2D)' call icepack_query_parameters(skl_bgc_out=skl_bgc, & solve_zsal_out=solve_zsal, z_tracers_out=z_tracers) @@ -303,25 +304,27 @@ subroutine init_hist_bgc_2D ! read namelist !----------------------------------------------------------------- - call get_fileunit(nu_nml) if (my_task == master_task) then - open (nu_nml, file=nml_filename, status='old',iostat=nml_error) + write(nu_diag,*) subname,' Reading icefields_bgc_nml' + + call get_fileunit(nu_nml) + open (nu_nml, file=trim(nml_filename), status='old',iostat=nml_error) if (nml_error /= 0) then - nml_error = -1 - else - nml_error = 1 + call abort_ice(subname//'ERROR: icefields_bgc_nml open file '// & + trim(nml_filename), & + file=__FILE__, line=__LINE__) endif + + nml_error = 1 do while (nml_error > 0) read(nu_nml, nml=icefields_bgc_nml,iostat=nml_error) end do - if (nml_error == 0) close(nu_nml) - endif - call release_fileunit(nu_nml) - - call broadcast_scalar(nml_error, master_task) - if (nml_error /= 0) then - close (nu_nml) - call abort_ice(subname//'ERROR: reading icefields_bgc_nml') + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: icefields_bgc_nml reading ', & + file=__FILE__, line=__LINE__) + endif + close(nu_nml) + call release_fileunit(nu_nml) endif if (.not. tr_iso) then diff --git a/cicecore/cicedyn/analysis/ice_history_drag.F90 b/cicecore/cicedyn/analysis/ice_history_drag.F90 index dd9e3cb59..c0a1f99bd 100644 --- a/cicecore/cicedyn/analysis/ice_history_drag.F90 +++ b/cicecore/cicedyn/analysis/ice_history_drag.F90 @@ -1,7 +1,7 @@ !======================================================================= ! 2013 module for form drag parameters -! authors Michel Tsamados, David Schroeder, CPOM +! authors Michel Tsamados, David Schroeder, CPOM module ice_history_drag @@ -17,7 +17,7 @@ module ice_history_drag implicit none private public :: accum_hist_drag, init_hist_drag_2D - + !--------------------------------------------------------------- ! flags: write to output file if true or histfreq value !--------------------------------------------------------------- @@ -31,7 +31,7 @@ module ice_history_drag !--------------------------------------------------------------- namelist / icefields_drag_nml / & - f_Cdn_atm, f_Cdn_ocn , & + f_Cdn_atm, f_Cdn_ocn , & f_drag !--------------------------------------------------------------- @@ -47,7 +47,7 @@ module ice_history_drag n_Cdn_atm_skin , n_Cdn_atm_floe, & n_Cdn_atm_pond , n_Cdn_atm_rdg, & n_Cdn_ocn_skin , n_Cdn_ocn_floe, & - n_Cdn_ocn_keel , n_Cdn_atm_ratio + n_Cdn_ocn_keel , n_Cdn_atm_ratio !======================================================================= @@ -64,13 +64,10 @@ subroutine init_hist_drag_2D use ice_calendar, only: nstreams use ice_communicate, only: my_task, master_task use ice_history_shared, only: tstr2D, tcstr, define_hist_field - use ice_fileunits, only: goto_nml integer (kind=int_kind) :: ns integer (kind=int_kind) :: nml_error ! namelist i/o error flag logical (kind=log_kind) :: formdrag - character(len=char_len_long) :: tmpstr2 ! for namelist check - character(len=char_len) :: nml_name ! for namelist check character(len=*), parameter :: subname = '(init_hist_drag_2D)' @@ -84,39 +81,24 @@ subroutine init_hist_drag_2D !----------------------------------------------------------------- if (my_task == master_task) then - nml_name = 'icefields_drag_nml' - write(nu_diag,*) subname,' Reading ', trim(nml_name) + write(nu_diag,*) subname,' Reading icefields_drag_nml' - ! open namelist file call get_fileunit(nu_nml) open (nu_nml, file=trim(nml_filename), status='old',iostat=nml_error) if (nml_error /= 0) then - call abort_ice(subname//'ERROR: '//trim(nml_name)//' open file '// & + call abort_ice(subname//'ERROR: icefields_drag_nml open file '// & trim(nml_filename), & file=__FILE__, line=__LINE__) endif - ! go to this namelist - call goto_nml(nu_nml,trim(nml_name),nml_error) - if (nml_error /= 0) then - call abort_ice(subname//'ERROR: searching for '// trim(nml_name), & - file=__FILE__, line=__LINE__) - endif - - ! read namelist nml_error = 1 do while (nml_error > 0) read(nu_nml, nml=icefields_drag_nml,iostat=nml_error) - ! check if error - if (nml_error /= 0) then - ! backspace and re-read erroneous line - backspace(nu_nml) - read(nu_nml,fmt='(A)') tmpstr2 - call abort_ice(subname//'ERROR: ' // trim(nml_name) // ' reading ' // & - trim(tmpstr2), file=__FILE__, line=__LINE__) - endif end do - + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: icefields_drag_nml reading ', & + file=__FILE__, line=__LINE__) + endif close(nu_nml) call release_fileunit(nu_nml) endif @@ -142,43 +124,43 @@ subroutine init_hist_drag_2D "hdraft: draught", & "none", c1, c0, & ns, f_drag) - + if (f_drag(1:1) /= 'x') & call define_hist_field(n_hridge,"hridge","m",tstr2D, tcstr, & "hridge: ridge height", & "none", c1, c0, & ns, f_drag) - + if (f_drag(1:1) /= 'x') & call define_hist_field(n_distrdg,"distrdg","m",tstr2D, tcstr, & "distrdg: distance between ridges", & "none", c1, c0, & - ns, f_drag) + ns, f_drag) if (f_drag(1:1) /= 'x') & call define_hist_field(n_hkeel,"hkeel","m",tstr2D, tcstr, & "hkeel: keel depth", & "none", c1, c0, & ns, f_drag) - + if (f_drag(1:1) /= 'x') & call define_hist_field(n_dkeel,"dkeel","m",tstr2D, tcstr, & "dkeel: distance between keels", & "none", c1, c0, & - ns, f_drag) + ns, f_drag) if (f_drag(1:1) /= 'x') & call define_hist_field(n_lfloe,"lfloe","m",tstr2D, tcstr, & "lfloe: floe length", & "none", c1, c0, & ns, f_drag) - + if (f_drag(1:1) /= 'x') & call define_hist_field(n_dfloe,"dfloe","m",tstr2D, tcstr, & "dfloe: distance between floes", & "none", c1, c0, & - ns, f_drag) - + ns, f_drag) + if (f_Cdn_atm(1:1) /= 'x') & call define_hist_field(n_Cdn_atm,"Cdn_atm","none",tstr2D, tcstr, & "Ca: total ice-atm drag coefficient", & @@ -190,49 +172,49 @@ subroutine init_hist_drag_2D "Cdn_ocn: total ice-ocn drag coefficient", & "none", c1, c0, & ns, f_Cdn_ocn) - + if (f_drag(1:1) /= 'x') & call define_hist_field(n_Cdn_atm_skin,"Cdn_atm_skin","none", & tstr2D, tcstr, & "Cdn_atm_skin: neutral skin ice-atm drag coefficient", & "none", c1, c0, & ns, f_drag) - + if (f_drag(1:1) /= 'x') & call define_hist_field(n_Cdn_atm_floe,"Cdn_atm_floe","none", & tstr2D, tcstr, & "Cdn_atm_floe: neutral floe edge ice-atm drag coefficient", & "none", c1, c0, & - ns, f_drag) - + ns, f_drag) + if (f_drag(1:1) /= 'x') & call define_hist_field(n_Cdn_atm_pond,"Cdn_atm_pond","none", & tstr2D, tcstr, & "Cdn_atm_pond: neutral pond edge ice-atm drag coefficient", & "none", c1, c0, & ns, f_drag) - + if (f_drag(1:1) /= 'x') & call define_hist_field(n_Cdn_atm_rdg,"Cdn_atm_rdg","none", & tstr2D, tcstr, & "Cdn_atm_rdg: neutral ridge ice-atm drag coefficient", & "none", c1, c0, & ns, f_drag) - + if (f_drag(1:1) /= 'x') & call define_hist_field(n_Cdn_ocn_skin,"Cdn_ocn_skin","none", & tstr2D, tcstr, & "Cdn_ocn_skin: neutral skin ice-ocn drag coefficient", & "none", c1, c0, & ns, f_drag) - + if (f_drag(1:1) /= 'x') & call define_hist_field(n_Cdn_ocn_floe,"Cdn_ocn_floe","none", & tstr2D, tcstr, & "Cdn_ocn_floe: neutral floe edge ice-ocn drag coefficient", & "none", c1, c0, & - ns, f_drag) - + ns, f_drag) + if (f_drag(1:1) /= 'x') & call define_hist_field(n_Cdn_ocn_keel,"Cdn_ocn_keel","none", & tstr2D, tcstr, & @@ -299,21 +281,21 @@ subroutine accum_hist_drag (iblk) call accum_hist_field(n_lfloe, iblk, lfloe(:,:,iblk), a2D) call accum_hist_field(n_dfloe, iblk, dfloe(:,:,iblk), a2D) call accum_hist_field(n_Cdn_atm_rdg, & - iblk, Cdn_atm_rdg(:,:,iblk), a2D) + iblk, Cdn_atm_rdg(:,:,iblk), a2D) call accum_hist_field(n_Cdn_atm_floe, & iblk, Cdn_atm_floe(:,:,iblk), a2D) call accum_hist_field(n_Cdn_atm_pond, & iblk, Cdn_atm_pond(:,:,iblk), a2D) call accum_hist_field(n_Cdn_atm_skin, & - iblk, Cdn_atm_skin(:,:,iblk), a2D) + iblk, Cdn_atm_skin(:,:,iblk), a2D) call accum_hist_field(n_Cdn_atm_ratio, & iblk, Cdn_atm_ratio(:,:,iblk), a2D) call accum_hist_field(n_Cdn_ocn_keel, & - iblk, Cdn_ocn_keel(:,:,iblk), a2D) + iblk, Cdn_ocn_keel(:,:,iblk), a2D) call accum_hist_field(n_Cdn_ocn_floe, & iblk, Cdn_ocn_floe(:,:,iblk), a2D) call accum_hist_field(n_Cdn_ocn_skin, & - iblk, Cdn_ocn_skin(:,:,iblk), a2D) + iblk, Cdn_ocn_skin(:,:,iblk), a2D) end if endif ! if(allocated(a2D)) diff --git a/cicecore/cicedyn/analysis/ice_history_fsd.F90 b/cicecore/cicedyn/analysis/ice_history_fsd.F90 index 610f56608..c64ecbefa 100644 --- a/cicecore/cicedyn/analysis/ice_history_fsd.F90 +++ b/cicecore/cicedyn/analysis/ice_history_fsd.F90 @@ -21,7 +21,7 @@ module ice_history_fsd private public :: accum_hist_fsd, init_hist_fsd_2D, init_hist_fsd_3Df, & init_hist_fsd_4Df - + !--------------------------------------------------------------- ! flags: write to output file if true or histfreq value !--------------------------------------------------------------- @@ -76,13 +76,11 @@ subroutine init_hist_fsd_2D use ice_calendar, only: nstreams use ice_communicate, only: my_task, master_task use ice_history_shared, only: tstr2D, tcstr, define_hist_field - use ice_fileunits, only: goto_nml integer (kind=int_kind) :: ns integer (kind=int_kind) :: nml_error ! namelist i/o error flag + real (kind=dbl_kind) :: secday logical (kind=log_kind) :: tr_fsd, wave_spec - character (len=char_len_long) :: tmpstr2 ! test namelist - character(len=char_len) :: nml_name ! text namelist name character(len=*), parameter :: subname = '(init_hist_fsd_2D)' @@ -99,39 +97,24 @@ subroutine init_hist_fsd_2D !----------------------------------------------------------------- if (my_task == master_task) then - nml_name = 'icefields_fsd_nml' - write(nu_diag,*) subname,' Reading ', trim(nml_name) + write(nu_diag,*) subname,' Reading icefields_fsd_nml' - ! open namelist file call get_fileunit(nu_nml) open (nu_nml, file=trim(nml_filename), status='old',iostat=nml_error) if (nml_error /= 0) then - call abort_ice(subname//'ERROR: '//trim(nml_name)//' open file '// & + call abort_ice(subname//'ERROR: icefields_fsd_nml open file '// & trim(nml_filename), & file=__FILE__, line=__LINE__) endif - ! goto this namelist - call goto_nml(nu_nml,trim(nml_name),nml_error) - if (nml_error /= 0) then - call abort_ice(subname//'ERROR: searching for '// trim(nml_name), & - file=__FILE__, line=__LINE__) - endif - - ! read namelist nml_error = 1 do while (nml_error > 0) read(nu_nml, nml=icefields_fsd_nml,iostat=nml_error) - ! check if error - if (nml_error /= 0) then - ! backspace and re-read erroneous line - backspace(nu_nml) - read(nu_nml,fmt='(A)') tmpstr2 - call abort_ice(subname//'ERROR: ' // trim(nml_name) // ' reading ' // & - trim(tmpstr2), file=__FILE__, line=__LINE__) - endif end do - + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: icefields_fsd_nml reading ', & + file=__FILE__, line=__LINE__) + endif close(nu_nml) call release_fileunit(nu_nml) endif @@ -155,7 +138,7 @@ subroutine init_hist_fsd_2D do ns = 1, nstreams if (f_wave_sig_ht(1:1) /= 'x') & - call define_hist_field(n_wave_sig_ht,"wave_sig_ht","m",tstr2D, tcstr, & + call define_hist_field(n_wave_sig_ht,"wave_sig_ht","1",tstr2D, tcstr, & "significant height of wind and swell waves", & "from attenuated spectrum in ice", c1, c0, & ns, f_wave_sig_ht) @@ -165,7 +148,7 @@ subroutine init_hist_fsd_2D "for waves", c1, c0, & ns, f_aice_ww) if (f_diam_ww(1:1) /= 'x') & - call define_hist_field(n_diam_ww,"diam_ww","m",tstr2D, tcstr, & + call define_hist_field(n_diam_ww,"diam_ww","1",tstr2D, tcstr, & "Average (number) diameter of floes > Dmin", & "for waves", c1, c0, & ns, f_diam_ww) @@ -234,27 +217,27 @@ subroutine init_hist_fsd_3Df if (histfreq(ns) /= 'x') then if (f_afsd(1:1) /= 'x') & - call define_hist_field(n_afsd,"afsd", "1/m", tstr3Df, tcstr, & + call define_hist_field(n_afsd,"afsd", "1", tstr3Df, tcstr, & "areal floe size distribution", & "per unit bin width ", c1, c0, ns, f_afsd) if (f_dafsd_newi(1:1) /= 'x') & - call define_hist_field(n_dafsd_newi,"dafsd_newi","1/s",tstr3Df, tcstr, & + call define_hist_field(n_dafsd_newi,"dafsd_newi","1",tstr3Df, tcstr, & "Change in fsd: new ice", & "Avg over freq period", c1, c0, ns, f_dafsd_newi) if (f_dafsd_latg(1:1) /= 'x') & - call define_hist_field(n_dafsd_latg,"dafsd_latg","1/s",tstr3Df, tcstr, & + call define_hist_field(n_dafsd_latg,"dafsd_latg","1",tstr3Df, tcstr, & "Change in fsd: lateral growth", & "Avg over freq period", c1, c0, ns, f_dafsd_latg) if (f_dafsd_latm(1:1) /= 'x') & - call define_hist_field(n_dafsd_latm,"dafsd_latm","1/s",tstr3Df, tcstr, & + call define_hist_field(n_dafsd_latm,"dafsd_latm","1",tstr3Df, tcstr, & "Change in fsd: lateral melt", & "Avg over freq period", c1, c0, ns, f_dafsd_latm) if (f_dafsd_wave(1:1) /= 'x') & - call define_hist_field(n_dafsd_wave,"dafsd_wave","1/s",tstr3Df, tcstr, & + call define_hist_field(n_dafsd_wave,"dafsd_wave","1",tstr3Df, tcstr, & "Change in fsd: waves", & "Avg over freq period", c1, c0, ns, f_dafsd_wave) if (f_dafsd_weld(1:1) /= 'x') & - call define_hist_field(n_dafsd_weld,"dafsd_weld","1/s",tstr3Df, tcstr, & + call define_hist_field(n_dafsd_weld,"dafsd_weld","1",tstr3Df, tcstr, & "Change in fsd: welding", & "Avg over freq period", c1, c0, ns, f_dafsd_weld) endif ! if (histfreq(ns) /= 'x') @@ -290,12 +273,12 @@ subroutine init_hist_fsd_4Df if (histfreq(ns) /= 'x') then if (f_afsdn(1:1) /= 'x') & - call define_hist_field(n_afsdn,"afsdn","1/m",tstr4Df, tcstr, & + call define_hist_field(n_afsdn,"afsdn","1",tstr4Df, tcstr, & "areal floe size and thickness distribution", & "per unit bin width", c1, c0, ns, f_afsdn) endif ! if (histfreq(ns) /= 'x') then - enddo ! ns + enddo ! ns endif ! tr_fsd @@ -306,19 +289,16 @@ end subroutine init_hist_fsd_4Df ! accumulate average ice quantities or snapshots ! author: Elizabeth C. Hunke, LANL - subroutine accum_hist_fsd (dt, iblk) + subroutine accum_hist_fsd (iblk) use ice_blocks, only: nx_block, ny_block use ice_constants, only: c0, c1, c2, c4 use ice_history_shared, only: a2D, a3Df, a4Df, nfsd_hist, & ncat_hist, accum_hist_field, n3Dacum, n4Dscum - use ice_state, only: trcrn, aicen, vicen, aice + use ice_state, only: trcrn, aicen_init, vicen, aice_init use ice_arrays_column, only: wave_sig_ht, floe_rad_c, floe_binwidth, & d_afsd_newi, d_afsd_latg, d_afsd_latm, d_afsd_wave, d_afsd_weld - real (kind=dbl_kind), intent(in) :: & - dt ! time step - integer (kind=int_kind), intent(in) :: & iblk ! block index @@ -363,7 +343,7 @@ subroutine accum_hist_fsd (dt, iblk) worka(i,j) = c0 do n = 1, ncat_hist do k = 1, nfsd_hist - worka(i,j) = worka(i,j) + aicen(i,j,n,iblk)*trcrn(i,j,nt_fsd+k-1,n,iblk) + worka(i,j) = worka(i,j) + aicen_init(i,j,n,iblk)*trcrn(i,j,nt_fsd+k-1,n,iblk) end do end do end do @@ -378,7 +358,7 @@ subroutine accum_hist_fsd (dt, iblk) workb = c0 do n = 1, ncat_hist do k = 1, nfsd_hist - workc = aicen(i,j,n,iblk)*trcrn(i,j,nt_fsd+k-1,n,iblk) & + workc = aicen_init(i,j,n,iblk)*trcrn(i,j,nt_fsd+k-1,n,iblk) & / (c4*floeshape*floe_rad_c(k)**2) ! number-mean radius worka(i,j) = worka(i,j) + workc * floe_rad_c(k) @@ -401,7 +381,7 @@ subroutine accum_hist_fsd (dt, iblk) workb = c0 do n = 1, ncat_hist do k = 1, nfsd_hist - workb = workb + aicen(i,j,n,iblk)*trcrn(i,j,nt_fsd+k-1,n,iblk) + workb = workb + aicen_init(i,j,n,iblk)*trcrn(i,j,nt_fsd+k-1,n,iblk) worka(i,j) = worka(i,j) + vicen(i,j,n,iblk)*trcrn(i,j,nt_fsd+k-1,n,iblk) end do end do @@ -418,13 +398,13 @@ subroutine accum_hist_fsd (dt, iblk) if (f_fsdrad(1:1) /= 'x') then do j = 1, ny_block do i = 1, nx_block - worka(i,j) = c0 - if (aice(i,j,iblk) > puny) then + worka(i,j) = c0 + if (aice_init(i,j,iblk) > puny) then do k = 1, nfsd_hist do n = 1, ncat_hist worka(i,j) = worka(i,j) & + (trcrn(i,j,nt_fsd+k-1,n,iblk) * floe_rad_c(k) & - * aicen(i,j,n,iblk)/aice(i,j,iblk)) + * aicen_init(i,j,n,iblk)/aice_init(i,j,iblk)) end do end do endif @@ -437,12 +417,12 @@ subroutine accum_hist_fsd (dt, iblk) do j = 1, ny_block do i = 1, nx_block worka(i,j) = c0 - if (aice(i,j,iblk) > puny) then + if (aice_init(i,j,iblk) > puny) then do k = 1, nfsd_hist do n = 1, ncat_hist worka(i,j) = worka(i,j) & + (c8*floeshape*trcrn(i,j,nt_fsd+k-1,n,iblk)*floe_rad_c(k) & - *aicen(i,j,n,iblk)/(c4*floeshape*floe_rad_c(k)**2 *aice(i,j,iblk))) + *aicen_init(i,j,n,iblk)/(c4*floeshape*floe_rad_c(k)**2 *aice_init(i,j,iblk))) end do end do endif @@ -463,29 +443,29 @@ subroutine accum_hist_fsd (dt, iblk) worke(i,j,k)=c0 do n = 1, ncat_hist worke(i,j,k) = worke(i,j,k) + (trcrn(i,j,nt_fsd+k-1,n,iblk) & - * aicen(i,j,n,iblk)/floe_binwidth(k)) + * aicen_init(i,j,n,iblk)/floe_binwidth(k)) end do end do end do end do call accum_hist_field(n_afsd-n3Dacum, iblk, nfsd_hist, worke, a3Df) endif - + if (f_dafsd_newi(1:1)/= 'x') & call accum_hist_field(n_dafsd_newi-n3Dacum, iblk, nfsd_hist, & - d_afsd_newi(:,:,1:nfsd_hist,iblk)/dt, a3Df) + d_afsd_newi(:,:,1:nfsd_hist,iblk), a3Df) if (f_dafsd_latg(1:1)/= 'x') & call accum_hist_field(n_dafsd_latg-n3Dacum, iblk, nfsd_hist, & - d_afsd_latg(:,:,1:nfsd_hist,iblk)/dt, a3Df) + d_afsd_latg(:,:,1:nfsd_hist,iblk), a3Df) if (f_dafsd_latm(1:1)/= 'x') & call accum_hist_field(n_dafsd_latm-n3Dacum, iblk, nfsd_hist, & - d_afsd_latm(:,:,1:nfsd_hist,iblk)/dt, a3Df) + d_afsd_latm(:,:,1:nfsd_hist,iblk), a3Df) if (f_dafsd_wave(1:1)/= 'x') & call accum_hist_field(n_dafsd_wave-n3Dacum, iblk, nfsd_hist, & - d_afsd_wave(:,:,1:nfsd_hist,iblk)/dt, a3Df) + d_afsd_wave(:,:,1:nfsd_hist,iblk), a3Df) if (f_dafsd_weld(1:1)/= 'x') & call accum_hist_field(n_dafsd_weld-n3Dacum, iblk, nfsd_hist, & - d_afsd_weld(:,:,1:nfsd_hist,iblk)/dt, a3Df) + d_afsd_weld(:,:,1:nfsd_hist,iblk), a3Df) endif ! a3Df allocated ! 4D floe size, thickness category fields @@ -493,11 +473,11 @@ subroutine accum_hist_fsd (dt, iblk) if (f_afsdn(1:1) /= 'x') then do n = 1, ncat_hist - do k = 1, nfsd_hist + do k = 1, nfsd_hist do j = 1, ny_block do i = 1, nx_block workd(i,j,k,n) = trcrn(i,j,nt_fsd+k-1,n,iblk) & - * aicen(i,j,n,iblk)/floe_binwidth(k) + * aicen_init(i,j,n,iblk)/floe_binwidth(k) end do end do end do diff --git a/cicecore/cicedyn/analysis/ice_history_mechred.F90 b/cicecore/cicedyn/analysis/ice_history_mechred.F90 index e0d15fcf2..920a83b47 100644 --- a/cicecore/cicedyn/analysis/ice_history_mechred.F90 +++ b/cicecore/cicedyn/analysis/ice_history_mechred.F90 @@ -20,7 +20,7 @@ module ice_history_mechred implicit none private public :: accum_hist_mechred, init_hist_mechred_2D, init_hist_mechred_3Dc - + !--------------------------------------------------------------- ! flags: write to output file if true or histfreq value !--------------------------------------------------------------- @@ -84,14 +84,11 @@ subroutine init_hist_mechred_2D use ice_calendar, only: nstreams, histfreq use ice_communicate, only: my_task, master_task use ice_history_shared, only: tstr2D, tcstr, define_hist_field - use ice_fileunits, only: goto_nml integer (kind=int_kind) :: ns integer (kind=int_kind) :: nml_error ! namelist i/o error flag real (kind=dbl_kind) :: secday logical (kind=log_kind) :: tr_lvl - character(len=char_len_long) :: tmpstr2 ! for namelist check - character(len=char_len) :: nml_name ! for namelist check character(len=*), parameter :: subname = '(init_hist_mechred_2D)' @@ -106,39 +103,24 @@ subroutine init_hist_mechred_2D !----------------------------------------------------------------- if (my_task == master_task) then - nml_name = 'icefields_mechred_nml' - write(nu_diag,*) subname,' Reading ', trim(nml_name) + write(nu_diag,*) subname,' Reading icefields_mechred_nml' - ! open namelist file call get_fileunit(nu_nml) open (nu_nml, file=trim(nml_filename), status='old',iostat=nml_error) if (nml_error /= 0) then - call abort_ice(subname//'ERROR: '//trim(nml_name)//' open file '// & + call abort_ice(subname//'ERROR: icefields_mechred_nml open file '// & trim(nml_filename), & file=__FILE__, line=__LINE__) endif - ! goto this namelist in file - call goto_nml(nu_nml,trim(nml_name),nml_error) - if (nml_error /= 0) then - call abort_ice(subname//'ERROR: searching for '// trim(nml_name), & - file=__FILE__, line=__LINE__) - endif - - ! read namelist nml_error = 1 do while (nml_error > 0) read(nu_nml, nml=icefields_mechred_nml,iostat=nml_error) - ! check if error - if (nml_error /= 0) then - ! backspace and re-read erroneous line - backspace(nu_nml) - read(nu_nml,fmt='(A)') tmpstr2 - call abort_ice(subname//'ERROR: ' // trim(nml_name) // ' reading ' // & - trim(tmpstr2), file=__FILE__, line=__LINE__) - endif end do - + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: icefields_mechred_nml reading ', & + file=__FILE__, line=__LINE__) + endif close(nu_nml) call release_fileunit(nu_nml) endif @@ -206,13 +188,13 @@ subroutine init_hist_mechred_2D "ice area ridging rate", & "none", secday*c100, c0, & ns, f_dardg1dt) - + if (f_dardg2dt(1:1) /= 'x') & call define_hist_field(n_dardg2dt,"dardg2dt","%/day",tstr2D, tcstr, & "ridge area formation rate", & "none", secday*c100, c0, & ns, f_dardg2dt) - + if (f_dvirdgdt(1:1) /= 'x') & call define_hist_field(n_dvirdgdt,"dvirdgdt","cm/day",tstr2D, tcstr, & "ice volume ridging rate", & diff --git a/cicecore/cicedyn/analysis/ice_history_pond.F90 b/cicecore/cicedyn/analysis/ice_history_pond.F90 index 182865fec..365bd4410 100644 --- a/cicecore/cicedyn/analysis/ice_history_pond.F90 +++ b/cicecore/cicedyn/analysis/ice_history_pond.F90 @@ -73,6 +73,7 @@ subroutine init_hist_pond_2D integer (kind=int_kind) :: ns integer (kind=int_kind) :: nml_error ! namelist i/o error flag logical (kind=log_kind) :: tr_pond + character(len=*), parameter :: subname = '(init_hist_pond_2D)' call icepack_query_tracer_flags(tr_pond_out=tr_pond) @@ -84,25 +85,27 @@ subroutine init_hist_pond_2D ! read namelist !----------------------------------------------------------------- - call get_fileunit(nu_nml) if (my_task == master_task) then - open (nu_nml, file=nml_filename, status='old',iostat=nml_error) + write(nu_diag,*) subname,' Reading icefields_pond_nml' + + call get_fileunit(nu_nml) + open (nu_nml, file=trim(nml_filename), status='old',iostat=nml_error) if (nml_error /= 0) then - nml_error = -1 - else - nml_error = 1 + call abort_ice(subname//'ERROR: icefields_pond_nml open file '// & + trim(nml_filename), & + file=__FILE__, line=__LINE__) endif + + nml_error = 1 do while (nml_error > 0) read(nu_nml, nml=icefields_pond_nml,iostat=nml_error) end do - if (nml_error == 0) close(nu_nml) - endif - call release_fileunit(nu_nml) - - call broadcast_scalar(nml_error, master_task) - if (nml_error /= 0) then - close (nu_nml) - call abort_ice(subname//'ERROR: reading icefields_pond_nml') + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: icefields_pond_nml reading ', & + file=__FILE__, line=__LINE__) + endif + close(nu_nml) + call release_fileunit(nu_nml) endif if (.not. tr_pond) then diff --git a/cicecore/cicedyn/analysis/ice_history_snow.F90 b/cicecore/cicedyn/analysis/ice_history_snow.F90 index 5a590af2b..090759759 100644 --- a/cicecore/cicedyn/analysis/ice_history_snow.F90 +++ b/cicecore/cicedyn/analysis/ice_history_snow.F90 @@ -87,30 +87,32 @@ subroutine init_hist_snow_2D (dt) if (tr_snow) then - !----------------------------------------------------------------- - ! read namelist - !----------------------------------------------------------------- - - call get_fileunit(nu_nml) - if (my_task == master_task) then - open (nu_nml, file=nml_filename, status='old',iostat=nml_error) - if (nml_error /= 0) then - nml_error = -1 - else + !----------------------------------------------------------------- + ! read namelist + !----------------------------------------------------------------- + + if (my_task == master_task) then + write(nu_diag,*) subname,' Reading icefields_snow_nml' + + call get_fileunit(nu_nml) + open (nu_nml, file=trim(nml_filename), status='old',iostat=nml_error) + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: icefields_snow_nml open file '// & + trim(nml_filename), & + file=__FILE__, line=__LINE__) + endif + nml_error = 1 + do while (nml_error > 0) + read(nu_nml, nml=icefields_snow_nml,iostat=nml_error) + end do + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: icefields_snow_nml reading ', & + file=__FILE__, line=__LINE__) + endif + close(nu_nml) + call release_fileunit(nu_nml) endif - do while (nml_error > 0) - read(nu_nml, nml=icefields_snow_nml,iostat=nml_error) - end do - if (nml_error == 0) close(nu_nml) - endif - call release_fileunit(nu_nml) - - call broadcast_scalar(nml_error, master_task) - if (nml_error /= 0) then - close (nu_nml) - call abort_ice('ice: error reading icefields_snow_nml') - endif else ! .not. tr_snow f_smassice = 'x' diff --git a/cicecore/cicedyn/dynamics/ice_transport_remap.F90 b/cicecore/cicedyn/dynamics/ice_transport_remap.F90 index 8916c359d..89c0609ef 100644 --- a/cicecore/cicedyn/dynamics/ice_transport_remap.F90 +++ b/cicecore/cicedyn/dynamics/ice_transport_remap.F90 @@ -1,4 +1,5 @@ !======================================================================= +! ! Transports quantities using the second-order conservative remapping ! scheme developed by John Dukowicz and John Baumgardner (DB) and modified ! for sea ice by William Lipscomb and Elizabeth Hunke. @@ -19,31 +20,27 @@ ! 2003: Vectorized by Clifford Chen (Fujitsu) and William Lipscomb ! 2004-05: Block structure added (WHL) ! 2006: Moved remap driver to ice_transport_driver -! Geometry changes: +! Geometry changes: ! (1) Reconstruct fields in stretched logically rectangular coordinates ! (2) Modify geometry so that the area flux across each edge ! can be specified (following an idea of Mats Bentsen) -! 2010: ECH removed unnecessary grid arrays and optional arguments from +! 2010: ECH removed unnecessary grid arrays and optional arguments from ! horizontal_remap -! 2023: TAR, DMI Remove commented code and unnecessary arrays module ice_transport_remap use ice_kinds_mod use ice_blocks, only: nx_block, ny_block - use ice_calendar, only: istep1 use ice_communicate, only: my_task use ice_constants, only: c0, c1, c2, c12, p333, p4, p5, p6, & eps13, eps16, & field_loc_center, field_type_scalar, & field_loc_NEcorner, field_type_vector - use ice_diagnostics, only: diagnostic_abort use ice_domain_size, only: max_blocks, ncat use ice_fileunits, only: nu_diag use ice_exit, only: abort_ice use icepack_intfc, only: icepack_warnings_flush, icepack_warnings_aborted use icepack_intfc, only: icepack_query_parameters - use ice_grid, only : grid_ice implicit none private @@ -55,154 +52,149 @@ module ice_transport_remap nvert = 3 ! number of vertices in a triangle ! for triangle integral formulas - real (kind=dbl_kind), parameter :: & + real (kind=dbl_kind), parameter :: & p5625m = -9._dbl_kind/16._dbl_kind ,& p52083 = 25._dbl_kind/48._dbl_kind - logical :: & - l_fixed_area ! if true, prescribe area flux across each edge - ! if false, area flux is determined internally - ! and is passed out - logical (kind=log_kind), parameter :: bugcheck = .false. !======================================================================= ! Here is some information about how the incremental remapping scheme -! works in CICE and how it can be adapted for use in other models. +! works in CICE and how it can be adapted for use in other models. ! -! The remapping routine is designed to transport a generic mass-like +! The remapping routine is designed to transport a generic mass-like ! field (in CICE, the ice fractional area) along with an arbitrary number -! of tracers in two dimensions. The velocity components are assumed -! to lie at grid cell corners and the transported scalars at cell centers. -! Incremental remapping has the following desirable properties: -! -! (1) Tracer monotonicity is preserved. That is, no new local -! extrema are produced in fields like ice thickness or internal -! energy. -! (2) The reconstucted mass and tracer fields vary linearly in x and y. -! This means that remapping is 2nd-order accurate in space, -! except where horizontal gradients are limited to preserve -! monotonicity. -! (3) There are economies of scale. Transporting a single field -! is rather expensive, but additional fields have a relatively -! low marginal cost. -! -! The following generic conservation equations may be solved: -! -! dm/dt = del*(u*m) (0) -! d(m*T1)/dt = del*(u*m*T1) (1) -! d(m*T1*T2)/dt = del*(u*m*T1*T2) (2) -! d(m*T1*T2*T3)/dt = del*(u*m*T1*T2*T3) (3) +! of tracers in two dimensions. The velocity components are assumed +! to lie at grid cell corners and the transported scalars at cell centers. +! Incremental remapping has the following desirable properties: +! +! (1) Tracer monotonicity is preserved. That is, no new local +! extrema are produced in fields like ice thickness or internal +! energy. +! (2) The reconstucted mass and tracer fields vary linearly in x and y. +! This means that remapping is 2nd-order accurate in space, +! except where horizontal gradients are limited to preserve +! monotonicity. +! (3) There are economies of scale. Transporting a single field +! is rather expensive, but additional fields have a relatively +! low marginal cost. +! +! The following generic conservation equations may be solved: +! +! dm/dt = del*(u*m) (0) +! d(m*T1)/dt = del*(u*m*T1) (1) +! d(m*T1*T2)/dt = del*(u*m*T1*T2) (2) +! d(m*T1*T2*T3)/dt = del*(u*m*T1*T2*T3) (3) ! ! where d is a partial derivative, del is the 2D divergence operator, ! u is the horizontal velocity, m is the mass density field, and ! T1, T2, and T3 are tracers. ! ! In CICE, these equations have the form -! +! ! da/dt = del*(u*a) (4) ! dv/dt = d(a*h)/dt = del*(u*a*h) (5) ! de/dt = d(a*h*q)/dt = del*(u*a*h*q) (6) ! d(aT)/dt = del*(u*a*t) (7) -! -! where a = fractional ice area, v = ice/snow volume, h = v/a = thickness, -! e = ice/snow internal energy (J/m^2), q = e/v = internal energy per -! unit volume (J/m^3), and T is a tracer. These equations express +! +! where a = fractional ice area, v = ice/snow volume, h = v/a = thickness, +! e = ice/snow internal energy (J/m^2), q = e/v = internal energy per +! unit volume (J/m^3), and T is a tracer. These equations express ! conservation of ice area, volume, internal energy, and area-weighted -! tracer, respectively. +! tracer, respectively. ! ! (Note: In CICE, a, v and e are prognostic quantities from which ! h and q are diagnosed. The remapping routine works with tracers, ! which means that h and q must be derived from a, v, and e before -! calling the remapping routine.) +! calling the remapping routine.) ! -! Earlier versions of CICE assumed fixed ice and snow density. -! Beginning with CICE 4.0, the ice and snow density can be variable. -! In this case, equations (5) and (6) are replaced by -! -! dv/dt = d(a*h)/dt = del*(u*a*h) (8) +! Earlier versions of CICE assumed fixed ice and snow density. +! Beginning with CICE 4.0, the ice and snow density can be variable. +! In this case, equations (5) and (6) are replaced by +! +! dv/dt = d(a*h)/dt = del*(u*a*h) (8) ! dm/dt = d(a*h*rho)/dt = del*(u*a*h*rho) (9) ! de/dt = d(a*h*rho*qm)/dt = del*(u*a*h*rho*qm) (10) -! -! where rho = density and qm = internal energy per unit mass (J/kg). -! Eq. (9) expresses mass conservation, which in the variable-density -! case is no longer equivalent to volume conservation (8). -! -! Tracers satisfying equations of the form (1) are called "type 1." -! In CICE the paradigmatic type 1 tracers are hi and hs. -! -! Tracers satisfying equations of the form (2) are called "type 2". -! The paradigmatic type 2 tracers are qi and qs (or rhoi and rhos -! in the variable-density case). -! +! +! where rho = density and qm = internal energy per unit mass (J/kg). +! Eq. (9) expresses mass conservation, which in the variable-density +! case is no longer equivalent to volume conservation (8). +! +! Tracers satisfying equations of the form (1) are called "type 1." +! In CICE the paradigmatic type 1 tracers are hi and hs. +! +! Tracers satisfying equations of the form (2) are called "type 2". +! The paradigmatic type 2 tracers are qi and qs (or rhoi and rhos +! in the variable-density case). +! ! Tracers satisfying equations of the form (3) are called "type 3." ! The paradigmatic type 3 tracers are qmi and qms in the variable-density -! case. There are no such tracers in the constant-density case. -! -! The fields a, T1, and T2 are reconstructed in each grid cell with -! 2nd-order accuracy. T3 is reconstructed with 1st-order accuracy -! (i.e., it is transported in upwind fashion) in order to avoid -! additional mathematical complexity. -! -! The mass-like field lives in the array "mm" (shorthand for mean -! mass) and the tracers fields in the array "tm" (mean tracers). -! In order to transport tracers correctly, the remapping routine -! needs to know the tracers types and relationships. This is done -! as follows: -! -! Each field in the "tm" array is assigned an index, 1:ntrace. -! (Note: ntrace is not the same as ntrcr, the number of tracers -! in the trcrn state variable array. For remapping purposes we -! have additional tracers hi and hs.) -! -! The tracer types (1,2,3) are contained in the "tracer_type" array. -! For standard CICE: -! -! tracer_type = (1 1 1 2 2 2 2 2) -! -! Type 2 and type 3 tracers are said to depend on type 1 tracers. -! For instance, qi depends on hi, which is to say that -! there is a conservation equation of the form (2) or (6). -! Thus we define a "depend" array. For standard CICE: -! -! depend = (0 0 0 1 1 1 1 2) -! -! which implies that elements 1-3 (hi, hs, Ts) are type 1, -! elements 4-7 (qi) depend on element 1 (hi), and element 8 (qs) -! depends on element 2 (hs). -! -! We also define a logical array "has_dependents". In standard CICE: -! -! has_dependents = (T T F F F F F F), -! -! which means that only elements 1 and 2 (hi and hs) have dependent -! tracers. -! -! For the variable-density case, things are a bit more complicated. -! Suppose we have 4 variable-density ice layers and one variable- -! density snow layer. Then the indexing is as follows: -! 1 = hi -! 2 = hs -! 3 = Ts -! 4-7 = rhoi -! 8 = rhos -! 9-12 = qmi -! 13 = qms -! -! The key arrays are: -! -! tracer_type = (1 1 1 2 2 2 2 2 3 3 3 3 3) -! -! depend = (0 0 0 1 1 1 1 2 4 5 6 7 8) -! -! has_dependents = (T T F T T T T T F F F F F) -! -! which imply that hi and hs are type 1 with dependents rhoi and rhos, -! while rhoi and rhos are type 2 with dependents qmi and qms. -! -! Tracers added to the ntrcr array are handled automatically -! by the remapping with little extra coding. It is necessary -! only to provide the correct type and dependency information. +! case. There are no such tracers in the constant-density case. +! +! The fields a, T1, and T2 are reconstructed in each grid cell with +! 2nd-order accuracy. T3 is reconstructed with 1st-order accuracy +! (i.e., it is transported in upwind fashion) in order to avoid +! additional mathematical complexity. +! +! The mass-like field lives in the array "mm" (shorthand for mean +! mass) and the tracers fields in the array "tm" (mean tracers). +! In order to transport tracers correctly, the remapping routine +! needs to know the tracers types and relationships. This is done +! as follows: +! +! Each field in the "tm" array is assigned an index, 1:ntrace. +! (Note: ntrace is not the same as ntrcr, the number of tracers +! in the trcrn state variable array. For remapping purposes we +! have additional tracers hi and hs.) +! +! The tracer types (1,2,3) are contained in the "tracer_type" array. +! For standard CICE: +! +! tracer_type = (1 1 1 2 2 2 2 2) +! +! Type 2 and type 3 tracers are said to depend on type 1 tracers. +! For instance, qi depends on hi, which is to say that +! there is a conservation equation of the form (2) or (6). +! Thus we define a "depend" array. For standard CICE: +! +! depend = (0 0 0 1 1 1 1 2) +! +! which implies that elements 1-3 (hi, hs, Ts) are type 1, +! elements 4-7 (qi) depend on element 1 (hi), and element 8 (qs) +! depends on element 2 (hs). +! +! We also define a logical array "has_dependents". In standard CICE: +! +! has_dependents = (T T F F F F F F), +! +! which means that only elements 1 and 2 (hi and hs) have dependent +! tracers. +! +! For the variable-density case, things are a bit more complicated. +! Suppose we have 4 variable-density ice layers and one variable- +! density snow layer. Then the indexing is as follows: +! 1 = hi +! 2 = hs +! 3 = Ts +! 4-7 = rhoi +! 8 = rhos +! 9-12 = qmi +! 13 = qms +! +! The key arrays are: +! +! tracer_type = (1 1 1 2 2 2 2 2 3 3 3 3 3) +! +! depend = (0 0 0 1 1 1 1 2 4 5 6 7 8) +! +! has_dependents = (T T F T T T T T F F F F F) +! +! which imply that hi and hs are type 1 with dependents rhoi and rhos, +! while rhoi and rhos are type 2 with dependents qmi and qms. +! +! Tracers added to the ntrcr array are handled automatically +! by the remapping with little extra coding. It is necessary +! only to provide the correct type and dependency information. ! ! When using this routine in other models, most of the tracer dependency ! apparatus may be irrelevant. In a layered ocean model, for example, @@ -245,7 +237,7 @@ module ice_transport_remap ! regions are then tweaked, following an idea by Mats Bentsen, such ! that they have the desired area. If l_fixed_area = F, these regions ! are not tweaked, and the edgearea arrays are output variables. -! +! !======================================================================= contains @@ -254,38 +246,52 @@ module ice_transport_remap ! ! Grid quantities used by the remapping transport scheme ! -! Note: Arrays needed for nonuniform grids has been deleted. -! They can be found in version 6.5 and earlier +! Note: the arrays xyav, xxxav, etc are not needed for rectangular grids +! but may be needed in the future for other nonuniform grids. They have +! been commented out here to save memory and flops. ! ! author William H. Lipscomb, LANL subroutine init_remap + use ice_domain, only: nblocks + use ice_grid, only: xav, yav, xxav, yyav +! dxt, dyt, xyav, & +! xxxav, xxyav, xyyav, yyyav + + integer (kind=int_kind) :: & + i, j, iblk ! standard indices + character(len=*), parameter :: subname = '(init_remap)' - !------------------------------------------------------------------- - ! Set logical l_fixed_area depending of the grid type. - ! - ! If l_fixed_area is true, the area of each departure region is - ! computed in advance (e.g., by taking the divergence of the - ! velocity field and passed to locate_triangles. The departure - ! regions are adjusted to obtain the desired area. - ! If false, edgearea is computed in locate_triangles and passed out. + ! Compute grid cell average geometric quantities on the scaled + ! rectangular grid with dx = 1, dy = 1. ! - ! l_fixed_area = .false. has been the default approach in CICE. It is - ! used like this for the B-grid. However, idealized tests with the - ! C-grid have shown that l_fixed_area = .false. leads to a checkerboard - ! pattern in prognostic fields (e.g. aice). Using l_fixed_area = .true. - ! eliminates the checkerboard pattern in C-grid simulations. - ! - !------------------------------------------------------------------- - - if (grid_ice == 'CD' .or. grid_ice == 'C') then - l_fixed_area = .true. - else - l_fixed_area = .false. - endif + ! Note: On a rectangular grid, the integral of any odd function + ! of x or y = 0. + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + xav(i,j,iblk) = c0 + yav(i,j,iblk) = c0 +!!! These formulas would be used on a rectangular grid +!!! with dimensions (dxt, dyt): +!!! xxav(i,j,iblk) = dxt(i,j,iblk)**2 / c12 +!!! yyav(i,j,iblk) = dyt(i,j,iblk)**2 / c12 + xxav(i,j,iblk) = c1/c12 + yyav(i,j,iblk) = c1/c12 +! xyav(i,j,iblk) = c0 +! xxxav(i,j,iblk) = c0 +! xxyav(i,j,iblk) = c0 +! xyyav(i,j,iblk) = c0 +! yyyav(i,j,iblk) = c0 + enddo + enddo + enddo + !$OMP END PARALLEL DO + end subroutine init_remap !======================================================================= @@ -296,195 +302,211 @@ end subroutine init_remap ! ! This scheme preserves monotonicity of ice area and tracers. That is, ! it does not produce new extrema. It is second-order accurate in space, -! except where gradients are limited to preserve monotonicity. +! except where gradients are limited to preserve monotonicity. ! ! This version of the remapping allows the user to specify the areal ! flux across each edge, based on an idea developed by Mats Bentsen. ! ! author William H. Lipscomb, LANL -! 2006: Moved driver (subroutine transport_remap) into separate module. +! 2006: Moved driver (subroutine transport_remap) into separate module. ! Geometry changes (logically rectangular coordinates, fixed ! area fluxes) - subroutine horizontal_remap (dt, ntrace, & - uvel, vvel, & - mm, tm, & - tracer_type, depend, & - has_dependents, & - integral_order, & - l_dp_midpt, & - uvelE, vvelN) + subroutine horizontal_remap (dt, ntrace, & + uvel, vvel, & + mm, tm, & + l_fixed_area, & + tracer_type, depend, & + has_dependents, & + integral_order, & + l_dp_midpt) use ice_boundary, only: ice_halo, ice_HaloMask, ice_HaloUpdate, & ice_HaloDestroy use ice_domain, only: nblocks, blocks_ice, halo_info, maskhalo_remap use ice_blocks, only: block, get_block, nghost use ice_grid, only: HTE, HTN, dxu, dyu, & - earea, narea, tarear, hm + tarear, hm, & + xav, yav, xxav, yyav +! xyav, xxxav, xxyav, xyyav, yyyav + use ice_calendar, only: istep1 use ice_timers, only: ice_timer_start, ice_timer_stop, timer_bound real (kind=dbl_kind), intent(in) :: & - dt ! time step + dt ! time step integer (kind=int_kind), intent(in) :: & - ntrace ! number of tracers in use + ntrace ! number of tracers in use real (kind=dbl_kind), intent(in), dimension(nx_block,ny_block,max_blocks) :: & - uvel, & ! x-component of velocity (m/s) ugrid - vvel ! y-component of velocity (m/s) ugrid - - real (kind=dbl_kind), intent(in), optional, dimension(nx_block,ny_block,max_blocks) :: & - uvelE, & ! x-component of velocity (m/s) egrid - vvelN ! y-component of velocity (m/s) ngrid + uvel ,&! x-component of velocity (m/s) + vvel ! y-component of velocity (m/s) real (kind=dbl_kind), intent(inout), dimension (nx_block,ny_block,0:ncat,max_blocks) :: & - mm ! mean mass values in each grid cell + mm ! mean mass values in each grid cell real (kind=dbl_kind), intent(inout), dimension (nx_block,ny_block,ntrace,ncat,max_blocks) :: & - tm ! mean tracer values in each grid cell + tm ! mean tracer values in each grid cell + + !------------------------------------------------------------------- + ! If l_fixed_area is true, the area of each departure region is + ! computed in advance (e.g., by taking the divergence of the + ! velocity field and passed to locate_triangles. The departure + ! regions are adjusted to obtain the desired area. + ! If false, edgearea is computed in locate_triangles and passed out. + !------------------------------------------------------------------- + + logical, intent(in) :: & + l_fixed_area ! if true, edgearea_e and edgearea_n are prescribed + ! if false, edgearea is computed here and passed out integer (kind=int_kind), dimension (ntrace), intent(in) :: & - tracer_type , & ! = 1, 2, or 3 (see comments above) - depend ! tracer dependencies (see above) + tracer_type ,&! = 1, 2, or 3 (see comments above) + depend ! tracer dependencies (see above) logical (kind=log_kind), dimension (ntrace), intent(in) :: & - has_dependents ! true if a tracer has dependent tracers + has_dependents ! true if a tracer has dependent tracers integer (kind=int_kind), intent(in) :: & - integral_order ! polynomial order for triangle integrals + integral_order ! polynomial order for triangle integrals logical (kind=log_kind), intent(in) :: & - l_dp_midpt ! if true, find departure points using - ! corrected midpoint velocity + l_dp_midpt ! if true, find departure points using + ! corrected midpoint velocity ! local variables integer (kind=int_kind) :: & - i, j , & ! horizontal indices - iblk , & ! block index - ilo,ihi,jlo,jhi, & ! beginning and end of physical domain - n, m ! ice category, tracer indices + i, j ,&! horizontal indices + iblk ,&! block index + ilo,ihi,jlo,jhi,&! beginning and end of physical domain + n, m ! ice category, tracer indices integer (kind=int_kind), dimension(0:ncat,max_blocks) :: & - icellsnc ! number of cells with ice + icellsnc ! number of cells with ice integer (kind=int_kind), dimension(nx_block*ny_block,0:ncat) :: & indxinc, indxjnc ! compressed i/j indices real (kind=dbl_kind), dimension(nx_block,ny_block) :: & - edgearea_e , & ! area of departure regions for east edges - edgearea_n ! area of departure regions for north edges + edgearea_e ,&! area of departure regions for east edges + edgearea_n ! area of departure regions for north edges real (kind=dbl_kind), dimension (nx_block,ny_block,max_blocks) :: & - dpx , & ! x coordinates of departure points at cell corners - dpy ! y coordinates of departure points at cell corners + dpx ,&! x coordinates of departure points at cell corners + dpy ! y coordinates of departure points at cell corners real (kind=dbl_kind), dimension(nx_block,ny_block,0:ncat,max_blocks) :: & - mc , & ! mass at geometric center of cell - mx, my ! limited derivative of mass wrt x and y + mc ,&! mass at geometric center of cell + mx, my ! limited derivative of mass wrt x and y real (kind=dbl_kind), dimension(nx_block,ny_block,0:ncat) :: & - mmask ! = 1. if mass is present, = 0. otherwise + mmask ! = 1. if mass is present, = 0. otherwise real (kind=dbl_kind), dimension (nx_block,ny_block,ntrace,ncat,max_blocks) :: & - tc , & ! tracer values at geometric center of cell - tx, ty ! limited derivative of tracer wrt x and y + tc ,&! tracer values at geometric center of cell + tx, ty ! limited derivative of tracer wrt x and y real (kind=dbl_kind), dimension (nx_block,ny_block,ntrace,ncat) :: & - tmask ! = 1. if tracer is present, = 0. otherwise + tmask ! = 1. if tracer is present, = 0. otherwise real (kind=dbl_kind), dimension (nx_block,ny_block,0:ncat) :: & - mflxe, mflxn ! mass transports across E and N cell edges + mflxe, mflxn ! mass transports across E and N cell edges real (kind=dbl_kind), dimension (nx_block,ny_block,ntrace,ncat) :: & - mtflxe, mtflxn ! mass*tracer transports across E and N cell edges + mtflxe, mtflxn ! mass*tracer transports across E and N cell edges real (kind=dbl_kind), dimension (nx_block,ny_block,ngroups) :: & - triarea ! area of east-edge departure triangle + triarea ! area of east-edge departure triangle real (kind=dbl_kind), dimension (nx_block,ny_block,0:nvert,ngroups) :: & - xp, yp ! x and y coordinates of special triangle points - ! (need 4 points for triangle integrals) + xp, yp ! x and y coordinates of special triangle points + ! (need 4 points for triangle integrals) integer (kind=int_kind), dimension (nx_block,ny_block,ngroups) :: & - iflux , & ! i index of cell contributing transport - jflux ! j index of cell contributing transport + iflux ,&! i index of cell contributing transport + jflux ! j index of cell contributing transport integer (kind=int_kind), dimension(ngroups,max_blocks) :: & - icellsng ! number of cells with ice + icellsng ! number of cells with ice integer (kind=int_kind), dimension(nx_block*ny_block,ngroups) :: & - indxing, indxjng ! compressed i/j indices + indxing, indxjng ! compressed i/j indices integer (kind=int_kind), dimension(nx_block,ny_block,max_blocks) :: & - halomask ! temporary mask for fast halo updates + halomask ! temporary mask for fast halo updates logical (kind=log_kind) :: & - l_stop ! if true, abort the model + l_stop ! if true, abort the model integer (kind=int_kind) :: & - istop, jstop ! indices of grid cell where model aborts + istop, jstop ! indices of grid cell where model aborts character (len=char_len) :: & - edge ! 'north' or 'east' + edge ! 'north' or 'east' - type (ice_halo) :: & - halo_info_tracer ! masked halo + type (ice_halo) :: halo_info_tracer type (block) :: & - this_block ! block information for current block + this_block ! block information for current block character(len=*), parameter :: subname = '(horizontal_remap)' - !------------------------------------------------------------------- - ! Remap the ice area and associated tracers. - ! Remap the open water area (without tracers). - !------------------------------------------------------------------- +!---!------------------------------------------------------------------- +!---! Remap the ice area and associated tracers. +!---! Remap the open water area (without tracers). +!---!------------------------------------------------------------------- - !$OMP PARALLEL DO PRIVATE(iblk,ilo,ihi,jlo,jhi,this_block,n, & - !$OMP indxinc,indxjnc,mmask,tmask,istop,jstop,l_stop) & - !$OMP SCHEDULE(runtime) + !--- tcraig, tcx, this omp loop leads to a seg fault in gnu + !--- need to check private variables and debug further + !$TCXOMP PARALLEL DO PRIVATE(iblk,ilo,ihi,jlo,jhi,this_block,n,m, & + !$TCXOMP indxinc,indxjnc,mmask,tmask,istop,jstop,l_stop) do iblk = 1, nblocks l_stop = .false. istop = 0 jstop = 0 - this_block = get_block(blocks_ice(iblk),iblk) + this_block = get_block(blocks_ice(iblk),iblk) ilo = this_block%ilo ihi = this_block%ihi jlo = this_block%jlo jhi = this_block%jhi - !------------------------------------------------------------------- - ! Compute masks and count ice cells. - ! Masks are used to prevent tracer values in cells without ice from - ! being used to compute tracer gradients. - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Compute masks and count ice cells. + ! Masks are used to prevent tracer values in cells without ice from + ! being used to compute tracer gradients. + !------------------------------------------------------------------- call make_masks (nx_block, ny_block, & ilo, ihi, jlo, jhi, & nghost, ntrace, & has_dependents, icellsnc(:,iblk), & - indxinc(:,:), indxjnc(:,:), & - mm (:,:,:,iblk), mmask(:,:,:), & + indxinc(:,:), indxjnc(:,:), & + mm(:,:,:,iblk), mmask(:,:,:), & tm(:,:,:,:,iblk), tmask(:,:,:,:)) - !------------------------------------------------------------------- - ! Construct linear fields, limiting gradients to preserve monotonicity. - ! Note: Pass in unit arrays instead of true distances HTE, HTN, etc. - ! The resulting gradients are in scaled coordinates. - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Construct linear fields, limiting gradients to preserve monotonicity. + ! Note: Pass in unit arrays instead of true distances HTE, HTN, etc. + ! The resulting gradients are in scaled coordinates. + !------------------------------------------------------------------- ! open water - call construct_fields(nx_block, ny_block, & - ilo, ihi, jlo, jhi, & - nghost, ntrace, & - tracer_type, depend, & - has_dependents, icellsnc(0,iblk), & - indxinc(:,0), indxjnc(:,0), & - hm (:,:,iblk), & - mm (:,:,0,iblk), mc (:,:,0,iblk), & - mx (:,:,0,iblk), my (:,:,0,iblk), & - mmask(:,:,0) ) + call construct_fields(nx_block, ny_block, & + ilo, ihi, jlo, jhi, & + nghost, ntrace, & + tracer_type, depend, & + has_dependents, icellsnc (0,iblk), & + indxinc (:,0), indxjnc(:,0), & + hm (:,:,iblk), xav (:,:,iblk), & + yav (:,:,iblk), xxav (:,:,iblk), & + yyav (:,:,iblk), & +! xyav (:,:,iblk), & +! xxxav (:,:,iblk), xxyav(:,:,iblk), & +! xyyav (:,:,iblk), yyyav(:,:,iblk), & + mm (:,:,0,iblk), mc(:,:,0,iblk), & + mx (:,:,0,iblk), my(:,:,0,iblk), & + mmask (:,:,0) ) ! ice categories @@ -495,21 +517,26 @@ subroutine horizontal_remap (dt, ntrace, & nghost, ntrace, & tracer_type, depend, & has_dependents, icellsnc (n,iblk), & - indxinc (:,n), indxjnc(:,n), & - hm (:,:,iblk), & - mm (:,:,n,iblk), mc (:,:,n,iblk), & - mx (:,:,n,iblk), my (:,:,n,iblk), & - mmask (:,:,n), & - tm (:,:,:,n,iblk), tc(:,:,:,n,iblk), & - tx (:,:,:,n,iblk), ty(:,:,:,n,iblk), & + indxinc (:,n), indxjnc(:,n), & + hm (:,:,iblk), xav (:,:,iblk), & + yav (:,:,iblk), xxav (:,:,iblk), & + yyav (:,:,iblk), & +! xyav (:,:,iblk), & +! xxxav (:,:,iblk), xxyav (:,:,iblk), & +! xyyav (:,:,iblk), yyyav (:,:,iblk), & + mm (:,:,n,iblk), mc (:,:,n,iblk), & + mx (:,:,n,iblk), my (:,:,n,iblk), & + mmask (:,:,n), & + tm (:,:,:,n,iblk), tc(:,:,:,n,iblk), & + tx (:,:,:,n,iblk), ty(:,:,:,n,iblk), & tmask(:,:,:,n) ) enddo ! n - - !------------------------------------------------------------------- - ! Given velocity field at cell corners, compute departure points - ! of trajectories. - !------------------------------------------------------------------- + + !------------------------------------------------------------------- + ! Given velocity field at cell corners, compute departure points + ! of trajectories. + !------------------------------------------------------------------- call departure_points(nx_block, ny_block, & ilo, ihi, jlo, jhi, & @@ -518,20 +545,27 @@ subroutine horizontal_remap (dt, ntrace, & dxu (:,:,iblk), dyu (:,:,iblk), & HTN (:,:,iblk), HTE (:,:,iblk), & dpx (:,:,iblk), dpy (:,:,iblk), & - l_dp_midpt, l_stop, & + l_dp_midpt, l_stop, & istop, jstop) if (l_stop) then - call diagnostic_abort(istop,jstop,iblk,'bad departure points') + write(nu_diag,*) 'istep1, my_task, iblk =', & + istep1, my_task, iblk + write (nu_diag,*) 'Global block:', this_block%block_id + if (istop > 0 .and. jstop > 0) & + write(nu_diag,*) 'Global i and j:', & + this_block%i_glob(istop), & + this_block%j_glob(jstop) + call abort_ice(subname//'ERROR: bad departure points') endif enddo ! iblk - !$OMP END PARALLEL DO + !$TCXOMP END PARALLEL DO - !------------------------------------------------------------------- - ! Ghost cell updates - ! If nghost >= 2, these calls are not needed - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Ghost cell updates + ! If nghost >= 2, these calls are not needed + !------------------------------------------------------------------- if (nghost==1) then @@ -551,12 +585,12 @@ subroutine horizontal_remap (dt, ntrace, & call ice_HaloUpdate (my, halo_info, & field_loc_center, field_type_vector) - ! tracer fields + ! tracer fields if (maskhalo_remap) then halomask(:,:,:) = 0 - !$OMP PARALLEL DO PRIVATE(iblk,this_block,ilo,ihi,jlo,jhi,n,m,j,i) SCHEDULE(runtime) + !$OMP PARALLEL DO PRIVATE(iblk,this_block,ilo,ihi,jlo,jhi,n,m,j,i) do iblk = 1, nblocks - this_block = get_block(blocks_ice(iblk),iblk) + this_block = get_block(blocks_ice(iblk),iblk) ilo = this_block%ilo ihi = this_block%ihi jlo = this_block%jlo @@ -575,8 +609,8 @@ subroutine horizontal_remap (dt, ntrace, & enddo enddo !$OMP END PARALLEL DO - call ice_HaloUpdate (halomask, halo_info, & - field_loc_center, field_type_scalar) + call ice_HaloUpdate(halomask, halo_info, & + field_loc_center, field_type_scalar) call ice_HaloMask(halo_info_tracer, halo_info, halomask) call ice_HaloUpdate (tc, halo_info_tracer, & @@ -598,29 +632,28 @@ subroutine horizontal_remap (dt, ntrace, & endif ! nghost - ! tcraig, this OMP loop sometimes fails with cce/14.0.3, compiler bug?? - ! TILL I can trigger the same with ifort (IFORT) 18.0.0 20170811 -!TILL !$OMP PARALLEL DO PRIVATE(iblk,i,j,ilo,ihi,jlo,jhi,this_block,n, & -!TILL !$OMP edgearea_e,edgearea_n,edge,iflux,jflux, & -!TILL !$OMP xp,yp,indxing,indxjng,mflxe,mflxn, & -!TILL !$OMP mtflxe,mtflxn,triarea,istop,jstop,l_stop) & -!TILL !$OMP SCHEDULE(runtime) + !--- tcraig, tcx, this omp loop leads to a seg fault in gnu + !--- need to check private variables and debug further + !$TCXOMP PARALLEL DO PRIVATE(iblk,i,j,ilo,ihi,jlo,jhi,this_block,n,m, & + !$TCXOMP edgearea_e,edgearea_n,edge,iflux,jflux, & + !$TCXOMP xp,yp,indxing,indxjng,mflxe,mflxn, & + !$TCXOMP mtflxe,mtflxn,triarea,istop,jstop,l_stop) do iblk = 1, nblocks l_stop = .false. istop = 0 jstop = 0 - this_block = get_block(blocks_ice(iblk),iblk) + this_block = get_block(blocks_ice(iblk),iblk) ilo = this_block%ilo ihi = this_block%ihi jlo = this_block%jlo jhi = this_block%jhi - !------------------------------------------------------------------- - ! If l_fixed_area is true, compute edgearea by taking the divergence - ! of the velocity field. Otherwise, initialize edgearea. - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! If l_fixed_area is true, compute edgearea by taking the divergence + ! of the velocity field. Otherwise, initialize edgearea. + !------------------------------------------------------------------- do j = 1, ny_block do i = 1, nx_block @@ -630,24 +663,6 @@ subroutine horizontal_remap (dt, ntrace, & enddo if (l_fixed_area) then - if (grid_ice == 'CD' .or. grid_ice == 'C') then ! velocities are already on the center - if (.not.present(uvelE).or..not.present(vvelN)) then - call abort_ice (subname//'ERROR: uvelE,vvelN required with C|CD and l_fixed_area') - endif - - do j = jlo, jhi - do i = ilo-1, ihi - edgearea_e(i,j) = uvelE(i,j,iblk) * HTE(i,j,iblk) * dt - enddo - enddo - - do j = jlo-1, jhi - do i = ilo, ihi - edgearea_n(i,j) = vvelN(i,j,iblk)*HTN(i,j,iblk) * dt - enddo - enddo - - else do j = jlo, jhi do i = ilo-1, ihi edgearea_e(i,j) = (uvel(i,j,iblk) + uvel(i,j-1,iblk)) & @@ -661,126 +676,125 @@ subroutine horizontal_remap (dt, ntrace, & * p5 * HTN(i,j,iblk) * dt enddo enddo - endif endif - !------------------------------------------------------------------- - ! Transports for east cell edges. - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Transports for east cell edges. + !------------------------------------------------------------------- - !------------------------------------------------------------------- - ! Compute areas and vertices of departure triangles. - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Compute areas and vertices of departure triangles. + !------------------------------------------------------------------- edge = 'east' call locate_triangles(nx_block, ny_block, & ilo, ihi, jlo, jhi, & nghost, edge, & - icellsng(:,iblk), & - indxing(:,:), indxjng(:,:), & - dpx (:,:,iblk), dpy(:,:,iblk), & - dxu (:,:,iblk), dyu(:,:,iblk), & - earea (:,:,iblk), narea (:,:,iblk), & - xp (:,:,:,:), yp (:,:,:,:), & + icellsng (:,iblk), & + indxing(:,:), indxjng(:,:), & + dpx (:,:,iblk), dpy (:,:,iblk), & + dxu (:,:,iblk), dyu (:,:,iblk), & + xp(:,:,:,:), yp(:,:,:,:), & iflux, jflux, & - triarea, edgearea_e(:,:)) + triarea, & + l_fixed_area, edgearea_e(:,:)) - !------------------------------------------------------------------- - ! Given triangle vertices, compute coordinates of triangle points - ! needed for transport integrals. - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Given triangle vertices, compute coordinates of triangle points + ! needed for transport integrals. + !------------------------------------------------------------------- - call triangle_coordinates (nx_block, ny_block, & - integral_order, icellsng(:,iblk), & - indxing(:,:), indxjng(:,:), & - xp, yp) + call triangle_coordinates (nx_block, ny_block, & + integral_order, icellsng (:,iblk), & + indxing(:,:), indxjng(:,:), & + xp, yp) - !------------------------------------------------------------------- - ! Compute the transport across east cell edges by summing contributions - ! from each triangle. - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Compute the transport across east cell edges by summing contributions + ! from each triangle. + !------------------------------------------------------------------- ! open water - call transport_integrals(nx_block, ny_block, & - ntrace, icellsng (:,iblk), & - indxing(:,:), indxjng(:,:), & - tracer_type, depend, & - integral_order, triarea, & - iflux, jflux, & - xp, yp, & - mc(:,:,0,iblk), mx (:,:,0,iblk), & - my(:,:,0,iblk), mflxe(:,:,0)) + call transport_integrals(nx_block, ny_block, & + ntrace, icellsng (:,iblk), & + indxing(:,:), indxjng(:,:), & + tracer_type, depend, & + integral_order, triarea, & + iflux, jflux, & + xp, yp, & + mc(:,:,0,iblk), mx (:,:,0,iblk), & + my(:,:,0,iblk), mflxe(:,:,0)) ! ice categories do n = 1, ncat call transport_integrals & (nx_block, ny_block, & ntrace, icellsng (:,iblk), & - indxing(:,:), indxjng(:,:), & + indxing(:,:), indxjng(:,:), & tracer_type, depend, & integral_order, triarea, & iflux, jflux, & xp, yp, & - mc(:,:, n,iblk), mx (:,:, n,iblk), & - my(:,:, n,iblk), mflxe (:,:, n), & - tc(:,:,:,n,iblk), tx (:,:,:,n,iblk), & + mc(:,:, n,iblk), mx (:,:, n,iblk), & + my(:,:, n,iblk), mflxe(:,:, n), & + tc(:,:,:,n,iblk), tx (:,:,:,n,iblk), & ty(:,:,:,n,iblk), mtflxe(:,:,:,n)) enddo - !------------------------------------------------------------------- - ! Repeat for north edges - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Repeat for north edges + !------------------------------------------------------------------- edge = 'north' call locate_triangles(nx_block, ny_block, & ilo, ihi, jlo, jhi, & nghost, edge, & - icellsng(:,iblk), & - indxing(:,:), indxjng(:,:), & - dpx (:,:,iblk), dpy (:,:,iblk), & - dxu (:,:,iblk), dyu (:,:,iblk), & - earea (:,:,iblk), narea (:,:,iblk), & - xp (:,:,:,:), yp(:,:,:,:), & + icellsng (:,iblk), & + indxing(:,:), indxjng(:,:), & + dpx (:,:,iblk), dpy (:,:,iblk), & + dxu (:,:,iblk), dyu (:,:,iblk), & + xp(:,:,:,:), yp(:,:,:,:), & iflux, jflux, & - triarea, edgearea_n(:,:)) + triarea, & + l_fixed_area, edgearea_n(:,:)) - call triangle_coordinates (nx_block, ny_block, & - integral_order, icellsng(:,iblk), & - indxing(:,:), indxjng(:,:), & - xp, yp) + call triangle_coordinates (nx_block, ny_block, & + integral_order, icellsng (:,iblk), & + indxing(:,:), indxjng(:,:), & + xp, yp) ! open water - call transport_integrals(nx_block, ny_block, & - ntrace, icellsng (:,iblk), & - indxing(:,:), indxjng(:,:), & - tracer_type, depend, & - integral_order, triarea, & - iflux, jflux, & - xp, yp, & - mc(:,:,0,iblk), mx (:,:,0,iblk), & - my(:,:,0,iblk), mflxn(:,:,0)) + call transport_integrals(nx_block, ny_block, & + ntrace, icellsng (:,iblk), & + indxing(:,:), indxjng(:,:), & + tracer_type, depend, & + integral_order, triarea, & + iflux, jflux, & + xp, yp, & + mc(:,:,0,iblk), mx(:,:,0,iblk), & + my(:,:,0,iblk), mflxn(:,:,0)) ! ice categories do n = 1, ncat call transport_integrals & (nx_block, ny_block, & ntrace, icellsng (:,iblk), & - indxing(:,:), indxjng(:,:), & + indxing(:,:), indxjng(:,:), & tracer_type, depend, & integral_order, triarea, & iflux, jflux, & xp, yp, & - mc(:,:, n,iblk), mx (:,:, n,iblk), & - my(:,:, n,iblk), mflxn (:,:, n), & - tc(:,:,:,n,iblk), tx (:,:,:,n,iblk), & + mc(:,:, n,iblk), mx (:,:, n,iblk), & + my(:,:, n,iblk), mflxn(:,:, n), & + tc(:,:,:,n,iblk), tx (:,:,:,n,iblk), & ty(:,:,:,n,iblk), mtflxn(:,:,:,n)) enddo ! n - !------------------------------------------------------------------- - ! Update the ice area and tracers. - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Update the ice area and tracers. + !------------------------------------------------------------------- ! open water call update_fields (nx_block, ny_block, & @@ -793,7 +807,15 @@ subroutine horizontal_remap (dt, ntrace, & mm (:,:,0,iblk)) if (l_stop) then - call diagnostic_abort(istop,jstop,iblk,'negative area (open water)') + this_block = get_block(blocks_ice(iblk),iblk) + write (nu_diag,*) 'istep1, my_task, iblk, cat =', & + istep1, my_task, iblk, '0' + write (nu_diag,*) 'Global block:', this_block%block_id + if (istop > 0 .and. jstop > 0) & + write(nu_diag,*) 'Global i and j:', & + this_block%i_glob(istop), & + this_block%j_glob(jstop) + call abort_ice (subname//'ERROR: negative area (open water)') endif ! ice categories @@ -803,22 +825,27 @@ subroutine horizontal_remap (dt, ntrace, & ilo, ihi, jlo, jhi, & ntrace, & tracer_type, depend, & - tarear (:,:,iblk), l_stop, & + tarear(:,:,iblk), l_stop, & istop, jstop, & - mflxe (:,:, n), mflxn (:,:, n), & - mm (:,:, n,iblk), & + mflxe(:,:, n), mflxn(:,:, n), & + mm (:,:, n,iblk), & mtflxe(:,:,:,n), mtflxn(:,:,:,n), & - tm (:,:,:,n,iblk)) + tm (:,:,:,n,iblk)) if (l_stop) then write (nu_diag,*) 'istep1, my_task, iblk, cat =', & istep1, my_task, iblk, n - call diagnostic_abort(istop,jstop,iblk,'negative area (ice)') + write (nu_diag,*) 'Global block:', this_block%block_id + if (istop > 0 .and. jstop > 0) & + write(nu_diag,*) 'Global i and j:', & + this_block%i_glob(istop), & + this_block%j_glob(jstop) + call abort_ice (subname//'ERROR: negative area (ice)') endif enddo ! n enddo ! iblk -!TILL !$OMP END PARALLEL DO + !$TCXOMP END PARALLEL DO end subroutine horizontal_remap @@ -837,53 +864,53 @@ end subroutine horizontal_remap ! ! author William H. Lipscomb, LANL - subroutine make_masks (nx_block, ny_block, & - ilo, ihi, jlo, jhi, & - nghost, ntrace, & - has_dependents, & - icells, & - indxi, indxj, & - mm, mmask, & - tm, tmask) + subroutine make_masks (nx_block, ny_block, & + ilo, ihi, jlo, jhi, & + nghost, ntrace, & + has_dependents, & + icells, & + indxi, indxj, & + mm, mmask, & + tm, tmask) integer (kind=int_kind), intent(in) :: & - nx_block, ny_block, & ! block dimensions - ilo,ihi,jlo,jhi , & ! beginning and end of physical domain - nghost , & ! number of ghost cells - ntrace ! number of tracers in use + nx_block, ny_block ,&! block dimensions + ilo,ihi,jlo,jhi ,&! beginning and end of physical domain + nghost ,&! number of ghost cells + ntrace ! number of tracers in use logical (kind=log_kind), dimension (ntrace), intent(in) :: & - has_dependents ! true if a tracer has dependent tracers + has_dependents ! true if a tracer has dependent tracers integer (kind=int_kind), dimension(0:ncat), intent(out) :: & - icells ! number of cells with ice + icells ! number of cells with ice integer (kind=int_kind), dimension(nx_block*ny_block,0:ncat), intent(out) :: & - indxi , & ! compressed i/j indices - indxj + indxi ,&! compressed i/j indices + indxj real (kind=dbl_kind), dimension (nx_block,ny_block,0:ncat), intent(in) :: & - mm ! mean ice area in each grid cell + mm ! mean ice area in each grid cell real (kind=dbl_kind), dimension (nx_block,ny_block,0:ncat), intent(out) :: & - mmask ! = 1. if ice is present, else = 0. + mmask ! = 1. if ice is present, else = 0. real (kind=dbl_kind), dimension (nx_block, ny_block, ntrace, ncat), intent(in), optional :: & - tm ! mean tracer values in each grid cell + tm ! mean tracer values in each grid cell real (kind=dbl_kind), dimension (nx_block, ny_block, ntrace, ncat), intent(out), optional :: & - tmask ! = 1. if tracer is present, else = 0. + tmask ! = 1. if tracer is present, else = 0. ! local variables integer (kind=int_kind) :: & - i, j, ij , & ! horizontal indices - n , & ! ice category index - nt ! tracer index + i, j, ij ,&! horizontal indices + n ,&! ice category index + nt ! tracer index real (kind=dbl_kind) :: & - puny ! + puny ! character(len=*), parameter :: subname = '(make_masks)' @@ -899,9 +926,9 @@ subroutine make_masks (nx_block, ny_block, & enddo enddo - !------------------------------------------------------------------- - ! open water mask - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! open water mask + !------------------------------------------------------------------- icells(0) = 0 do j = 1, ny_block @@ -920,9 +947,9 @@ subroutine make_masks (nx_block, ny_block, & do n = 1, ncat - !------------------------------------------------------------------- - ! Find grid cells where ice is present. - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Find grid cells where ice is present. + !------------------------------------------------------------------- icells(n) = 0 do j = 1, ny_block @@ -936,9 +963,9 @@ subroutine make_masks (nx_block, ny_block, & enddo enddo - !------------------------------------------------------------------- - ! ice area mask - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! ice area mask + !------------------------------------------------------------------- mmask(:,:,n) = c0 do ij = 1, icells(n) @@ -947,9 +974,9 @@ subroutine make_masks (nx_block, ny_block, & mmask(i,j,n) = c1 enddo - !------------------------------------------------------------------- - ! tracer masks - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! tracer masks + !------------------------------------------------------------------- if (present(tm)) then @@ -969,11 +996,11 @@ subroutine make_masks (nx_block, ny_block, & endif ! present(tm) - !------------------------------------------------------------------- - ! Redefine icells - ! For nghost = 1, exclude ghost cells - ! For nghost = 2, include one layer of ghost cells - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Redefine icells + ! For nghost = 1, exclude ghost cells + ! For nghost = 2, include one layer of ghost cells + !------------------------------------------------------------------- icells(n) = 0 do j = jlo-nghost+1, jhi+nghost-1 @@ -986,7 +1013,7 @@ subroutine make_masks (nx_block, ny_block, & endif ! mm > puny enddo enddo - + enddo ! n end subroutine make_masks @@ -1004,7 +1031,12 @@ subroutine construct_fields (nx_block, ny_block, & tracer_type, depend, & has_dependents, icells, & indxi, indxj, & - hm, & + hm, xav, & + yav, xxav, & + yyav, & +! xyav, & +! xxxav, xxyav, & +! xyyav, yyyav, & mm, mc, & mx, my, & mmask, & @@ -1013,110 +1045,109 @@ subroutine construct_fields (nx_block, ny_block, & tmask) integer (kind=int_kind), intent(in) :: & - nx_block, ny_block, & ! block dimensions - ilo,ihi,jlo,jhi , & ! beginning and end of physical domain - nghost , & ! number of ghost cells - ntrace , & ! number of tracers in use + nx_block, ny_block ,&! block dimensions + ilo,ihi,jlo,jhi ,&! beginning and end of physical domain + nghost ,&! number of ghost cells + ntrace ,&! number of tracers in use icells ! number of cells with mass integer (kind=int_kind), dimension (ntrace), intent(in) :: & - tracer_type , & ! = 1, 2, or 3 (see comments above) - depend ! tracer dependencies (see above) + tracer_type ,&! = 1, 2, or 3 (see comments above) + depend ! tracer dependencies (see above) logical (kind=log_kind), dimension (ntrace), intent(in) :: & - has_dependents ! true if a tracer has dependent tracers + has_dependents ! true if a tracer has dependent tracers integer (kind=int_kind), dimension(nx_block*ny_block), intent(in) :: & - indxi , & ! compressed i/j indices + indxi ,&! compressed i/j indices indxj real (kind=dbl_kind), dimension (nx_block,ny_block), intent(in) :: & - hm ! land/boundary mask, thickness (T-cell) + hm ,&! land/boundary mask, thickness (T-cell) + xav, yav ,&! mean T-cell values of x, y + xxav, yyav ! mean T-cell values of xx, yy +! xyav, ,&! mean T-cell values of xy +! xxxav,xxyav,xyyav,yyyav ! mean T-cell values of xxx, xxy, xyy, yyy real (kind=dbl_kind), dimension (nx_block,ny_block), intent(in) :: & - mm , & ! mean value of mass field - mmask ! = 1. if ice is present, = 0. otherwise + mm ,&! mean value of mass field + mmask ! = 1. if ice is present, = 0. otherwise real (kind=dbl_kind), dimension (nx_block,ny_block,ntrace), intent(in), optional :: & - tm , & ! mean tracer - tmask ! = 1. if tracer is present, = 0. otherwise + tm ,&! mean tracer + tmask ! = 1. if tracer is present, = 0. otherwise real (kind=dbl_kind), dimension (nx_block,ny_block), intent(out) :: & - mc , & ! mass value at geometric center of cell - mx, my ! limited derivative of mass wrt x and y + mc ,&! mass value at geometric center of cell + mx, my ! limited derivative of mass wrt x and y real (kind=dbl_kind), dimension (nx_block,ny_block,ntrace), intent(out), optional :: & - tc , & ! tracer at geometric center of cell - tx, ty ! limited derivative of tracer wrt x and y + tc ,&! tracer at geometric center of cell + tx, ty ! limited derivative of tracer wrt x and y ! local variables integer (kind=int_kind) :: & - i, j , & ! horizontal indices - nt, nt1 , & ! tracer indices - ij ! combined i/j horizontal index + i, j ,&! horizontal indices + nt, nt1 ,&! tracer indices + ij ! combined i/j horizontal index real (kind=dbl_kind), dimension (nx_block,ny_block) :: & - xav , & ! mean T-cell values of x - yav , & ! mean T-cell values of y - mxav , & ! x coordinate of center of mass - myav ! y coordinate of center of mass - - real (kind=dbl_kind), parameter :: xxav=c1/c12 ! mean T-cell values of xx - real (kind=dbl_kind), parameter :: yyav=c1/c12 ! mean T-cell values of yy + mxav ,&! x coordinate of center of mass + myav ! y coordinate of center of mass real (kind=dbl_kind), dimension (nx_block,ny_block,ntrace) :: & - mtxav , & ! x coordinate of center of mass*tracer - mtyav ! y coordinate of center of mass*tracer + mtxav ,&! x coordinate of center of mass*tracer + mtyav ! y coordinate of center of mass*tracer real (kind=dbl_kind) :: & puny, & - w2, w3, w7 ! work variables + w1, w2, w3, w7 ! work variables character(len=*), parameter :: subname = '(construct_fields)' - !------------------------------------------------------------------- - ! Compute field values at the geometric center of each grid cell, - ! and compute limited gradients in the x and y directions. - ! - ! For second order accuracy, each state variable is approximated as - ! a field varying linearly over x and y within each cell. For each - ! category, the integrated value of m(x,y) over the cell must - ! equal mm(i,j,n)*tarea(i,j), where tarea(i,j) is the cell area. - ! Similarly, the integrated value of m(x,y)*t(x,y) must equal - ! the total mass*tracer, mm(i,j,n)*tm(i,j,n)*tarea(i,j). - ! - ! These integral conditions are satisfied for linear fields if we - ! stipulate the following: - ! (1) The mean mass, mm, is equal to the mass at the cell centroid. - ! (2) The mean value tm1 of type 1 tracers is equal to the value - ! at the center of mass. - ! (3) The mean value tm2 of type 2 tracers is equal to the value - ! at the center of mass*tm1, where tm2 depends on tm1. - ! (See comments at the top of the module.) - ! - ! We want to find the value of each state variable at a standard - ! reference point, which we choose to be the geometric center of - ! the cell. The geometric center is located at the intersection - ! of the line joining the midpoints of the north and south edges - ! with the line joining the midpoints of the east and west edges. - ! To find the value at the geometric center, we must know the - ! location of the cell centroid/center of mass, along with the - ! mean value and the gradients with respect to x and y. - ! - ! The cell gradients are first computed from the difference between - ! values in the neighboring cells, then limited by requiring that - ! no new extrema are created within the cell. - ! - ! For rectangular coordinates the centroid and the geometric - ! center coincide, which means that some of the equations in this - ! subroutine could be simplified. However, the full equations - ! are retained for generality. - !------------------------------------------------------------------- - - !------------------------------------------------------------------- - ! Initialize - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Compute field values at the geometric center of each grid cell, + ! and compute limited gradients in the x and y directions. + ! + ! For second order accuracy, each state variable is approximated as + ! a field varying linearly over x and y within each cell. For each + ! category, the integrated value of m(x,y) over the cell must + ! equal mm(i,j,n)*tarea(i,j), where tarea(i,j) is the cell area. + ! Similarly, the integrated value of m(x,y)*t(x,y) must equal + ! the total mass*tracer, mm(i,j,n)*tm(i,j,n)*tarea(i,j). + ! + ! These integral conditions are satisfied for linear fields if we + ! stipulate the following: + ! (1) The mean mass, mm, is equal to the mass at the cell centroid. + ! (2) The mean value tm1 of type 1 tracers is equal to the value + ! at the center of mass. + ! (3) The mean value tm2 of type 2 tracers is equal to the value + ! at the center of mass*tm1, where tm2 depends on tm1. + ! (See comments at the top of the module.) + ! + ! We want to find the value of each state variable at a standard + ! reference point, which we choose to be the geometric center of + ! the cell. The geometric center is located at the intersection + ! of the line joining the midpoints of the north and south edges + ! with the line joining the midpoints of the east and west edges. + ! To find the value at the geometric center, we must know the + ! location of the cell centroid/center of mass, along with the + ! mean value and the gradients with respect to x and y. + ! + ! The cell gradients are first computed from the difference between + ! values in the neighboring cells, then limited by requiring that + ! no new extrema are created within the cell. + ! + ! For rectangular coordinates the centroid and the geometric + ! center coincide, which means that some of the equations in this + ! subroutine could be simplified. However, the full equations + ! are retained for generality. + !------------------------------------------------------------------- + + !------------------------------------------------------------------- + ! Initialize + !------------------------------------------------------------------- call icepack_query_parameters(puny_out=puny) call icepack_warnings_flush(nu_diag) @@ -1125,11 +1156,9 @@ subroutine construct_fields (nx_block, ny_block, & do j = 1, ny_block do i = 1, nx_block - xav(i,j) = c0 - yav(i,j) = c0 - mc(i,j) = c0 - mx(i,j) = c0 - my(i,j) = c0 + mc(i,j) = c0 + mx(i,j) = c0 + my(i,j) = c0 mxav(i,j) = c0 myav(i,j) = c0 enddo @@ -1146,10 +1175,10 @@ subroutine construct_fields (nx_block, ny_block, & enddo enddo endif - + ! limited gradient of mass field in each cell (except masked cells) ! Note: The gradient is computed in scaled coordinates with - ! dxT = dyT = hte = htn = 1. + ! dxt = dyt = hte = htn = 1. call limited_gradient (nx_block, ny_block, & ilo, ihi, jlo, jhi, & @@ -1163,118 +1192,148 @@ subroutine construct_fields (nx_block, ny_block, & j = indxj(ij) ! mass field at geometric center +!echmod: xav = yav = 0 mc(i,j) = mm(i,j) +! mc(i,j) = mm(i,j) - xav(i,j)*mx(i,j) & +! - yav(i,j)*my(i,j) + enddo ! ij ! tracers if (present(tm)) then - do ij = 1,icells ! cells with mass - i = indxi(ij) - j = indxj(ij) - - ! center of mass (mxav,myav) for each cell - - mxav(i,j) = mx(i,j)*xxav / mm(i,j) - myav(i,j) = my(i,j)*yyav / mm(i,j) - - enddo - - do nt = 1, ntrace - - if (tracer_type(nt)==1) then ! independent of other tracers - - call limited_gradient(nx_block, ny_block, & - ilo, ihi, jlo, jhi, & - nghost, & - tm(:,:,nt), mmask, & - mxav, myav, & - tx(:,:,nt), ty(:,:,nt)) - - if (has_dependents(nt)) then ! need center of area*tracer - - do j = 1, ny_block - do i = 1, nx_block - mtxav(i,j,nt) = c0 - mtyav(i,j,nt) = c0 - enddo - enddo - - do ij = 1, icells ! Note: no tx or ty in ghost cells - ! (bound calls are later) - i = indxi(ij) - j = indxj(ij) - - ! tracer value at geometric center - tc(i,j,nt) = tm(i,j,nt) - tx(i,j,nt)*mxav(i,j) & - - ty(i,j,nt)*myav(i,j) - - if (tmask(i,j,nt) > puny) then + do ij = 1,icells ! cells with mass + i = indxi(ij) + j = indxj(ij) + + ! center of mass (mxav,myav) for each cell +!echmod: xyav = 0 + mxav(i,j) = (mx(i,j)*xxav(i,j) & + + mc(i,j)*xav (i,j)) / mm(i,j) + myav(i,j) = (my(i,j)*yyav(i,j) & + + mc(i,j)*yav(i,j)) / mm(i,j) + +! mxav(i,j) = (mx(i,j)*xxav(i,j) & +! + my(i,j)*xyav(i,j) & +! + mc(i,j)*xav (i,j)) / mm(i,j) +! myav(i,j) = (mx(i,j)*xyav(i,j) & +! + my(i,j)*yyav(i,j) & +! + mc(i,j)*yav(i,j)) / mm(i,j) + enddo + + do nt = 1, ntrace + + if (tracer_type(nt)==1) then ! independent of other tracers + + call limited_gradient(nx_block, ny_block, & + ilo, ihi, jlo, jhi, & + nghost, & + tm(:,:,nt), mmask, & + mxav, myav, & + tx(:,:,nt), ty(:,:,nt)) + + if (has_dependents(nt)) then ! need center of area*tracer + + do j = 1, ny_block + do i = 1, nx_block + mtxav(i,j,nt) = c0 + mtyav(i,j,nt) = c0 + enddo + enddo - ! center of area*tracer - w2 = mc(i,j)*tx(i,j,nt) & - + mx(i,j)*tc(i,j,nt) - w3 = mc(i,j)*ty(i,j,nt) & - + my(i,j)*tc(i,j,nt) - w7 = c1 / (mm(i,j)*tm(i,j,nt)) - ! echmod: grid arrays = 0 - mtxav(i,j,nt) = w2*xxav *w7 - mtyav(i,j,nt) = w3*yyav * w7 - endif ! tmask + do ij = 1, icells ! Note: no tx or ty in ghost cells + ! (bound calls are later) + i = indxi(ij) + j = indxj(ij) - enddo ! ij + ! tracer value at geometric center + tc(i,j,nt) = tm(i,j,nt) - tx(i,j,nt)*mxav(i,j) & + - ty(i,j,nt)*myav(i,j) + + if (tmask(i,j,nt) > puny) then + + ! center of area*tracer + w1 = mc(i,j)*tc(i,j,nt) + w2 = mc(i,j)*tx(i,j,nt) & + + mx(i,j)*tc(i,j,nt) + w3 = mc(i,j)*ty(i,j,nt) & + + my(i,j)*tc(i,j,nt) +! w4 = mx(i,j)*tx(i,j,nt) +! w5 = mx(i,j)*ty(i,j,nt) & +! + my(i,j)*tx(i,j,nt) +! w6 = my(i,j)*ty(i,j,nt) + w7 = c1 / (mm(i,j)*tm(i,j,nt)) +!echmod: grid arrays = 0 + mtxav(i,j,nt) = (w1*xav (i,j) + w2*xxav (i,j)) & + * w7 + mtyav(i,j,nt) = (w1*yav(i,j) + w3*yyav(i,j)) & + * w7 + +! mtxav(i,j,nt) = (w1*xav (i,j) + w2*xxav (i,j) & +! + w3*xyav (i,j) + w4*xxxav(i,j) & +! + w5*xxyav(i,j) + w6*xyyav(i,j)) & +! * w7 +! mtyav(i,j,nt) = (w1*yav(i,j) + w2*xyav (i,j) & +! + w3*yyav(i,j) + w4*xxyav(i,j) & +! + w5*xyyav(i,j) + w6*yyyav(i,j)) & +! * w7 + endif ! tmask - else ! no dependents + enddo ! ij - do ij = 1, icells ! mass is present - i = indxi(ij) - j = indxj(ij) + else ! no dependents - ! tracer value at geometric center - tc(i,j,nt) = tm(i,j,nt) - tx(i,j,nt)*mxav(i,j) & - - ty(i,j,nt)*myav(i,j) - enddo ! ij + do ij = 1, icells ! mass is present + i = indxi(ij) + j = indxj(ij) - endif ! has_dependents + ! tracer value at geometric center + tc(i,j,nt) = tm(i,j,nt) - tx(i,j,nt)*mxav(i,j) & + - ty(i,j,nt)*myav(i,j) + enddo ! ij - elseif (tracer_type(nt)==2) then ! tracer nt depends on nt1 - nt1 = depend(nt) + endif ! has_dependents - call limited_gradient(nx_block, ny_block, & - ilo, ihi, jlo, jhi, & - nghost, & - tm (:,:,nt), tmask(:,:,nt1), & - mtxav(:,:,nt1), mtyav(:,:,nt1), & - tx (:,:,nt), ty (:,:,nt)) + elseif (tracer_type(nt)==2) then ! tracer nt depends on nt1 + nt1 = depend(nt) - do ij = 1, icells ! ice is present - i = indxi(ij) - j = indxj(ij) - tc(i,j,nt) = tm(i,j,nt) & - - tx(i,j,nt) * mtxav(i,j,nt1) & - - ty(i,j,nt) * mtyav(i,j,nt1) - enddo ! ij + call limited_gradient(nx_block, ny_block, & + ilo, ihi, jlo, jhi, & + nghost, & + tm(:,:,nt), tmask(:,:,nt1), & + mtxav(:,:,nt1), mtyav(:,:,nt1), & + tx(:,:,nt), ty(:,:,nt)) - elseif (tracer_type(nt)==3) then ! upwind approx; gradient = 0 + do ij = 1, icells ! ice is present + i = indxi(ij) + j = indxj(ij) + tc(i,j,nt) = tm(i,j,nt) & + - tx(i,j,nt) * mtxav(i,j,nt1) & + - ty(i,j,nt) * mtyav(i,j,nt1) + enddo ! ij - do ij = 1, icells - i = indxi(ij) - j = indxj(ij) + elseif (tracer_type(nt)==3) then ! upwind approx; gradient = 0 - tc(i,j,nt) = tm(i,j,nt) - enddo ! ij + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) - endif ! tracer_type + tc(i,j,nt) = tm(i,j,nt) +! tx(i,j,nt) = c0 ! already initialized to 0. +! ty(i,j,nt) = c0 + enddo ! ij - enddo ! ntrace + endif ! tracer_type + enddo ! ntrace endif ! present (tm) end subroutine construct_fields !======================================================================= +! ! Compute a limited gradient of the scalar field phi in scaled coordinates. ! "Limited" means that we do not create new extrema in phi. For ! instance, field values at the cell corners can neither exceed the @@ -1292,44 +1351,43 @@ subroutine limited_gradient (nx_block, ny_block, & gx, gy) integer (kind=int_kind), intent(in) :: & - nx_block, ny_block, & ! block dimensions - ilo,ihi,jlo,jhi , & ! beginning and end of physical domain - nghost ! number of ghost cells - - real (kind=dbl_kind), dimension (nx_block,ny_block), intent (in) :: & - phi , & ! input tracer field (mean values in each grid cell) - phimask ! phimask(i,j) = 1 if phi(i,j) has physical meaning, = 0 otherwise. - ! For instance, aice has no physical meaning in land cells, - ! and hice no physical meaning where aice = 0. + nx_block, ny_block,&! block dimensions + ilo,ihi,jlo,jhi ,&! beginning and end of physical domain + nghost ! number of ghost cells real (kind=dbl_kind), dimension (nx_block,ny_block), intent (in) :: & - cnx , & ! x-coordinate of phi relative to geometric center of cell - cny ! y-coordinate of phi relative to geometric center of cell½ + phi ,&! input tracer field (mean values in each grid cell) + cnx ,&! x-coordinate of phi relative to geometric center of cell + cny ,&! y-coordinate of phi relative to geometric center of cell + phimask + ! phimask(i,j) = 1 if phi(i,j) has physical meaning, = 0 otherwise. + ! For instance, aice has no physical meaning in land cells, + ! and hice no physical meaning where aice = 0. real (kind=dbl_kind), dimension (nx_block,ny_block), intent(out) :: & - gx , & ! limited x-direction gradient - gy ! limited y-direction gradient + gx ,&! limited x-direction gradient + gy ! limited y-direction gradient ! local variables integer (kind=int_kind) :: & - i, j, ij , & ! standard indices - icells ! number of cells to limit + i, j, ij ,&! standard indices + icells ! number of cells to limit integer (kind=int_kind), dimension(nx_block*ny_block) :: & - indxi, indxj ! combined i/j horizontal indices + indxi, indxj ! combined i/j horizontal indices real (kind=dbl_kind) :: & - phi_nw, phi_n, phi_ne , & ! values of phi in 8 neighbor cells - phi_w, phi_e , & - phi_sw, phi_s, phi_se , & - qmn, qmx , & ! min and max value of phi within grid cell - pmn, pmx , & ! min and max value of phi among neighbor cells - w1, w2, w3, w4 ! work variables + phi_nw, phi_n, phi_ne ,&! values of phi in 8 neighbor cells + phi_w, phi_e ,& + phi_sw, phi_s, phi_se ,& + qmn, qmx ,&! min and max value of phi within grid cell + pmn, pmx ,&! min and max value of phi among neighbor cells + w1, w2, w3, w4 ! work variables real (kind=dbl_kind) :: & - puny , & ! - gxtmp, gytmp ! temporary term for x- and y- limited gradient + puny, & ! + gxtmp, gytmp ! temporary term for x- and y- limited gradient character(len=*), parameter :: subname = '(limited_gradient)' @@ -1363,22 +1421,22 @@ subroutine limited_gradient (nx_block, ny_block, & ! Note: phimask = 1. or 0. If phimask = 1., use the true value; ! if phimask = 0., use the home cell value so that non-physical ! values of phi do not contribute to the gradient. - phi_nw = phimask(i-1,j+1) * phi(i-1,j+1) & - + (c1-phimask(i-1,j+1))* phi(i ,j ) - phi_n = phimask(i ,j+1) * phi(i ,j+1) & - + (c1-phimask(i ,j+1))* phi(i ,j ) - phi_ne = phimask(i+1,j+1) * phi(i+1,j+1) & - + (c1-phimask(i+1,j+1))* phi(i ,j ) - phi_w = phimask(i-1,j ) * phi(i-1,j ) & - + (c1-phimask(i-1,j ))* phi(i ,j ) - phi_e = phimask(i+1,j ) * phi(i+1,j ) & - + (c1-phimask(i+1,j ))* phi(i ,j ) - phi_sw = phimask(i-1,j-1) * phi(i-1,j-1) & - + (c1-phimask(i-1,j-1))* phi(i ,j ) - phi_s = phimask(i ,j-1) * phi(i ,j-1) & - + (c1-phimask(i ,j-1))* phi(i ,j ) - phi_se = phimask(i+1,j-1) * phi(i+1,j-1) & - + (c1-phimask(i+1,j-1))* phi(i ,j ) + phi_nw = phimask(i-1,j+1) * phi(i-1,j+1) & + + (c1-phimask(i-1,j+1))* phi(i,j) + phi_n = phimask(i,j+1) * phi(i,j+1) & + + (c1-phimask(i,j+1)) * phi(i,j) + phi_ne = phimask(i+1,j+1) * phi(i+1,j+1) & + + (c1-phimask(i+1,j+1))* phi(i,j) + phi_w = phimask(i-1,j) * phi(i-1,j) & + + (c1-phimask(i-1,j)) * phi(i,j) + phi_e = phimask(i+1,j) * phi(i+1,j) & + + (c1-phimask(i+1,j)) * phi(i,j) + phi_sw = phimask(i-1,j-1) * phi(i-1,j-1) & + + (c1-phimask(i-1,j-1))* phi(i,j) + phi_s = phimask(i,j-1) * phi(i,j-1) & + + (c1-phimask(i,j-1)) * phi(i,j) + phi_se = phimask(i+1,j-1) * phi(i+1,j-1) & + + (c1-phimask(i+1,j-1))* phi(i,j) ! unlimited gradient components ! (factors of two cancel out) @@ -1449,34 +1507,34 @@ subroutine departure_points (nx_block, ny_block, & istop, jstop) integer (kind=int_kind), intent(in) :: & - nx_block, ny_block, & ! block dimensions - ilo,ihi,jlo,jhi, & ! beginning and end of physical domain - nghost ! number of ghost cells + nx_block, ny_block,&! block dimensions + ilo,ihi,jlo,jhi, &! beginning and end of physical domain + nghost ! number of ghost cells real (kind=dbl_kind), intent(in) :: & dt ! time step (s) real (kind=dbl_kind), dimension (nx_block,ny_block), intent(in) :: & - uvel , & ! x-component of velocity (m/s) - vvel , & ! y-component of velocity (m/s) - dxu , & ! E-W dimensions of U-cell (m) - dyu , & ! N-S dimensions of U-cell (m) - HTN , & ! length of north face of T-cell (m) - HTE ! length of east face of T-cell (m) + uvel ,&! x-component of velocity (m/s) + vvel ,&! y-component of velocity (m/s) + dxu ,&! E-W dimensions of U-cell (m) + dyu ,&! N-S dimensions of U-cell (m) + HTN ,&! length of north face of T-cell (m) + HTE ! length of east face of T-cell (m) real (kind=dbl_kind), dimension (nx_block,ny_block), intent(out) :: & - dpx , & ! coordinates of departure points (m) - dpy ! coordinates of departure points (m) + dpx ,&! coordinates of departure points (m) + dpy ! coordinates of departure points (m) logical (kind=log_kind), intent(in) :: & - l_dp_midpt ! if true, find departure points using - ! corrected midpoint velocity + l_dp_midpt ! if true, find departure points using + ! corrected midpoint velocity logical (kind=log_kind), intent(inout) :: & - l_stop ! if true, abort on return + l_stop ! if true, abort on return integer (kind=int_kind), intent(inout) :: & - istop, jstop ! indices of grid cell where model aborts + istop, jstop ! indices of grid cell where model aborts ! local variables @@ -1484,20 +1542,20 @@ subroutine departure_points (nx_block, ny_block, & i, j, i2, j2 ! horizontal indices real (kind=dbl_kind) :: & - mpx, mpy , & ! coordinates of midpoint of back trajectory, + mpx, mpy ,&! coordinates of midpoint of back trajectory, ! relative to cell corner - mpxt, mpyt , & ! midpoint coordinates relative to cell center + mpxt, mpyt ,&! midpoint coordinates relative to cell center ump, vmp ! corrected velocity at midpoint character(len=*), parameter :: subname = '(departure_points)' - !------------------------------------------------------------------- - ! Estimate departure points. - ! This estimate is 1st-order accurate in time; improve accuracy by - ! using midpoint approximation (to add later). - ! For nghost = 1, loop over physical cells and update ghost cells later. - ! For nghost = 2, loop over a layer of ghost cells and skip update. - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Estimate departure points. + ! This estimate is 1st-order accurate in time; improve accuracy by + ! using midpoint approximation (to add later). + ! For nghost = 1, loop over physical cells and update ghost cells later. + ! For nghost = 2, loop over a layer of ghost cells and skip update. + !------------------------------------------------------------------- dpx(:,:) = c0 dpy(:,:) = c0 @@ -1532,84 +1590,84 @@ subroutine departure_points (nx_block, ny_block, & return endif - if (l_dp_midpt) then ! find dep pts using corrected midpt velocity - - do j = jlo-nghost+1, jhi+nghost-1 - do i = ilo-nghost+1, ihi+nghost-1 - if (uvel(i,j)/=c0 .or. vvel(i,j)/=c0) then - - !------------------------------------------------------------------- - ! Scale departure points to coordinate system in which grid cells - ! have sides of unit length. - !------------------------------------------------------------------- - - dpx(i,j) = dpx(i,j) / dxu(i,j) - dpy(i,j) = dpy(i,j) / dyu(i,j) - - !------------------------------------------------------------------- - ! Estimate midpoint of backward trajectory relative to corner (i,j). - !------------------------------------------------------------------- - - mpx = p5 * dpx(i,j) - mpy = p5 * dpy(i,j) - - !------------------------------------------------------------------- - ! Determine the indices (i2,j2) of the cell where the trajectory lies. - ! Compute the coordinates of the midpoint of the backward trajectory - ! relative to the cell center in a stretch coordinate system - ! with vertices at (1/2, 1/2), (1/2, -1/2), etc. - !------------------------------------------------------------------- - - if (mpx >= c0 .and. mpy >= c0) then ! cell (i+1,j+1) - i2 = i+1 - j2 = j+1 - mpxt = mpx - p5 - mpyt = mpy - p5 - elseif (mpx < c0 .and. mpy < c0) then ! cell (i,j) - i2 = i - j2 = j - mpxt = mpx + p5 - mpyt = mpy + p5 - elseif (mpx >= c0 .and. mpy < c0) then ! cell (i+1,j) - i2 = i+1 - j2 = j - mpxt = mpx - p5 - mpyt = mpy + p5 - elseif (mpx < c0 .and. mpy >= c0) then ! cell (i,j+1) - i2 = i - j2 = j+1 - mpxt = mpx + p5 - mpyt = mpy - p5 - endif - - !------------------------------------------------------------------- - ! Using a bilinear approximation, estimate the velocity at the - ! trajectory midpoint in the (i2,j2) reference frame. - !------------------------------------------------------------------- - - ump = uvel(i2-1,j2-1)*(mpxt-p5)*(mpyt-p5) & - - uvel(i2, j2-1)*(mpxt+p5)*(mpyt-p5) & - + uvel(i2, j2 )*(mpxt+p5)*(mpyt+p5) & - - uvel(i2-1,j2 )*(mpxt-p5)*(mpyt+p5) - - vmp = vvel(i2-1,j2-1)*(mpxt-p5)*(mpyt-p5) & - - vvel(i2, j2-1)*(mpxt+p5)*(mpyt-p5) & - + vvel(i2, j2 )*(mpxt+p5)*(mpyt+p5) & - - vvel(i2-1,j2 )*(mpxt-p5)*(mpyt+p5) - - !------------------------------------------------------------------- - ! Use the midpoint velocity to estimate the coordinates of the - ! departure point relative to corner (i,j). - !------------------------------------------------------------------- - - dpx(i,j) = -dt * ump - dpy(i,j) = -dt * vmp - - endif ! nonzero velocity - - enddo ! i - enddo ! j - + if (l_dp_midpt) then ! find dep pts using corrected midpt velocity + + do j = jlo-nghost+1, jhi+nghost-1 + do i = ilo-nghost+1, ihi+nghost-1 + if (uvel(i,j)/=c0 .or. vvel(i,j)/=c0) then + + !------------------------------------------------------------------- + ! Scale departure points to coordinate system in which grid cells + ! have sides of unit length. + !------------------------------------------------------------------- + + dpx(i,j) = dpx(i,j) / dxu(i,j) + dpy(i,j) = dpy(i,j) / dyu(i,j) + + !------------------------------------------------------------------- + ! Estimate midpoint of backward trajectory relative to corner (i,j). + !------------------------------------------------------------------- + + mpx = p5 * dpx(i,j) + mpy = p5 * dpy(i,j) + + !------------------------------------------------------------------- + ! Determine the indices (i2,j2) of the cell where the trajectory lies. + ! Compute the coordinates of the midpoint of the backward trajectory + ! relative to the cell center in a stretch coordinate system + ! with vertices at (1/2, 1/2), (1/2, -1/2), etc. + !------------------------------------------------------------------- + + if (mpx >= c0 .and. mpy >= c0) then ! cell (i+1,j+1) + i2 = i+1 + j2 = j+1 + mpxt = mpx - p5 + mpyt = mpy - p5 + elseif (mpx < c0 .and. mpy < c0) then ! cell (i,j) + i2 = i + j2 = j + mpxt = mpx + p5 + mpyt = mpy + p5 + elseif (mpx >= c0 .and. mpy < c0) then ! cell (i+1,j) + i2 = i+1 + j2 = j + mpxt = mpx - p5 + mpyt = mpy + p5 + elseif (mpx < c0 .and. mpy >= c0) then ! cell (i,j+1) + i2 = i + j2 = j+1 + mpxt = mpx + p5 + mpyt = mpy - p5 + endif + + !------------------------------------------------------------------- + ! Using a bilinear approximation, estimate the velocity at the + ! trajectory midpoint in the (i2,j2) reference frame. + !------------------------------------------------------------------- + + ump = uvel(i2-1,j2-1)*(mpxt-p5)*(mpyt-p5) & + - uvel(i2, j2-1)*(mpxt+p5)*(mpyt-p5) & + + uvel(i2, j2 )*(mpxt+p5)*(mpyt+p5) & + - uvel(i2-1,j2 )*(mpxt-p5)*(mpyt+p5) + + vmp = vvel(i2-1,j2-1)*(mpxt-p5)*(mpyt-p5) & + - vvel(i2, j2-1)*(mpxt+p5)*(mpyt-p5) & + + vvel(i2, j2 )*(mpxt+p5)*(mpyt+p5) & + - vvel(i2-1,j2 )*(mpxt-p5)*(mpyt+p5) + + !------------------------------------------------------------------- + ! Use the midpoint velocity to estimate the coordinates of the + ! departure point relative to corner (i,j). + !------------------------------------------------------------------- + + dpx(i,j) = -dt * ump + dpy(i,j) = -dt * vmp + + endif ! nonzero velocity + + enddo ! i + enddo ! j + endif ! l_dp_midpt end subroutine departure_points @@ -1629,26 +1687,24 @@ subroutine locate_triangles (nx_block, ny_block, & indxi, indxj, & dpx, dpy, & dxu, dyu, & - earea, narea, & xp, yp, & iflux, jflux, & - triarea, edgearea) + triarea, & + l_fixed_area, edgearea) integer (kind=int_kind), intent(in) :: & - nx_block, ny_block, & ! block dimensions - ilo,ihi,jlo,jhi , & ! beginning and end of physical domain - nghost ! number of ghost cells + nx_block, ny_block,&! block dimensions + ilo,ihi,jlo,jhi ,&! beginning and end of physical domain + nghost ! number of ghost cells character (len=char_len), intent(in) :: & edge ! 'north' or 'east' real (kind=dbl_kind), dimension(nx_block,ny_block), intent(in) :: & - dpx , & ! x coordinates of departure points at cell corners - dpy , & ! y coordinates of departure points at cell corners - dxu , & ! E-W dimension of U-cell (m) - dyu , & ! N-S dimension of U-cell (m) - earea , & ! area of E-cell - narea ! area of N-cell + dpx ,&! x coordinates of departure points at cell corners + dpy ,&! y coordinates of departure points at cell corners + dxu ,&! E-W dimension of U-cell (m) + dyu ! N-S dimension of U-cell (m) real (kind=dbl_kind), dimension (nx_block,ny_block,0:nvert,ngroups), intent(out) :: & xp, yp ! coordinates of triangle vertices @@ -1657,16 +1713,22 @@ subroutine locate_triangles (nx_block, ny_block, & triarea ! area of departure triangle integer (kind=int_kind), dimension (nx_block,ny_block,ngroups), intent(out) :: & - iflux , & ! i index of cell contributing transport + iflux ,&! i index of cell contributing transport jflux ! j index of cell contributing transport integer (kind=int_kind), dimension (ngroups), intent(out) :: & icells ! number of cells where triarea > puny integer (kind=int_kind), dimension (nx_block*ny_block,ngroups), intent(out) :: & - indxi , & ! compressed index in i-direction + indxi ,&! compressed index in i-direction indxj ! compressed index in j-direction + logical, intent(in) :: & + l_fixed_area ! if true, the area of each departure region is + ! passed in as edgearea + ! if false, edgearea if determined internally + ! and is passed out + real (kind=dbl_kind), dimension(nx_block,ny_block), intent(inout) :: & edgearea ! area of departure region for each edge ! edgearea > 0 for eastward/northward flow @@ -1674,55 +1736,50 @@ subroutine locate_triangles (nx_block, ny_block, & ! local variables integer (kind=int_kind) :: & - i, j, ij, ic , & ! horizontal indices - ib, jb , & ! limits for loops for bugcheck - ng, nv , & ! triangle indices - ishift , jshift , & ! differences between neighbor cells - ishift_tl, jshift_tl , & ! i,j indices of TL cell relative to edge - ishift_bl, jshift_bl , & ! i,j indices of BL cell relative to edge - ishift_tr, jshift_tr , & ! i,j indices of TR cell relative to edge - ishift_br, jshift_br , & ! i,j indices of BR cell relative to edge - ishift_tc, jshift_tc , & ! i,j indices of TC cell relative to edge - ishift_bc, jshift_bc , & ! i,j indices of BC cell relative to edge - is_l, js_l , & ! i,j shifts for TL1, BL2 for area consistency - is_r, js_r , & ! i,j shifts for TR1, BR2 for area consistency - ise_tl, jse_tl , & ! i,j of TL other edge relative to edge - ise_bl, jse_bl , & ! i,j of BL other edge relative to edge - ise_tr, jse_tr , & ! i,j of TR other edge relative to edge - ise_br, jse_br ! i,j of BR other edge relative to edge + i, j, ij, ic ,&! horizontal indices + ib, ie, jb, je ,&! limits for loops over edges + ng, nv ,&! triangle indices + ishift, jshift ,&! differences between neighbor cells + ishift_tl, jshift_tl ,&! i,j indices of TL cell relative to edge + ishift_bl, jshift_bl ,&! i,j indices of BL cell relative to edge + ishift_tr, jshift_tr ,&! i,j indices of TR cell relative to edge + ishift_br, jshift_br ,&! i,j indices of BR cell relative to edge + ishift_tc, jshift_tc ,&! i,j indices of TC cell relative to edge + ishift_bc, jshift_bc ! i,j indices of BC cell relative to edge integer (kind=int_kind) :: & icellsd ! number of cells where departure area > 0. integer (kind=int_kind), dimension (nx_block*ny_block) :: & - indxid , & ! compressed index in i-direction + indxid ,&! compressed index in i-direction indxjd ! compressed index in j-direction real (kind=dbl_kind), dimension(nx_block,ny_block) :: & - dx, dy , & ! scaled departure points - areafac_c , & ! earea or narea - areafac_ce ! areafac_c on other edge (narea or earea) + dx, dy ,&! scaled departure points + areafac_c ,&! area scale factor at center of edge + areafac_l ,&! area scale factor at left corner + areafac_r ! area scale factor at right corner real (kind=dbl_kind) :: & - xcl, ycl , & ! coordinates of left corner point + xcl, ycl ,&! coordinates of left corner point ! (relative to midpoint of edge) - xdl, ydl , & ! left departure point - xil, yil , & ! left intersection point - xcr, ycr , & ! right corner point - xdr, ydr , & ! right departure point - xir, yir , & ! right intersection point - xic, yic , & ! x-axis intersection point - xicl, yicl , & ! left-hand x-axis intersection point - xicr, yicr , & ! right-hand x-axis intersection point - xdm, ydm , & ! midpoint of segment connecting DL and DR; + xdl, ydl ,&! left departure point + xil, yil ,&! left intersection point + xcr, ycr ,&! right corner point + xdr, ydr ,&! right departure point + xir, yir ,&! right intersection point + xic, yic ,&! x-axis intersection point + xicl, yicl ,&! left-hand x-axis intersection point + xicr, yicr ,&! right-hand x-axis intersection point + xdm, ydm ,&! midpoint of segment connecting DL and DR; ! shifted if l_fixed_area = T - md , & ! slope of line connecting DL and DR - mdl , & ! slope of line connecting DL and DM - mdr , & ! slope of line connecting DR and DM - area1, area2 , & ! temporary triangle areas - area3, area4 , & ! - area_c , & ! center polygon area - puny , & ! + md ,&! slope of line connecting DL and DR + mdl ,&! slope of line connecting DL and DM + mdr ,&! slope of line connecting DR and DM + area1, area2 ,&! temporary triangle areas + area3, area4 ,&! + area_c ,&! center polygon area + puny ,&! w1, w2 ! work variables real (kind=dbl_kind), dimension (nx_block,ny_block,ngroups) :: & @@ -1730,70 +1787,70 @@ subroutine locate_triangles (nx_block, ny_block, & real (kind=dbl_kind), dimension(nx_block,ny_block) :: & areasum ! sum of triangle areas for a given edge - + character(len=*), parameter :: subname = '(locate_triangles)' - !------------------------------------------------------------------- - ! Triangle notation: - ! For each edge, there are 20 triangles that can contribute, - ! but many of these are mutually exclusive. It turns out that - ! at most 5 triangles can contribute to transport integrals at once. - ! - ! See Figure 3 in DB for pictures of these triangles. - ! See Table 1 in DB for logical conditions. - ! - ! For the north edge, DB refer to these triangles as: - ! (1) NW, NW1, W, W2 - ! (2) NE, NE1, E, E2 - ! (3) NW2, W1, NE2, E1 - ! (4) H1a, H1b, N1a, N1b - ! (5) H2a, H2b, N2a, N2b - ! - ! For the east edge, DB refer to these triangles as: - ! (1) NE, NE1, N, N2 - ! (2) SE, SE1, S, S2 - ! (3) NE2, N1, SE2, S1 - ! (4) H1a, H1b, E1a, E2b - ! (5) H2a, H2b, E2a, E2b - ! - ! The code below works for either north or east edges. - ! The respective triangle labels are: - ! (1) TL, TL1, BL, BL2 - ! (2) TR, TR1, BR, BR2 - ! (3) TL2, BL1, TR2, BR1 - ! (4) BC1a, BC1b, TC1a, TC2b - ! (5) BC2a, BC2b, TC2a, TC2b - ! - ! where the cell labels are: - ! - ! | | - ! TL | TC | TR (top left, center, right) - ! | | - ! ------------------------ - ! | | - ! BL | BC | BR (bottom left, center, right) - ! | | - ! - ! and the transport is across the edge between cells TC and BC. - ! - ! Departure points are scaled to a local coordinate system - ! whose origin is at the midpoint of the edge. - ! In this coordinate system, the lefthand corner CL = (-0.5,0) - ! and the righthand corner CR = (0.5, 0). - !------------------------------------------------------------------- - - !------------------------------------------------------------------- - ! Initialize - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Triangle notation: + ! For each edge, there are 20 triangles that can contribute, + ! but many of these are mutually exclusive. It turns out that + ! at most 5 triangles can contribute to transport integrals at once. + ! + ! See Figure 3 in DB for pictures of these triangles. + ! See Table 1 in DB for logical conditions. + ! + ! For the north edge, DB refer to these triangles as: + ! (1) NW, NW1, W, W2 + ! (2) NE, NE1, E, E2 + ! (3) NW2, W1, NE2, E1 + ! (4) H1a, H1b, N1a, N1b + ! (5) H2a, H2b, N2a, N2b + ! + ! For the east edge, DB refer to these triangles as: + ! (1) NE, NE1, N, N2 + ! (2) SE, SE1, S, S2 + ! (3) NE2, N1, SE2, S1 + ! (4) H1a, H1b, E1a, E2b + ! (5) H2a, H2b, E2a, E2b + ! + ! The code below works for either north or east edges. + ! The respective triangle labels are: + ! (1) TL, TL1, BL, BL2 + ! (2) TR, TR1, BR, BR2 + ! (3) TL2, BL1, TR2, BR1 + ! (4) BC1a, BC1b, TC1a, TC2b + ! (5) BC2a, BC2b, TC2a, TC2b + ! + ! where the cell labels are: + ! + ! | | + ! TL | TC | TR (top left, center, right) + ! | | + ! ------------------------ + ! | | + ! BL | BC | BR (bottom left, center, right) + ! | | + ! + ! and the transport is across the edge between cells TC and TB. + ! + ! Departure points are scaled to a local coordinate system + ! whose origin is at the midpoint of the edge. + ! In this coordinate system, the lefthand corner CL = (-0.5,0) + ! and the righthand corner CR = (0.5, 0). + !------------------------------------------------------------------- + + !------------------------------------------------------------------- + ! Initialize + !------------------------------------------------------------------- call icepack_query_parameters(puny_out=puny) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=__FILE__, line=__LINE__) - areafac_c(:,:) = c0 - areafac_ce(:,:) = c0 - + areafac_c(:,:) = c0 + areafac_l(:,:) = c0 + areafac_r(:,:) = c0 do ng = 1, ngroups do j = 1, ny_block do i = 1, nx_block @@ -1815,6 +1872,13 @@ subroutine locate_triangles (nx_block, ny_block, & if (trim(edge) == 'north') then + ! loop size + + ib = ilo + ie = ihi + jb = jlo - nghost ! lowest j index is a ghost cell + je = jhi + ! index shifts for neighbor cells ishift_tl = -1 @@ -1830,42 +1894,24 @@ subroutine locate_triangles (nx_block, ny_block, & ishift_bc = 0 jshift_bc = 0 - ! index shifts for TL1, BL2, TR1 and BR2 for area consistency - - is_l = -1 - js_l = 0 - is_r = 1 - js_r = 0 - - ! index shifts for neighbor east edges - - ise_tl = -1 - jse_tl = 1 - ise_bl = -1 - jse_bl = 0 - ise_tr = 0 - jse_tr = 1 - ise_br = 0 - jse_br = 0 - ! area scale factor - ! earea, narea valid on halo - do j = 1, ny_block - do i = 1, nx_block - areafac_c(i,j) = narea(i,j) + do j = jb, je + do i = ib, ie + areafac_l(i,j) = dxu(i-1,j)*dyu(i-1,j) + areafac_r(i,j) = dxu(i,j)*dyu(i,j) + areafac_c(i,j) = p5*(areafac_l(i,j) + areafac_r(i,j)) enddo enddo - ! area scale factor for other edge (east) + else ! east edge - do j = 1, ny_block - do i = 1, nx_block - areafac_ce(i,j) = earea(i,j) - enddo - enddo + ! loop size - else ! east edge + ib = ilo - nghost ! lowest i index is a ghost cell + ie = ihi + jb = jlo + je = jhi ! index shifts for neighbor cells @@ -1882,112 +1928,87 @@ subroutine locate_triangles (nx_block, ny_block, & ishift_bc = 0 jshift_bc = 0 - ! index shifts for TL1, BL2, TR1 and BR2 for area consistency - - is_l = 0 - js_l = 1 - is_r = 0 - js_r = -1 - - ! index shifts for neighbor north edges - - ise_tl = 1 - jse_tl = 0 - ise_bl = 0 - jse_bl = 0 - ise_tr = 1 - jse_tr = -1 - ise_br = 0 - jse_br = -1 - ! area scale factors - ! earea, narea valid on halo - - do j = 1, ny_block - do i = 1, nx_block - areafac_c(i,j) = earea(i,j) - enddo - enddo - ! area scale factor for other edge (north) - - do j = 1, ny_block - do i = 1, nx_block - areafac_ce(i,j) = narea(i,j) + do j = jb, je + do i = ib, ie + areafac_l(i,j) = dxu(i,j)*dyu(i,j) + areafac_r(i,j) = dxu(i,j-1)*dyu(i,j-1) + areafac_c(i,j) = p5 * (areafac_l(i,j) + areafac_r(i,j)) enddo enddo endif - !------------------------------------------------------------------- - ! Compute mask for edges with nonzero departure areas and for - ! one grid-cell wide channels - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Compute mask for edges with nonzero departure areas + !------------------------------------------------------------------- - icellsd = 0 - if (trim(edge) == 'north') then - do j = jlo-1, jhi - do i = ilo, ihi - if (dpx(i-1,j)/=c0 .or. dpy(i-1,j)/=c0 & - .or. & - dpx(i,j)/=c0 .or. dpy(i,j)/=c0) then + if (l_fixed_area) then + icellsd = 0 + do j = jb, je + do i = ib, ie + if (edgearea(i,j) /= c0) then icellsd = icellsd + 1 indxid(icellsd) = i indxjd(icellsd) = j - else - if ( abs(edgearea(i,j)) > c0 ) then ! 1 grid-cell wide channel: dpx,y = 0, edgearea /= 0 + endif + enddo + enddo + else + icellsd = 0 + if (trim(edge) == 'north') then + do j = jb, je + do i = ib, ie + if (dpx(i-1,j)/=c0 .or. dpy(i-1,j)/=c0 & + .or. & + dpx(i,j)/=c0 .or. dpy(i,j)/=c0) then icellsd = icellsd + 1 indxid(icellsd) = i indxjd(icellsd) = j endif - endif - enddo - enddo - else ! east edge - do j = jlo, jhi - do i = ilo-1, ihi - if (dpx(i,j-1)/=c0 .or. dpy(i,j-1)/=c0 & - .or. & - dpx(i,j)/=c0 .or. dpy(i,j)/=c0) then - icellsd = icellsd + 1 - indxid(icellsd) = i - indxjd(icellsd) = j - else - if ( abs(edgearea(i,j)) > c0 ) then ! 1 grid-cell wide channel: dpx,y = 0, edgearea /= 0 + enddo + enddo + else ! east edge + do j = jb, je + do i = ib, ie + if (dpx(i,j-1)/=c0 .or. dpy(i,j-1)/=c0 & + .or. & + dpx(i,j)/=c0 .or. dpy(i,j)/=c0) then icellsd = icellsd + 1 indxid(icellsd) = i indxjd(icellsd) = j endif - endif - enddo - enddo - endif ! edge = north/east + enddo + enddo + endif ! edge = north/east + endif ! l_fixed_area - !------------------------------------------------------------------- - ! Scale the departure points - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Scale the departure points + !------------------------------------------------------------------- - do j = 1, jhi - do i = 1, ihi + do j = 1, je + do i = 1, ie dx(i,j) = dpx(i,j) / dxu(i,j) dy(i,j) = dpy(i,j) / dyu(i,j) enddo enddo - !------------------------------------------------------------------- - ! Compute departure regions, divide into triangles, and locate - ! vertices of each triangle. - ! Work in a nondimensional coordinate system in which lengths are - ! scaled by the local metric coefficients (dxu and dyu). - ! Note: The do loop includes north faces of the j = 1 ghost cells - ! when edge = 'north'. The loop includes east faces of i = 1 - ! ghost cells when edge = 'east'. - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Compute departure regions, divide into triangles, and locate + ! vertices of each triangle. + ! Work in a nondimensional coordinate system in which lengths are + ! scaled by the local metric coefficients (dxu and dyu). + ! Note: The do loop includes north faces of the j = 1 ghost cells + ! when edge = 'north'. The loop includes east faces of i = 1 + ! ghost cells when edge = 'east'. + !------------------------------------------------------------------- do ij = 1, icellsd i = indxid(ij) j = indxjd(ij) - + xcl = -p5 ycl = c0 @@ -1997,15 +2018,15 @@ subroutine locate_triangles (nx_block, ny_block, & ! Departure points if (trim(edge) == 'north') then ! north edge - xdl = xcl + dx(i-1,j ) - ydl = ycl + dy(i-1,j ) - xdr = xcr + dx(i ,j ) - ydr = ycr + dy(i ,j ) + xdl = xcl + dx(i-1,j) + ydl = ycl + dy(i-1,j) + xdr = xcr + dx(i,j) + ydr = ycr + dy(i,j) else ! east edge; rotate trajectory by pi/2 - xdl = xcl - dy(i ,j ) - ydl = ycl + dx(i ,j ) - xdr = xcr - dy(i ,j-1) - ydr = ycr + dx(i ,j-1) + xdl = xcl - dy(i,j) + ydl = ycl + dx(i,j) + xdr = xcr - dy(i,j-1) + ydr = ycr + dx(i,j-1) endif xdm = p5 * (xdr + xdl) @@ -2015,12 +2036,12 @@ subroutine locate_triangles (nx_block, ny_block, & xil = xcl yil = (xcl*(ydm-ydl) + xdm*ydl - xdl*ydm) / (xdm - xdl) - + xir = xcr - yir = (xcr*(ydr-ydm) - xdm*ydr + xdr*ydm) / (xdr - xdm) - + yir = (xcr*(ydr-ydm) - xdm*ydr + xdr*ydm) / (xdr - xdm) + md = (ydr - ydl) / (xdr - xdl) - + if (abs(md) > puny) then xic = xdl - ydl/md else @@ -2033,21 +2054,14 @@ subroutine locate_triangles (nx_block, ny_block, & xicr = xic yicr = yic - !------------------------------------------------------------------- - ! Locate triangles in TL cell (NW for north edge, NE for east edge) - ! and BL cell (W for north edge, N for east edge). - ! - ! areafact_c or areafac_ce (areafact_c for the other edge) are used - ! (with shifted indices) to make sure that a flux area on one edge - ! is consistent with the analogous area on the other edge and to - ! ensure that areas add up when using l_fixed_area = T. See PR #849 - ! for details. - ! - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Locate triangles in TL cell (NW for north edge, NE for east edge) + ! and BL cell (W for north edge, N for east edge). + !------------------------------------------------------------------- if (yil > c0 .and. xdl < xcl .and. ydl >= c0) then - ! TL (group 1) + ! TL (group 1) ng = 1 xp (i,j,1,ng) = xcl @@ -2058,11 +2072,11 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = ydl iflux (i,j,ng) = i + ishift_tl jflux (i,j,ng) = j + jshift_tl - areafact(i,j,ng) = -areafac_ce(i+ise_tl,j+jse_tl) + areafact(i,j,ng) = -areafac_l(i,j) elseif (yil < c0 .and. xdl < xcl .and. ydl < c0) then - ! BL (group 1) + ! BL (group 1) ng = 1 xp (i,j,1,ng) = xcl @@ -2073,11 +2087,11 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = yil iflux (i,j,ng) = i + ishift_bl jflux (i,j,ng) = j + jshift_bl - areafact(i,j,ng) = areafac_ce(i+ise_bl,j+jse_bl) + areafact(i,j,ng) = areafac_l(i,j) elseif (yil < c0 .and. xdl < xcl .and. ydl >= c0) then - ! TL1 (group 1) + ! TL1 (group 1) ng = 1 xp (i,j,1,ng) = xcl @@ -2088,9 +2102,9 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = yic iflux (i,j,ng) = i + ishift_tl jflux (i,j,ng) = j + jshift_tl - areafact(i,j,ng) = areafac_c(i+is_l,j+js_l) + areafact(i,j,ng) = areafac_l(i,j) - ! BL1 (group 3) + ! BL1 (group 3) ng = 3 xp (i,j,1,ng) = xcl @@ -2101,11 +2115,11 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = yil iflux (i,j,ng) = i + ishift_bl jflux (i,j,ng) = j + jshift_bl - areafact(i,j,ng) = areafac_ce(i+ise_bl,j+jse_bl) + areafact(i,j,ng) = areafac_l(i,j) elseif (yil > c0 .and. xdl < xcl .and. ydl < c0) then - ! TL2 (group 3) + ! TL2 (group 3) ng = 3 xp (i,j,1,ng) = xcl @@ -2116,9 +2130,9 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = yic iflux (i,j,ng) = i + ishift_tl jflux (i,j,ng) = j + jshift_tl - areafact(i,j,ng) = -areafac_ce(i+ise_tl,j+jse_tl) + areafact(i,j,ng) = -areafac_l(i,j) - ! BL2 (group 1) + ! BL2 (group 1) ng = 1 xp (i,j,1,ng) = xcl @@ -2129,18 +2143,18 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = ydl iflux (i,j,ng) = i + ishift_bl jflux (i,j,ng) = j + jshift_bl - areafact(i,j,ng) = -areafac_c(i+is_l,j+js_l) + areafact(i,j,ng) = -areafac_l(i,j) endif ! TL and BL triangles - !------------------------------------------------------------------- - ! Locate triangles in TR cell (NE for north edge, SE for east edge) - ! and in BR cell (E for north edge, S for east edge). - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Locate triangles in TR cell (NE for north edge, SE for east edge) + ! and in BR cell (E for north edge, S for east edge). + !------------------------------------------------------------------- if (yir > c0 .and. xdr >= xcr .and. ydr >= c0) then - ! TR (group 2) + ! TR (group 2) ng = 2 xp (i,j,1,ng) = xcr @@ -2151,11 +2165,11 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = yir iflux (i,j,ng) = i + ishift_tr jflux (i,j,ng) = j + jshift_tr - areafact(i,j,ng) = -areafac_ce(i+ise_tr,j+jse_tr) + areafact(i,j,ng) = -areafac_r(i,j) elseif (yir < c0 .and. xdr >= xcr .and. ydr < c0) then - ! BR (group 2) + ! BR (group 2) ng = 2 xp (i,j,1,ng) = xcr @@ -2166,11 +2180,11 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = ydr iflux (i,j,ng) = i + ishift_br jflux (i,j,ng) = j + jshift_br - areafact(i,j,ng) = areafac_ce(i+ise_br,j+jse_br) + areafact(i,j,ng) = areafac_r(i,j) - elseif (yir < c0 .and. xdr >= xcr .and. ydr >= c0) then + elseif (yir < c0 .and. xdr >= xcr .and. ydr >= c0) then - ! TR1 (group 2) + ! TR1 (group 2) ng = 2 xp (i,j,1,ng) = xcr @@ -2181,9 +2195,9 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = ydr iflux (i,j,ng) = i + ishift_tr jflux (i,j,ng) = j + jshift_tr - areafact(i,j,ng) = areafac_c(i+is_r,j+js_r) + areafact(i,j,ng) = areafac_r(i,j) - ! BR1 (group 3) + ! BR1 (group 3) ng = 3 xp (i,j,1,ng) = xcr @@ -2194,11 +2208,11 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = yic iflux (i,j,ng) = i + ishift_br jflux (i,j,ng) = j + jshift_br - areafact(i,j,ng) = areafac_ce(i+ise_br,j+jse_br) + areafact(i,j,ng) = areafac_r(i,j) - elseif (yir > c0 .and. xdr >= xcr .and. ydr < c0) then + elseif (yir > c0 .and. xdr >= xcr .and. ydr < c0) then - ! TR2 (group 3) + ! TR2 (group 3) ng = 3 xp (i,j,1,ng) = xcr @@ -2209,11 +2223,11 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = yir iflux (i,j,ng) = i + ishift_tr jflux (i,j,ng) = j + jshift_tr - areafact(i,j,ng) = -areafac_ce(i+ise_tr,j+jse_tr) + areafact(i,j,ng) = -areafac_r(i,j) - ! BR2 (group 2) + ! BR2 (group 2) - ng = 2 + ng = 2 xp (i,j,1,ng) = xcr yp (i,j,1,ng) = ycr xp (i,j,2,ng) = xdr @@ -2222,13 +2236,13 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = yic iflux (i,j,ng) = i + ishift_br jflux (i,j,ng) = j + jshift_br - areafact(i,j,ng) = -areafac_c(i+is_r,j+js_r) + areafact(i,j,ng) = -areafac_r(i,j) endif ! TR and BR triangles - !------------------------------------------------------------------- - ! Redefine departure points if not located in central cells (TC or BC) - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Redefine departure points if not located in central cells (TC or BC) + !------------------------------------------------------------------- if (xdl < xcl) then xdl = xil @@ -2240,10 +2254,10 @@ subroutine locate_triangles (nx_block, ny_block, & ydr = yir endif - !------------------------------------------------------------------- - ! For l_fixed_area = T, shift the midpoint so that the departure - ! region has the prescribed area - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! For l_fixed_area = T, shift the midpoint so that the departure + ! region has the prescribed area + !------------------------------------------------------------------- if (l_fixed_area) then @@ -2256,21 +2270,21 @@ subroutine locate_triangles (nx_block, ny_block, & yp(i,j,3,ng) & - yp(i,j,2,ng) * & (xp(i,j,3,ng)-xp(i,j,1,ng)) ) & - * areafact(i,j,ng) + * areafact(i,j,ng) ng = 2 area2 = p5 * ( (xp(i,j,2,ng)-xp(i,j,1,ng)) * & yp(i,j,3,ng) & - yp(i,j,2,ng) * & (xp(i,j,3,ng)-xp(i,j,1,ng)) ) & - * areafact(i,j,ng) + * areafact(i,j,ng) ng = 3 area3 = p5 * ( (xp(i,j,2,ng)-xp(i,j,1,ng)) * & yp(i,j,3,ng) & - yp(i,j,2,ng) * & (xp(i,j,3,ng)-xp(i,j,1,ng)) ) & - * areafact(i,j,ng) + * areafact(i,j,ng) !----------------------------------------------------------- ! Check whether the central triangles lie in one grid cell or two. @@ -2278,7 +2292,9 @@ subroutine locate_triangles (nx_block, ny_block, & ! region so that the sum of all triangle areas is equal to the ! prescribed value. ! If two triangles are in one grid cell and one is in the other, - ! then compute the area of the lone triangle. Then adjust + ! then compute the area of the lone triangle using an area factor + ! corresponding to the adjacent corner. This is necessary to prevent + ! negative masses in some rare cases on curved grids. Then adjust ! the area of the remaining two-triangle region so that the sum of ! all triangle areas has the prescribed value. !----------------------------------------------------------- @@ -2314,7 +2330,7 @@ subroutine locate_triangles (nx_block, ny_block, & endif yicr = c0 - elseif (xic < c0 .and. xic > xcl) then ! fix ICL = IC + elseif (xic < c0) then ! fix ICL = IC xicl = xic yicl = yic @@ -2323,8 +2339,8 @@ subroutine locate_triangles (nx_block, ny_block, & xdm = p5 * (xdr + xicl) ydm = p5 * ydr - ! compute area of (lone) triangle adjacent to left corner - area4 = p5 * (xcl - xic) * ydl * areafac_c(i,j) + ! compute area of triangle adjacent to left corner + area4 = p5 * (xcl - xic) * ydl * areafac_l(i,j) area_c = edgearea(i,j) - area1 - area2 - area3 - area4 ! shift midpoint so that area of remaining triangles = area_c @@ -2343,17 +2359,16 @@ subroutine locate_triangles (nx_block, ny_block, & endif yicr = c0 - elseif (xic >= c0 .and. xic < xcr) then ! fix ICR = IR + elseif (xic >= c0) then ! fix ICR = IR xicr = xic yicr = yic - ! compute midpoint between ICR and DL + ! compute midpoint between ICR and DL xdm = p5 * (xicr + xdl) ydm = p5 * ydl - ! compute area of (lone) triangle adjacent to right corner - area4 = p5 * (xic - xcr) * ydr * areafac_c(i,j) + area4 = p5 * (xic - xcr) * ydr * areafac_r(i,j) area_c = edgearea(i,j) - area1 - area2 - area3 - area4 ! shift midpoint so that area of remaining triangles = area_c @@ -2377,16 +2392,16 @@ subroutine locate_triangles (nx_block, ny_block, & endif ! l_fixed_area - !------------------------------------------------------------------- - ! Locate triangles in BC cell (H for both north and east edges) - ! and TC cell (N for north edge and E for east edge). - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Locate triangles in BC cell (H for both north and east edges) + ! and TC cell (N for north edge and E for east edge). + !------------------------------------------------------------------- - ! Start with cases where both DPs lie in the same grid cell + ! Start with cases where both DPs lie in the same grid cell if (ydl >= c0 .and. ydr >= c0 .and. ydm >= c0) then - ! TC1a (group 4) + ! TC1a (group 4) ng = 4 xp (i,j,1,ng) = xcl @@ -2399,7 +2414,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_tc areafact(i,j,ng) = -areafac_c(i,j) - ! TC2a (group 5) + ! TC2a (group 5) ng = 5 xp (i,j,1,ng) = xcr @@ -2412,8 +2427,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_tc areafact(i,j,ng) = -areafac_c(i,j) - ! TC3a (group 6) - + ! TC3a (group 6) ng = 6 xp (i,j,1,ng) = xdl yp (i,j,1,ng) = ydl @@ -2427,7 +2441,7 @@ subroutine locate_triangles (nx_block, ny_block, & elseif (ydl >= c0 .and. ydr >= c0 .and. ydm < c0) then ! rare - ! TC1b (group 4) + ! TC1b (group 4) ng = 4 xp (i,j,1,ng) = xcl @@ -2440,7 +2454,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_tc areafact(i,j,ng) = -areafac_c(i,j) - ! TC2b (group 5) + ! TC2b (group 5) ng = 5 xp (i,j,1,ng) = xcr @@ -2453,7 +2467,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_tc areafact(i,j,ng) = -areafac_c(i,j) - ! BC3b (group 6) + ! BC3b (group 6) ng = 6 xp (i,j,1,ng) = xicr @@ -2466,9 +2480,9 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - elseif (ydl <= c0 .and. ydr <= c0 .and. ydm <= c0) then + elseif (ydl < c0 .and. ydr < c0 .and. ydm < c0) then - ! BC1a (group 4) + ! BC1a (group 4) ng = 4 xp (i,j,1,ng) = xcl @@ -2481,7 +2495,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - ! BC2a (group 5) + ! BC2a (group 5) ng = 5 xp (i,j,1,ng) = xcr @@ -2494,7 +2508,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - ! BC3a (group 6) + ! BC3a (group 6) ng = 6 xp (i,j,1,ng) = xdl @@ -2507,9 +2521,9 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - elseif (ydl <= c0 .and. ydr <= c0 .and. ydm > c0) then ! rare + elseif (ydl < c0 .and. ydr < c0 .and. ydm >= c0) then ! rare - ! BC1b (group 4) + ! BC1b (group 4) ng = 4 xp (i,j,1,ng) = xcl @@ -2522,7 +2536,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - ! BC2b (group 5) + ! BC2b (group 5) ng = 5 xp (i,j,1,ng) = xcr @@ -2535,7 +2549,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - ! TC3b (group 6) + ! TC3b (group 6) ng = 6 xp (i,j,1,ng) = xicl @@ -2548,12 +2562,14 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_tc areafact(i,j,ng) = -areafac_c(i,j) - ! Now consider cases where the two DPs lie in different grid cells + ! Now consider cases where the two DPs lie in different grid cells + ! For these cases, one triangle is given the area factor associated + ! with the adjacent corner, to avoid rare negative masses on curved grids. - elseif (ydl > c0 .and. ydr < c0 .and. xic >= c0 & - .and. ydm >= c0) then + elseif (ydl >= c0 .and. ydr < c0 .and. xic >= c0 & + .and. ydm >= c0) then - ! TC1b (group 4) + ! TC1b (group 4) ng = 4 xp (i,j,1,ng) = xcl @@ -2566,7 +2582,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_tc areafact(i,j,ng) = -areafac_c(i,j) - ! BC2b (group 5) lone triangle + ! BC2b (group 5) ng = 5 xp (i,j,1,ng) = xcr @@ -2577,9 +2593,9 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = ydr iflux (i,j,ng) = i + ishift_bc jflux (i,j,ng) = j + jshift_bc - areafact(i,j,ng) = areafac_c(i,j) + areafact(i,j,ng) = areafac_r(i,j) - ! TC3b (group 6) + ! TC3b (group 6) ng = 6 xp (i,j,1,ng) = xdl @@ -2592,10 +2608,10 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_tc areafact(i,j,ng) = -areafac_c(i,j) - elseif (ydl > c0 .and. ydr < c0 .and. xic >= c0 & - .and. ydm < c0 ) then ! less common + elseif (ydl >= c0 .and. ydr < c0 .and. xic >= c0 & + .and. ydm < c0 ) then ! less common - ! TC1b (group 4) + ! TC1b (group 4) ng = 4 xp (i,j,1,ng) = xcl @@ -2608,7 +2624,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_tc areafact(i,j,ng) = -areafac_c(i,j) - ! BC2b (group 5) lone triangle + ! BC2b (group 5) ng = 5 xp (i,j,1,ng) = xcr @@ -2619,9 +2635,9 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = ydr iflux (i,j,ng) = i + ishift_bc jflux (i,j,ng) = j + jshift_bc - areafact(i,j,ng) = areafac_c(i,j) + areafact(i,j,ng) = areafac_r(i,j) - ! BC3b (group 6) + ! BC3b (group 6) ng = 6 xp (i,j,1,ng) = xicr @@ -2634,10 +2650,10 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - elseif (ydl > c0 .and. ydr < c0 .and. xic < c0 & - .and. ydm < c0) then + elseif (ydl >= c0 .and. ydr < c0 .and. xic < c0 & + .and. ydm < c0) then - ! TC1b (group 4) lone triangle + ! TC1b (group 4) ng = 4 xp (i,j,1,ng) = xcl @@ -2648,9 +2664,9 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = ydl iflux (i,j,ng) = i + ishift_tc jflux (i,j,ng) = j + jshift_tc - areafact(i,j,ng) = -areafac_c(i,j) + areafact(i,j,ng) = -areafac_l(i,j) - ! BC2b (group 5) + ! BC2b (group 5) ng = 5 xp (i,j,1,ng) = xcr @@ -2663,7 +2679,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - ! BC3b (group 6) + ! BC3b (group 6) ng = 6 xp (i,j,1,ng) = xdr @@ -2676,10 +2692,10 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - elseif (ydl > c0 .and. ydr < c0 .and. xic < c0 & - .and. ydm >= c0) then ! less common + elseif (ydl >= c0 .and. ydr < c0 .and. xic < c0 & + .and. ydm >= c0) then ! less common - ! TC1b (group 4) lone triangle + ! TC1b (group 4) ng = 4 xp (i,j,1,ng) = xcl @@ -2690,9 +2706,9 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = ydl iflux (i,j,ng) = i + ishift_tc jflux (i,j,ng) = j + jshift_tc - areafact(i,j,ng) = -areafac_c(i,j) + areafact(i,j,ng) = -areafac_l(i,j) - ! BC2b (group 5) + ! BC2b (group 5) ng = 5 xp (i,j,1,ng) = xcr @@ -2705,7 +2721,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - ! TC3b (group 6) + ! TC3b (group 6) ng = 6 xp (i,j,1,ng) = xicl @@ -2718,10 +2734,10 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_tc areafact(i,j,ng) = -areafac_c(i,j) - elseif (ydl < c0 .and. ydr > c0 .and. xic < c0 & - .and. ydm >= c0) then + elseif (ydl < c0 .and. ydr >= c0 .and. xic < c0 & + .and. ydm >= c0) then - ! BC1b (group 4) lone triangle + ! BC1b (group 4) ng = 4 xp (i,j,1,ng) = xcl @@ -2732,9 +2748,9 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = yicl iflux (i,j,ng) = i + ishift_bc jflux (i,j,ng) = j + jshift_bc - areafact(i,j,ng) = areafac_c(i,j) + areafact(i,j,ng) = areafac_l(i,j) - ! TC2b (group 5) + ! TC2b (group 5) ng = 5 xp (i,j,1,ng) = xcr @@ -2747,7 +2763,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_tc areafact(i,j,ng) = -areafac_c(i,j) - ! TC3b (group 6) + ! TC3b (group 6) ng = 6 xp (i,j,1,ng) = xicl @@ -2760,10 +2776,10 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_tc areafact(i,j,ng) = -areafac_c(i,j) - elseif (ydl < c0 .and. ydr > c0 .and. xic < c0 & - .and. ydm < c0) then ! less common + elseif (ydl < c0 .and. ydr >= c0 .and. xic < c0 & + .and. ydm < c0) then ! less common - ! BC1b (group 4) lone triangle + ! BC1b (group 4) ng = 4 xp (i,j,1,ng) = xcl @@ -2774,9 +2790,9 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = yicl iflux (i,j,ng) = i + ishift_bc jflux (i,j,ng) = j + jshift_bc - areafact(i,j,ng) = areafac_c(i,j) + areafact(i,j,ng) = areafac_l(i,j) - ! TC2b (group 5) + ! TC2b (group 5) ng = 5 xp (i,j,1,ng) = xcr @@ -2789,7 +2805,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_tc areafact(i,j,ng) = -areafac_c(i,j) - ! BC3b (group 6) + ! BC3b (group 6) ng = 6 xp (i,j,1,ng) = xicr @@ -2802,10 +2818,10 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - elseif (ydl < c0 .and. ydr > c0 .and. xic >= c0 & - .and. ydm < c0) then + elseif (ydl < c0 .and. ydr >= c0 .and. xic >= c0 & + .and. ydm < c0) then - ! BC1b (group 4) + ! BC1b (group 4) ng = 4 xp (i,j,1,ng) = xcl @@ -2818,7 +2834,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - ! TC2b (group 5) lone triangle + ! TC2b (group 5) ng = 5 xp (i,j,1,ng) = xcr @@ -2829,9 +2845,9 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = yicr iflux (i,j,ng) = i + ishift_tc jflux (i,j,ng) = j + jshift_tc - areafact(i,j,ng) = -areafac_c(i,j) + areafact(i,j,ng) = -areafac_r(i,j) - ! BC3b (group 6) + ! BC3b (group 6) ng = 6 xp (i,j,1,ng) = xicr @@ -2844,10 +2860,10 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - elseif (ydl < c0 .and. ydr > c0 .and. xic >= c0 & - .and. ydm >= c0) then ! less common + elseif (ydl < c0 .and. ydr >= c0 .and. xic >= c0 & + .and. ydm >= c0) then ! less common - ! BC1b (group 4) + ! BC1b (group 4) ng = 4 xp (i,j,1,ng) = xcl @@ -2860,7 +2876,7 @@ subroutine locate_triangles (nx_block, ny_block, & jflux (i,j,ng) = j + jshift_bc areafact(i,j,ng) = areafac_c(i,j) - ! TC2b (group 5) lone triangle + ! TC2b (group 5) ng = 5 xp (i,j,1,ng) = xcr @@ -2871,9 +2887,9 @@ subroutine locate_triangles (nx_block, ny_block, & yp (i,j,3,ng) = yicr iflux (i,j,ng) = i + ishift_tc jflux (i,j,ng) = j + jshift_tc - areafact(i,j,ng) = -areafac_c(i,j) + areafact(i,j,ng) = -areafac_r(i,j) - ! TC3b (group 6) + ! TC3b (group 6) ng = 6 xp (i,j,1,ng) = xicl @@ -2890,26 +2906,26 @@ subroutine locate_triangles (nx_block, ny_block, & enddo ! ij - !------------------------------------------------------------------- - ! Compute triangle areas with appropriate sign. - ! These are found by computing the area in scaled coordinates and - ! multiplying by a scale factor (areafact). - ! Note that the scale factor is positive for fluxes out of the cell - ! and negative for fluxes into the cell. - ! - ! Note: The triangle area formula below gives A >=0 iff the triangle - ! points x1, x2, and x3 are taken in counterclockwise order. - ! These points are defined above in such a way that the - ! order is nearly always CCW. - ! In rare cases, we may compute A < 0. In this case, - ! the quadrilateral departure area is equal to the - ! difference of two triangle areas instead of the sum. - ! The fluxes work out correctly in the end. - ! - ! Also compute the cumulative area transported across each edge. - ! If l_fixed_area = T, this area is compared to edgearea as a bug check. - ! If l_fixed_area = F, this area is passed as an output array. - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Compute triangle areas with appropriate sign. + ! These are found by computing the area in scaled coordinates and + ! multiplying by a scale factor (areafact). + ! Note that the scale factor is positive for fluxes out of the cell + ! and negative for fluxes into the cell. + ! + ! Note: The triangle area formula below gives A >=0 iff the triangle + ! points x1, x2, and x3 are taken in counterclockwise order. + ! These points are defined above in such a way that the + ! order is nearly always CCW. + ! In rare cases, we may compute A < 0. In this case, + ! the quadrilateral departure area is equal to the + ! difference of two triangle areas instead of the sum. + ! The fluxes work out correctly in the end. + ! + ! Also compute the cumulative area transported across each edge. + ! If l_fixed_area = T, this area is compared to edgearea as a bug check. + ! If l_fixed_area = F, this area is passed as an output array. + !------------------------------------------------------------------- areasum(:,:) = c0 @@ -2924,12 +2940,12 @@ subroutine locate_triangles (nx_block, ny_block, & (yp(i,j,3,ng)-yp(i,j,1,ng)) & - (yp(i,j,2,ng)-yp(i,j,1,ng)) * & (xp(i,j,3,ng)-xp(i,j,1,ng)) ) & - * areafact(i,j,ng) + * areafact(i,j,ng) if (abs(triarea(i,j,ng)) < eps16*areafac_c(i,j)) then triarea(i,j,ng) = c0 else - icells(ng) = icells(ng) + 1 + icells(ng) = icells(ng) + 1 ic = icells(ng) indxi(ic,ng) = i indxj(ic,ng) = j @@ -2941,27 +2957,27 @@ subroutine locate_triangles (nx_block, ny_block, & enddo ! ng if (l_fixed_area) then - if (bugcheck) then ! set bugcheck = F to speed up code - do ij = 1, icellsd - i = indxid(ij) - j = indxjd(ij) - if ( abs(areasum(i,j) - edgearea(i,j)) > eps13*areafac_c(i,j) .and. abs(edgearea(i,j)) > c0 ) then - write(nu_diag,*) '' - write(nu_diag,*) 'Areas do not add up: m, i, j, edge =', & - my_task, i, j, trim(edge) - write(nu_diag,*) 'edgearea =', edgearea(i,j) - write(nu_diag,*) 'areasum =', areasum(i,j) - write(nu_diag,*) 'areafac_c =', areafac_c(i,j) - write(nu_diag,*) '' - write(nu_diag,*) 'Triangle areas:' - do ng = 1, ngroups ! not vector friendly - if (abs(triarea(i,j,ng)) > eps16*abs(areafact(i,j,ng))) then - write(nu_diag,*) ng, triarea(i,j,ng) - endif - enddo - endif - enddo - endif ! bugcheck + if (bugcheck) then ! set bugcheck = F to speed up code + do ij = 1, icellsd + i = indxid(ij) + j = indxjd(ij) + if (abs(areasum(i,j) - edgearea(i,j)) > eps13*areafac_c(i,j)) then + write(nu_diag,*) '' + write(nu_diag,*) 'Areas do not add up: m, i, j, edge =', & + my_task, i, j, trim(edge) + write(nu_diag,*) 'edgearea =', edgearea(i,j) + write(nu_diag,*) 'areasum =', areasum(i,j) + write(nu_diag,*) 'areafac_c =', areafac_c(i,j) + write(nu_diag,*) '' + write(nu_diag,*) 'Triangle areas:' + do ng = 1, ngroups ! not vector friendly + if (abs(triarea(i,j,ng)) > eps16*abs(areafact(i,j,ng))) then + write(nu_diag,*) ng, triarea(i,j,ng) + endif + enddo + endif + enddo + endif ! bugcheck else ! l_fixed_area = F do ij = 1, icellsd @@ -2971,10 +2987,10 @@ subroutine locate_triangles (nx_block, ny_block, & enddo endif ! l_fixed_area - !------------------------------------------------------------------- - ! Transform triangle vertices to a scaled coordinate system centered - ! in the cell containing the triangle. - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Transform triangle vertices to a scaled coordinate system centered + ! in the cell containing the triangle. + !------------------------------------------------------------------- if (trim(edge) == 'north') then do ng = 1, ngroups @@ -3007,22 +3023,19 @@ subroutine locate_triangles (nx_block, ny_block, & endif if (bugcheck) then - if (trim(edge) == 'north') then - ib = ilo - jb = jlo-1 - else ! east edge - ib = ilo-1 - jb = jlo - endif do ng = 1, ngroups do nv = 1, nvert - do j = jb, jhi - do i = ib, ihi + do j = jb, je + do i = ib, ie if (abs(triarea(i,j,ng)) > puny) then if (abs(xp(i,j,nv,ng)) > p5+puny) then write(nu_diag,*) '' write(nu_diag,*) 'WARNING: xp =', xp(i,j,nv,ng) write(nu_diag,*) 'm, i, j, ng, nv =', my_task, i, j, ng, nv +! write(nu_diag,*) 'yil,xdl,xcl,ydl=',yil,xdl,xcl,ydl +! write(nu_diag,*) 'yir,xdr,xcr,ydr=',yir,xdr,xcr,ydr +! write(nu_diag,*) 'ydm=',ydm +! stop endif if (abs(yp(i,j,nv,ng)) > p5+puny) then write(nu_diag,*) '' @@ -3044,10 +3057,10 @@ end subroutine locate_triangles ! to compute integrals of linear, quadratic, or cubic polynomials, ! using formulas from A.H. Stroud, Approximate Calculation of Multiple ! Integrals, Prentice-Hall, 1971. (Section 8.8, formula 3.1.) -! Linear functions can be integrated exactly by evaluating the function +! Linear functions can be integrated exactly by evaluating the function ! at just one point (the midpoint). Quadratic functions require ! 3 points, and cubics require 4 points. -! The default is cubic, but the code can be sped up slightly using +! The default is cubic, but the code can be sped up slightly using ! linear or quadratic integrals, usually with little loss of accuracy. ! ! The formulas are as follows: @@ -3073,24 +3086,24 @@ subroutine triangle_coordinates (nx_block, ny_block, & xp, yp) integer (kind=int_kind), intent(in) :: & - nx_block, ny_block, & ! block dimensions - integral_order ! polynomial order for quadrature integrals + nx_block, ny_block,&! block dimensions + integral_order ! polynomial order for quadrature integrals integer (kind=int_kind), dimension (ngroups), intent(in) :: & - icells ! number of cells where triarea > puny + icells ! number of cells where triarea > puny integer (kind=int_kind), dimension (nx_block*ny_block,ngroups), intent(in) :: & - indxi , & ! compressed index in i-direction - indxj ! compressed index in j-direction + indxi ,&! compressed index in i-direction + indxj ! compressed index in j-direction real (kind=dbl_kind), intent(inout), dimension (nx_block, ny_block, 0:nvert, ngroups) :: & - xp, yp ! coordinates of triangle points + xp, yp ! coordinates of triangle points ! local variables integer (kind=int_kind) :: & - i, j, ij , & ! horizontal indices - ng ! triangle index + i, j, ij ,&! horizontal indices + ng ! triangle index character(len=*), parameter :: subname = '(triangle_coordinates)' @@ -3157,10 +3170,10 @@ subroutine triangle_coordinates (nx_block, ny_block, & xp(i,j,2,ng) = p4*xp(i,j,2,ng) + p6*xp(i,j,0,ng) yp(i,j,2,ng) = p4*yp(i,j,2,ng) + p6*yp(i,j,0,ng) - + xp(i,j,3,ng) = p4*xp(i,j,3,ng) + p6*xp(i,j,0,ng) yp(i,j,3,ng) = p4*yp(i,j,3,ng) + p6*yp(i,j,0,ng) - + enddo ! ij enddo ! ng @@ -3191,69 +3204,69 @@ subroutine transport_integrals (nx_block, ny_block, & ty, mtflx) integer (kind=int_kind), intent(in) :: & - nx_block, ny_block , & ! block dimensions - ntrace , & ! number of tracers in use - integral_order ! polynomial order for quadrature integrals + nx_block, ny_block ,&! block dimensions + ntrace ,&! number of tracers in use + integral_order ! polynomial order for quadrature integrals integer (kind=int_kind), dimension (ntrace), intent(in) :: & - tracer_type , & ! = 1, 2, or 3 (see comments above) - depend ! tracer dependencies (see above) + tracer_type ,&! = 1, 2, or 3 (see comments above) + depend ! tracer dependencies (see above) integer (kind=int_kind), dimension (ngroups), intent(in) :: & - icells ! number of cells where triarea > puny + icells ! number of cells where triarea > puny integer (kind=int_kind), dimension (nx_block*ny_block,ngroups), intent(in) :: & - indxi , & ! compressed index in i-direction - indxj ! compressed index in j-direction + indxi ,&! compressed index in i-direction + indxj ! compressed index in j-direction real (kind=dbl_kind), intent(in), dimension (nx_block, ny_block, 0:nvert, ngroups) :: & - xp, yp ! coordinates of triangle points + xp, yp ! coordinates of triangle points real (kind=dbl_kind), intent(in), dimension (nx_block, ny_block, ngroups) :: & - triarea ! triangle area + triarea ! triangle area integer (kind=int_kind), intent(in), dimension (nx_block, ny_block, ngroups) :: & - iflux ,& - jflux + iflux ,& + jflux real (kind=dbl_kind), intent(in), dimension (nx_block, ny_block) :: & - mc, mx, my + mc, mx, my real (kind=dbl_kind), intent(out), dimension (nx_block, ny_block) :: & - mflx + mflx real (kind=dbl_kind), intent(in), dimension (nx_block, ny_block, ntrace), optional :: & - tc, tx, ty + tc, tx, ty real (kind=dbl_kind), intent(out), dimension (nx_block, ny_block, ntrace), optional :: & - mtflx + mtflx ! local variables integer (kind=int_kind) :: & - i, j, ij , & ! horizontal indices of edge - i2, j2 , & ! horizontal indices of cell contributing transport - ng , & ! triangle index - nt, nt1 ! tracer indices + i, j, ij ,&! horizontal indices of edge + i2, j2 ,&! horizontal indices of cell contributing transport + ng ,&! triangle index + nt, nt1 ! tracer indices real (kind=dbl_kind) :: & - m0, m1, m2, m3 , & ! mass field at internal points - w0, w1, w2, w3 ! work variables + m0, m1, m2, m3 ,&! mass field at internal points + w0, w1, w2, w3 ! work variables real (kind=dbl_kind), dimension (nx_block, ny_block) :: & - msum, mxsum, mysum , & ! sum of mass, mass*x, and mass*y - mxxsum, mxysum, myysum ! sum of mass*x*x, mass*x*y, mass*y*y + msum, mxsum, mysum ,&! sum of mass, mass*x, and mass*y + mxxsum, mxysum, myysum ! sum of mass*x*x, mass*x*y, mass*y*y real (kind=dbl_kind), dimension (nx_block, ny_block, ntrace) :: & - mtsum , & ! sum of mass*tracer - mtxsum , & ! sum of mass*tracer*x - mtysum ! sum of mass*tracer*y + mtsum ,&! sum of mass*tracer + mtxsum ,&! sum of mass*tracer*x + mtysum ! sum of mass*tracer*y character(len=*), parameter :: subname = '(transport_integrals)' - !------------------------------------------------------------------- - ! Initialize - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Initialize + !------------------------------------------------------------------- mflx(:,:) = c0 if (present(mtflx)) then @@ -3262,9 +3275,9 @@ subroutine transport_integrals (nx_block, ny_block, & enddo endif - !------------------------------------------------------------------- - ! Main loop - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Main loop + !------------------------------------------------------------------- do ng = 1, ngroups @@ -3286,11 +3299,11 @@ subroutine transport_integrals (nx_block, ny_block, & mflx(i,j) = mflx(i,j) + triarea(i,j,ng)*msum(i,j) ! quantities needed for tracer transports - mxsum(i,j) = m0*xp(i,j,0,ng) - mxxsum(i,j) = mxsum(i,j)*xp(i,j,0,ng) - mxysum(i,j) = mxsum(i,j)*yp(i,j,0,ng) - mysum(i,j) = m0*yp(i,j,0,ng) - myysum(i,j) = mysum(i,j)*yp(i,j,0,ng) + mxsum(i,j) = m0*xp(i,j,0,ng) + mxxsum(i,j) = mxsum(i,j)*xp(i,j,0,ng) + mxysum(i,j) = mxsum(i,j)*yp(i,j,0,ng) + mysum(i,j) = m0*yp(i,j,0,ng) + myysum(i,j) = mysum(i,j)*yp(i,j,0,ng) enddo ! ij elseif (integral_order == 2) then ! quadratic (3-point formula) @@ -3322,7 +3335,7 @@ subroutine transport_integrals (nx_block, ny_block, & mxsum(i,j) = w1 + w2 + w3 mxxsum(i,j) = w1*xp(i,j,1,ng) + w2*xp(i,j,2,ng) & - + w3*xp(i,j,3,ng) + + w3*xp(i,j,3,ng) mxysum(i,j) = w1*yp(i,j,1,ng) + w2*yp(i,j,2,ng) & + w3*yp(i,j,3,ng) @@ -3482,16 +3495,16 @@ subroutine update_fields (nx_block, ny_block, & tm) integer (kind=int_kind), intent(in) :: & - nx_block, ny_block, & ! block dimensions - ilo,ihi,jlo,jhi , & ! beginning and end of physical domain + nx_block, ny_block,&! block dimensions + ilo,ihi,jlo,jhi ,&! beginning and end of physical domain ntrace ! number of tracers in use integer (kind=int_kind), dimension (ntrace), intent(in) :: & - tracer_type , & ! = 1, 2, or 3 (see comments above) + tracer_type ,&! = 1, 2, or 3 (see comments above) depend ! tracer dependencies (see above) real (kind=dbl_kind), dimension (nx_block, ny_block), intent(in) :: & - mflxe, mflxn , & ! mass transport across east and north cell edges + mflxe, mflxn ,&! mass transport across east and north cell edges tarear ! 1/tarea real (kind=dbl_kind), dimension (nx_block, ny_block), intent(inout) :: & @@ -3507,12 +3520,12 @@ subroutine update_fields (nx_block, ny_block, & l_stop ! if true, abort on return integer (kind=int_kind), intent(inout) :: & - istop, jstop ! indices of grid cell where model aborts + istop, jstop ! indices of grid cell where model aborts ! local variables integer (kind=int_kind) :: & - i, j , & ! horizontal indices + i, j ,&! horizontal indices nt, nt1, nt2 ! tracer indices real (kind=dbl_kind), dimension(nx_block,ny_block,ntrace) :: & @@ -3523,18 +3536,18 @@ subroutine update_fields (nx_block, ny_block, & w1 ! work variable integer (kind=int_kind), dimension(nx_block*ny_block) :: & - indxi , & ! compressed indices in i and j directions + indxi ,&! compressed indices in i and j directions indxj integer (kind=int_kind) :: & - icells , & ! number of cells with mm > 0. + icells ,&! number of cells with mm > 0. ij ! combined i/j horizontal index character(len=*), parameter :: subname = '(update_fields)' - !------------------------------------------------------------------- - ! Save starting values of mass*tracer - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Save starting values of mass*tracer + !------------------------------------------------------------------- call icepack_query_parameters(puny_out=puny) call icepack_warnings_flush(nu_diag) @@ -3569,15 +3582,15 @@ subroutine update_fields (nx_block, ny_block, & enddo ! nt endif ! present(tm) - !------------------------------------------------------------------- - ! Update mass field - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Update mass field + !------------------------------------------------------------------- do j = jlo, jhi do i = ilo, ihi - w1 = mflxe(i,j) - mflxe(i-1,j ) & - + mflxn(i,j) - mflxn(i ,j-1) + w1 = mflxe(i,j) - mflxe(i-1,j) & + + mflxn(i,j) - mflxn(i,j-1) mm(i,j) = mm(i,j) - w1*tarear(i,j) if (mm(i,j) < -puny) then ! abort with negative value @@ -3594,8 +3607,8 @@ subroutine update_fields (nx_block, ny_block, & if (l_stop) then i = istop j = jstop - w1 = mflxe(i,j) - mflxe(i-1,j ) & - + mflxn(i,j) - mflxn(i ,j-1) + w1 = mflxe(i,j) - mflxe(i-1,j) & + + mflxn(i,j) - mflxn(i,j-1) write (nu_diag,*) ' ' write (nu_diag,*) 'New mass < 0, i, j =', i, j write (nu_diag,*) 'Old mass =', mm(i,j) + w1*tarear(i,j) @@ -3604,9 +3617,9 @@ subroutine update_fields (nx_block, ny_block, & return endif - !------------------------------------------------------------------- - ! Update tracers - !------------------------------------------------------------------- + !------------------------------------------------------------------- + ! Update tracers + !------------------------------------------------------------------- if (present(tm)) then @@ -3635,8 +3648,8 @@ subroutine update_fields (nx_block, ny_block, & i = indxi(ij) j = indxj(ij) - w1 = mtflxe(i,j,nt) - mtflxe(i-1,j ,nt) & - + mtflxn(i,j,nt) - mtflxn(i ,j-1,nt) + w1 = mtflxe(i,j,nt) - mtflxe(i-1,j,nt) & + + mtflxn(i,j,nt) - mtflxn(i,j-1,nt) tm(i,j,nt) = (mtold(i,j,nt) - w1*tarear(i,j)) & / mm(i,j) enddo ! ij @@ -3649,8 +3662,8 @@ subroutine update_fields (nx_block, ny_block, & j = indxj(ij) if (abs(tm(i,j,nt1)) > c0) then - w1 = mtflxe(i,j,nt) - mtflxe(i-1,j ,nt) & - + mtflxn(i,j,nt) - mtflxn(i ,j-1,nt) + w1 = mtflxe(i,j,nt) - mtflxe(i-1,j,nt) & + + mtflxn(i,j,nt) - mtflxn(i,j-1,nt) tm(i,j,nt) = (mtold(i,j,nt) - w1*tarear(i,j)) & / (mm(i,j) * tm(i,j,nt1)) endif @@ -3667,8 +3680,8 @@ subroutine update_fields (nx_block, ny_block, & if (abs(tm(i,j,nt1)) > c0 .and. & abs(tm(i,j,nt2)) > c0) then - w1 = mtflxe(i,j,nt) - mtflxe(i-1,j ,nt) & - + mtflxn(i,j,nt) - mtflxn(i ,j-1,nt) + w1 = mtflxe(i,j,nt) - mtflxe(i-1,j,nt) & + + mtflxn(i,j,nt) - mtflxn(i,j-1,nt) tm(i,j,nt) = (mtold(i,j,nt) - w1*tarear(i,j)) & / (mm(i,j) * tm(i,j,nt2) * tm(i,j,nt1)) endif diff --git a/cicecore/cicedyn/infrastructure/ice_domain.F90 b/cicecore/cicedyn/infrastructure/ice_domain.F90 index a2559c30b..61e0f4acf 100644 --- a/cicecore/cicedyn/infrastructure/ice_domain.F90 +++ b/cicecore/cicedyn/infrastructure/ice_domain.F90 @@ -161,24 +161,27 @@ subroutine init_domain_blocks nx_global = -1 ! NXGLOB, i-axis size ny_global = -1 ! NYGLOB, j-axis size - call get_fileunit(nu_nml) if (my_task == master_task) then - open (nu_nml, file=nml_filename, status='old',iostat=nml_error) + write(nu_diag,*) subname,' Reading domain_nml' + + call get_fileunit(nu_nml) + open (nu_nml, file=trim(nml_filename), status='old',iostat=nml_error) if (nml_error /= 0) then - nml_error = -1 - else - nml_error = 1 + call abort_ice(subname//'ERROR: domain_nml open file '// & + trim(nml_filename), & + file=__FILE__, line=__LINE__) endif + + nml_error = 1 do while (nml_error > 0) read(nu_nml, nml=domain_nml,iostat=nml_error) end do - if (nml_error == 0) close(nu_nml) - endif - call release_fileunit(nu_nml) - - call broadcast_scalar(nml_error, master_task) - if (nml_error /= 0) then - call abort_ice(subname//'ERROR: error reading domain_nml') + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: domain_nml reading ', & + file=__FILE__, line=__LINE__) + endif + close(nu_nml) + call release_fileunit(nu_nml) endif call broadcast_scalar(nprocs, master_task) diff --git a/cicecore/cicedynB/general/ice_init.F90 b/cicecore/cicedynB/general/ice_init.F90 index 3d102217a..eacaaa6e3 100644 --- a/cicecore/cicedynB/general/ice_init.F90 +++ b/cicecore/cicedynB/general/ice_init.F90 @@ -549,53 +549,154 @@ subroutine input_data nml_filename = 'ice_in'//trim(inst_suffix) #endif - call get_fileunit(nu_nml) - if (my_task == master_task) then - open (nu_nml, file=nml_filename, status='old',iostat=nml_error) + + call get_fileunit(nu_nml) + open (nu_nml, file=trim(nml_filename), status='old',iostat=nml_error) if (nml_error /= 0) then - nml_error = -1 - else - nml_error = 1 - endif + call abort_ice(subname//'ERROR: open file '// & + trim(nml_filename), & + file=__FILE__, line=__LINE__) + endif + write(nu_diag,*) subname,' Reading setup_nml' + rewind(unit=nu_nml, iostat=nml_error) + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: setup_nml rewind ', & + file=__FILE__, line=__LINE__) + endif + nml_error = 1 do while (nml_error > 0) - print*,'Reading setup_nml' - read(nu_nml, nml=setup_nml,iostat=nml_error) - if (nml_error /= 0) exit - print*,'Reading grid_nml' - read(nu_nml, nml=grid_nml,iostat=nml_error) - if (nml_error /= 0) exit - print*,'Reading tracer_nml' - read(nu_nml, nml=tracer_nml,iostat=nml_error) - if (nml_error /= 0) exit - print*,'Reading thermo_nml' - read(nu_nml, nml=thermo_nml,iostat=nml_error) - if (nml_error /= 0) exit - print*,'Reading dynamics_nml' - read(nu_nml, nml=dynamics_nml,iostat=nml_error) - if (nml_error /= 0) exit - print*,'Reading shortwave_nml' - read(nu_nml, nml=shortwave_nml,iostat=nml_error) - if (nml_error /= 0) exit - print*,'Reading ponds_nml' - read(nu_nml, nml=ponds_nml,iostat=nml_error) - if (nml_error /= 0) exit - print*,'Reading snow_nml' - read(nu_nml, nml=snow_nml,iostat=nml_error) - if (nml_error /= 0) exit - print*,'Reading forcing_nml' - read(nu_nml, nml=forcing_nml,iostat=nml_error) - if (nml_error /= 0) exit + read(nu_nml, nml=setup_nml,iostat=nml_error) end do - if (nml_error == 0) close(nu_nml) - endif - call broadcast_scalar(nml_error, master_task) - if (nml_error /= 0) then - call abort_ice(subname//'ERROR: reading namelist', & - file=__FILE__, line=__LINE__) + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: setup_nml reading ', & + file=__FILE__, line=__LINE__) + endif + + write(nu_diag,*) subname,' Reading grid_nml' + rewind(unit=nu_nml, iostat=nml_error) + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: grid_nml rewind ', & + file=__FILE__, line=__LINE__) + endif + nml_error = 1 + do while (nml_error > 0) + read(nu_nml, nml=grid_nml,iostat=nml_error) + end do + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: grid_nml reading ', & + file=__FILE__, line=__LINE__) + endif + + write(nu_diag,*) subname,' Reading tracer_nml' + rewind(unit=nu_nml, iostat=nml_error) + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: tracer_nml rewind ', & + file=__FILE__, line=__LINE__) + endif + nml_error = 1 + do while (nml_error > 0) + read(nu_nml, nml=tracer_nml,iostat=nml_error) + end do + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: tracer_nml reading ', & + file=__FILE__, line=__LINE__) + endif + + write(nu_diag,*) subname,' Reading thermo_nml' + rewind(unit=nu_nml, iostat=nml_error) + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: thermo_nml rewind ', & + file=__FILE__, line=__LINE__) + endif + nml_error = 1 + do while (nml_error > 0) + read(nu_nml, nml=thermo_nml,iostat=nml_error) + end do + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: thermo_nml reading ', & + file=__FILE__, line=__LINE__) + endif + + write(nu_diag,*) subname,' Reading dynamics_nml' + rewind(unit=nu_nml, iostat=nml_error) + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: dynamics_nml rewind ', & + file=__FILE__, line=__LINE__) + endif + nml_error = 1 + do while (nml_error > 0) + read(nu_nml, nml=dynamics_nml,iostat=nml_error) + end do + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: dynamics_nml reading ', & + file=__FILE__, line=__LINE__) + endif + + write(nu_diag,*) subname,' Reading shortwave_nml' + rewind(unit=nu_nml, iostat=nml_error) + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: shortwave_nml rewind ', & + file=__FILE__, line=__LINE__) + endif + nml_error = 1 + do while (nml_error > 0) + read(nu_nml, nml=shortwave_nml,iostat=nml_error) + end do + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: shortwave_nml reading ', & + file=__FILE__, line=__LINE__) + endif + + write(nu_diag,*) subname,' Reading ponds_nml' + rewind(unit=nu_nml, iostat=nml_error) + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: ponds_nml rewind ', & + file=__FILE__, line=__LINE__) + endif + nml_error = 1 + do while (nml_error > 0) + read(nu_nml, nml=ponds_nml,iostat=nml_error) + end do + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: ponds_nml reading ', & + file=__FILE__, line=__LINE__) + endif + + write(nu_diag,*) subname,' Reading snow_nml' + rewind(unit=nu_nml, iostat=nml_error) + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: snow_nml rewind ', & + file=__FILE__, line=__LINE__) + endif + nml_error = 1 + do while (nml_error > 0) + read(nu_nml, nml=snow_nml,iostat=nml_error) + end do + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: snow_nml reading ', & + file=__FILE__, line=__LINE__) + endif + + write(nu_diag,*) subname,' Reading forcing_nml' + rewind(unit=nu_nml, iostat=nml_error) + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: forcing_nml rewind ', & + file=__FILE__, line=__LINE__) + endif + nml_error = 1 + do while (nml_error > 0) + read(nu_nml, nml=forcing_nml,iostat=nml_error) + end do + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: forcing_nml reading ', & + file=__FILE__, line=__LINE__) + endif + + close(nu_nml) + call release_fileunit(nu_nml) endif - call release_fileunit(nu_nml) !----------------------------------------------------------------- ! set up diagnostics output and resolve conflicts diff --git a/cicecore/cicedynB/infrastructure/io/io_pio2/ice_restart.F90 b/cicecore/cicedynB/infrastructure/io/io_pio2/ice_restart.F90 index 0ec6b7628..c9e7fdf8a 100644 --- a/cicecore/cicedynB/infrastructure/io/io_pio2/ice_restart.F90 +++ b/cicecore/cicedynB/infrastructure/io/io_pio2/ice_restart.F90 @@ -718,7 +718,8 @@ subroutine read_restart_field(nu,nrec,work,atype,vname,ndim3,diag, & status = pio_inq_varid(File,trim(vname),vardesc) if (status /= PIO_noerr) then - call abort_ice(subname//"ERROR: CICE restart? Missing variable: "//trim(vname)) + call abort_ice(subname// & + "ERROR: CICE restart? Missing variable: "//trim(vname)) endif status = pio_inq_varndims(File, vardesc, ndims) @@ -728,6 +729,10 @@ subroutine read_restart_field(nu,nrec,work,atype,vname,ndim3,diag, & ! if (ndim3 == ncat .and. ncat>1) then if (ndim3 == ncat .and. ndims == 3) then call pio_read_darray(File, vardesc, iodesc3d_ncat, work, status) +!#ifndef CESM1_PIO +!! This only works for PIO2 +! where (work == PIO_FILL_DOUBLE) work = c0 +!#endif if (present(field_loc)) then do n=1,ndim3 call ice_HaloUpdate (work(:,:,n,:), halo_info, & @@ -737,6 +742,10 @@ subroutine read_restart_field(nu,nrec,work,atype,vname,ndim3,diag, & ! elseif (ndim3 == 1) then elseif (ndim3 == 1 .and. ndims == 2) then call pio_read_darray(File, vardesc, iodesc2d, work, status) +!#ifndef CESM1_PIO +!! This only works for PIO2 +! where (work == PIO_FILL_DOUBLE) work = c0 +!#endif if (present(field_loc)) then call ice_HaloUpdate (work(:,:,1,:), halo_info, & field_loc, field_type) diff --git a/cicecore/drivers/nuopc/cmeps/CICE_InitMod.F90 b/cicecore/drivers/nuopc/cmeps/CICE_InitMod.F90 index 8b69730b8..338b25050 100644 --- a/cicecore/drivers/nuopc/cmeps/CICE_InitMod.F90 +++ b/cicecore/drivers/nuopc/cmeps/CICE_InitMod.F90 @@ -84,7 +84,7 @@ subroutine cice_init2() use ice_dyn_vp , only: init_vp use ice_flux , only: init_coupler_flux, init_history_therm use ice_flux , only: init_history_dyn, init_flux_atm, init_flux_ocn - use ice_forcing , only: init_forcing_ocn, init_snowtable + use ice_forcing , only: init_snowtable use ice_forcing_bgc , only: get_forcing_bgc, get_atm_bgc use ice_forcing_bgc , only: faero_default, faero_optics, alloc_forcing_bgc, fiso_default use ice_history , only: init_hist, accum_hist @@ -139,9 +139,6 @@ subroutine cice_init2() call calendar() ! determine the initial date - !TODO: - why is this being called when you are using CMEPS? - call init_forcing_ocn(dt) ! initialize sss and sst from data - call init_state ! initialize the ice state call init_transport ! initialize horizontal transport call ice_HaloRestore_init ! restored boundary conditions @@ -388,7 +385,6 @@ subroutine init_restart() call init_fsd(trcrn(:,:,nt_fsd:nt_fsd+nfsd-1,:,:)) endif endif - ! isotopes if (tr_iso) then if (trim(runtype) == 'continue') restart_iso = .true. diff --git a/cicecore/drivers/nuopc/cmeps/CICE_RunMod.F90 b/cicecore/drivers/nuopc/cmeps/CICE_RunMod.F90 index cff4bf5df..64ce2fd7d 100644 --- a/cicecore/drivers/nuopc/cmeps/CICE_RunMod.F90 +++ b/cicecore/drivers/nuopc/cmeps/CICE_RunMod.F90 @@ -56,9 +56,9 @@ subroutine CICE_Run tr_iso, tr_aero, tr_zaero, skl_bgc, z_tracers, wave_spec, tr_fsd character(len=*), parameter :: subname = '(CICE_Run)' - !-------------------------------------------------------------------- - ! initialize error code and step timer - !-------------------------------------------------------------------- + !-------------------------------------------------------------------- + ! initialize error code and step timer + !-------------------------------------------------------------------- call ice_timer_start(timer_step) ! start timing entire run @@ -73,13 +73,13 @@ subroutine CICE_Run if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=__FILE__, line=__LINE__) - !-------------------------------------------------------------------- - ! timestep loop - !-------------------------------------------------------------------- + !-------------------------------------------------------------------- + ! timestep loop + !-------------------------------------------------------------------- call ice_timer_start(timer_couple) ! atm/ocn coupling - call advance_timestep() ! advance timestep and update calendar data + call advance_timestep() ! advance timestep and update calendar data if (z_tracers) call get_atm_bgc ! biogeochemistry @@ -92,9 +92,9 @@ subroutine CICE_Run call ice_step - !-------------------------------------------------------------------- - ! end of timestep loop - !-------------------------------------------------------------------- + !-------------------------------------------------------------------- + ! end of timestep loop + !-------------------------------------------------------------------- call ice_timer_stop(timer_step) ! end timestepping loop timer diff --git a/cicecore/drivers/nuopc/cmeps/ice_comp_nuopc.F90 b/cicecore/drivers/nuopc/cmeps/ice_comp_nuopc.F90 index aba515d9b..a9d71e479 100644 --- a/cicecore/drivers/nuopc/cmeps/ice_comp_nuopc.F90 +++ b/cicecore/drivers/nuopc/cmeps/ice_comp_nuopc.F90 @@ -15,30 +15,21 @@ module ice_comp_nuopc use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock use NUOPC_Model , only : model_label_Finalize => label_Finalize use NUOPC_Model , only : NUOPC_ModelGet, SetVM - use ice_constants , only : ice_init_constants + use ice_constants , only : ice_init_constants, c0 use ice_shr_methods , only : chkerr, state_setscalar, state_getscalar, state_diagnose, alarmInit - use ice_shr_methods , only : set_component_logging, get_component_instance - use ice_shr_methods , only : state_flddebug - use ice_import_export , only : ice_import, ice_export - use ice_import_export , only : ice_advertise_fields, ice_realize_fields + use ice_shr_methods , only : set_component_logging, get_component_instance, state_flddebug + use ice_import_export , only : ice_import, ice_export, ice_advertise_fields, ice_realize_fields use ice_domain_size , only : nx_global, ny_global - use ice_domain , only : nblocks, blocks_ice, distrb_info - use ice_blocks , only : block, get_block, nx_block, ny_block, nblocks_x, nblocks_y - use ice_blocks , only : nblocks_tot, get_block_parameter - use ice_distribution , only : ice_distributiongetblockloc - use ice_grid , only : tlon, tlat, hm, tarea, ULON, ULAT + use ice_grid , only : grid_type, init_grid2 use ice_communicate , only : init_communicate, my_task, master_task, mpi_comm_ice use ice_calendar , only : force_restart_now, write_ic - use ice_calendar , only : idate, mday, mmonth, year_init, timesecs + use ice_calendar , only : idate, mday, mmonth, myear, year_init use ice_calendar , only : msec, dt, calendar, calendar_type, nextsw_cday, istep use ice_kinds_mod , only : dbl_kind, int_kind, char_len, char_len_long - use ice_scam , only : scmlat, scmlon, single_column use ice_fileunits , only : nu_diag, nu_diag_set, inst_index, inst_name use ice_fileunits , only : inst_suffix, release_all_fileunits, flush_fileunit use ice_restart_shared , only : runid, runtype, restart, use_restart_time, restart_dir, restart_file use ice_history , only : accum_hist - use CICE_InitMod , only : cice_init - use CICE_RunMod , only : cice_run use ice_exit , only : abort_ice use icepack_intfc , only : icepack_warnings_flush, icepack_warnings_aborted use icepack_intfc , only : icepack_init_orbit, icepack_init_parameters, icepack_query_orbit @@ -48,9 +39,15 @@ module ice_comp_nuopc #ifdef CESMCOUPLED use shr_const_mod use shr_orb_mod , only : shr_orb_decl, shr_orb_params, SHR_ORB_UNDEF_REAL, SHR_ORB_UNDEF_INT + use ice_scam , only : scmlat, scmlon, scol_mask, scol_frac, scol_ni, scol_nj #endif use ice_timers + use CICE_InitMod , only : cice_init1, cice_init2 + use CICE_RunMod , only : cice_run + use ice_mesh_mod , only : ice_mesh_set_distgrid, ice_mesh_setmask_from_maskfile, ice_mesh_check + use ice_mesh_mod , only : ice_mesh_init_tlon_tlat_area_hm, ice_mesh_create_scolumn use ice_prescribed_mod , only : ice_prescribed_init + use ice_scam , only : scol_valid, single_column implicit none private @@ -86,6 +83,10 @@ module ice_comp_nuopc character(len=*),parameter :: shr_cal_noleap = 'NO_LEAP' character(len=*),parameter :: shr_cal_gregorian = 'GREGORIAN' + type(ESMF_Mesh) :: ice_mesh + + integer :: nthrds ! Number of threads to use in this component + integer :: dbug = 0 logical :: profile_memory = .false. integer , parameter :: debug_import = 0 ! internal debug level @@ -192,8 +193,54 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! Local variables character(len=char_len_long) :: cvalue - character(len=char_len_long) :: logmsg + character(len=char_len_long) :: ice_meshfile + character(len=char_len_long) :: ice_maskfile + character(len=char_len_long) :: errmsg logical :: isPresent, isSet + real(dbl_kind) :: eccen, obliqr, lambm0, mvelpp + type(ESMF_DistGrid) :: ice_distGrid + real(kind=dbl_kind) :: atmiter_conv + real(kind=dbl_kind) :: atmiter_conv_driver + integer (kind=int_kind) :: natmiter + integer (kind=int_kind) :: natmiter_driver + character(len=char_len) :: tfrz_option_driver ! tfrz_option from driver attributes + character(len=char_len) :: tfrz_option ! tfrz_option from cice namelist + integer(int_kind) :: ktherm + integer :: localPet + integer :: npes + logical :: mastertask + type(ESMF_VM) :: vm + integer :: lmpicom ! local communicator + type(ESMF_Time) :: currTime ! Current time + type(ESMF_Time) :: startTime ! Start time + type(ESMF_Time) :: stopTime ! Stop time + type(ESMF_Time) :: refTime ! Ref time + type(ESMF_TimeInterval) :: timeStep ! Model timestep + type(ESMF_Calendar) :: esmf_calendar ! esmf calendar + type(ESMF_CalKind_Flag) :: esmf_caltype ! esmf calendar type + integer :: start_ymd ! Start date (YYYYMMDD) + integer :: start_tod ! start time of day (s) + integer :: curr_ymd ! Current date (YYYYMMDD) + integer :: curr_tod ! Current time of day (s) + integer :: stop_ymd ! stop date (YYYYMMDD) + integer :: stop_tod ! stop time of day (sec) + integer :: ref_ymd ! Reference date (YYYYMMDD) + integer :: ref_tod ! reference time of day (s) + integer :: yy,mm,dd ! Temporaries for time query + integer :: dtime ! time step + integer :: shrlogunit ! original log unit + character(len=char_len) :: starttype ! infodata start type + integer :: lsize ! local size of coupling array + integer :: n,c,g,i,j,m ! indices + integer :: iblk, jblk ! indices + integer :: ig, jg ! indices + integer :: ilo, ihi, jlo, jhi ! beginning and end of physical domain + character(len=char_len_long) :: diag_filename = 'unset' + character(len=char_len_long) :: logmsg + character(len=char_len_long) :: single_column_lnd_domainfile + real(dbl_kind) :: scol_lon + real(dbl_kind) :: scol_lat + real(dbl_kind) :: scol_spval character(len=*), parameter :: subname=trim(modName)//':(InitializeAdvertise) ' !-------------------------------- @@ -257,102 +304,26 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) write(logmsg,'(i6)') dbug call ESMF_LogWrite('CICE_cap: dbug = '//trim(logmsg), ESMF_LOGMSG_INFO) - call ice_advertise_fields(gcomp, importState, exportState, flds_scalar_name, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - end subroutine InitializeAdvertise - - !=============================================================================== - - subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) - - ! Arguments - type(ESMF_GridComp) :: gcomp - type(ESMF_State) :: importState - type(ESMF_State) :: exportState - type(ESMF_Clock) :: clock - integer, intent(out) :: rc - - ! Local variables - real(dbl_kind) :: eccen, obliqr, lambm0, mvelpp - type(ESMF_DistGrid) :: distGrid - type(ESMF_Mesh) :: Emesh, EmeshTemp - integer :: spatialDim - integer :: numOwnedElements - real(dbl_kind), pointer :: ownedElemCoords(:) - real(dbl_kind), pointer :: lat(:), latMesh(:) - real(dbl_kind), pointer :: lon(:), lonMesh(:) - integer , allocatable :: gindex_ice(:) - integer , allocatable :: gindex_elim(:) - integer , allocatable :: gindex(:) - integer :: globalID - character(ESMF_MAXSTR) :: cvalue - character(len=char_len) :: tfrz_option - character(ESMF_MAXSTR) :: convCIM, purpComp - type(ESMF_VM) :: vm - type(ESMF_Time) :: currTime ! Current time - type(ESMF_Time) :: startTime ! Start time - type(ESMF_Time) :: stopTime ! Stop time - type(ESMF_Time) :: refTime ! Ref time - type(ESMF_TimeInterval) :: timeStep ! Model timestep - type(ESMF_Calendar) :: esmf_calendar ! esmf calendar - type(ESMF_CalKind_Flag) :: esmf_caltype ! esmf calendar type - integer :: start_ymd ! Start date (YYYYMMDD) - integer :: start_tod ! start time of day (s) - integer :: curr_ymd ! Current date (YYYYMMDD) - integer :: curr_tod ! Current time of day (s) - integer :: stop_ymd ! stop date (YYYYMMDD) - integer :: stop_tod ! stop time of day (sec) - integer :: ref_ymd ! Reference date (YYYYMMDD) - integer :: ref_tod ! reference time of day (s) - integer :: yy,mm,dd ! Temporaries for time query - integer :: iyear ! yyyy - integer :: dtime ! time step - integer :: lmpicom - integer :: shrlogunit ! original log unit - character(len=char_len) :: starttype ! infodata start type - integer :: lsize ! local size of coupling array - logical :: isPresent - logical :: isSet - integer :: localPet - integer :: n,c,g,i,j,m ! indices - integer :: iblk, jblk ! indices - integer :: ig, jg ! indices - integer :: ilo, ihi, jlo, jhi ! beginning and end of physical domain - type(block) :: this_block ! block information for current block - integer :: compid ! component id - character(len=char_len_long) :: tempc1,tempc2 - real(dbl_kind) :: diff_lon - integer :: npes - integer :: num_elim_global - integer :: num_elim_local - integer :: num_elim - integer :: num_ice - integer :: num_elim_gcells ! local number of eliminated gridcells - integer :: num_elim_blocks ! local number of eliminated blocks - integer :: num_total_blocks - integer :: my_elim_start, my_elim_end - real(dbl_kind) :: rad_to_deg - integer(int_kind) :: ktherm - logical :: mastertask - character(len=char_len_long) :: diag_filename = 'unset' - character(len=*), parameter :: F00 = "('(ice_comp_nuopc) ',2a,1x,d21.14)" - character(len=*), parameter :: subname=trim(modName)//':(InitializeRealize) ' - !-------------------------------- - - rc = ESMF_SUCCESS - if (dbug > 5) call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) - !---------------------------------------------------------------------------- ! generate local mpi comm !---------------------------------------------------------------------------- call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMGet(vm, mpiCommunicator=lmpicom, localPet=localPet, PetCount=npes, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return +#ifdef CESMCOUPLED + call ESMF_VMGet(vm, pet=localPet, peCount=nthrds, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (nthrds==1) then + call NUOPC_CompAttributeGet(gcomp, "nthreads", value=cvalue, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + read(cvalue,*) nthrds + endif +!$ call omp_set_num_threads(nthrds) +#endif + !---------------------------------------------------------------------------- ! Initialize cice communicators !---------------------------------------------------------------------------- @@ -384,6 +355,8 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ice_init_constants(omega_in=SHR_CONST_OMEGA, radius_in=SHR_CONST_REARTH, & spval_dbl_in=SHR_CONST_SPVAL) + ! TODO: get tfrz_option from driver + call icepack_init_parameters( & secday_in = SHR_CONST_CDAY, & rhoi_in = SHR_CONST_RHOICE, & @@ -407,8 +380,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) depressT_in = 0.054_dbl_kind, & Tocnfrz_in = -34.0_dbl_kind*0.054_dbl_kind, & pi_in = SHR_CONST_PI, & - snowpatch_in = 0.005_dbl_kind, & - dragio_in = 0.00536_dbl_kind) + snowpatch_in = 0.005_dbl_kind) call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & @@ -460,23 +432,6 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) runtype = 'initial' ! determined from the namelist in ice_init if CESMCOUPLED is not defined end if - ! Determine if single column - call NUOPC_CompAttributeGet(gcomp, name='single_column', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) single_column - if (single_column) then - call NUOPC_CompAttributeGet(gcomp, name='scmlon', value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) scmlon - call NUOPC_CompAttributeGet(gcomp, name='scmlat', value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) scmlat - end if - else - single_column = .false. - end if - ! Determine runid call NUOPC_CompAttributeGet(gcomp, name='case_name', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (isPresent .and. isSet) then @@ -551,15 +506,186 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) end if !---------------------------------------------------------------------------- - ! Initialize cice + ! First cice initialization phase - before initializing grid info !---------------------------------------------------------------------------- - ! Note that cice_init also sets time manager info as well as mpi communicator info, - ! including master_task and my_task +#ifdef CESMCOUPLED + ! Determine if single column + + call NUOPC_CompAttributeGet(gcomp, name='scol_lon', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) scmlon + call NUOPC_CompAttributeGet(gcomp, name='scol_lat', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) scmlat + call NUOPC_CompAttributeGet(gcomp, name='scol_spval', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) scol_spval + + if (scmlon > scol_spval .and. scmlat > scol_spval) then + call NUOPC_CompAttributeGet(gcomp, name='single_column_lnd_domainfile', & + value=single_column_lnd_domainfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (trim(single_column_lnd_domainfile) /= 'UNSET') then + single_column = .true. + else + call abort_ice('single_column_domainfile cannot be null for single column mode') + end if + call NUOPC_CompAttributeGet(gcomp, name='scol_ocnmask', value=cvalue, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) scol_mask + call NUOPC_CompAttributeGet(gcomp, name='scol_ocnfrac', value=cvalue, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) scol_frac + call NUOPC_CompAttributeGet(gcomp, name='scol_ni', value=cvalue, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) scol_ni + call NUOPC_CompAttributeGet(gcomp, name='scol_nj', value=cvalue, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) scol_nj - call t_startf ('cice_init') - call cice_init - call t_stopf ('cice_init') + call ice_mesh_create_scolumn(scmlon, scmlat, ice_mesh, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + scol_valid = (scol_mask == 1) + if (.not. scol_valid) then + write(6,*)'DEBUG: i am here' + ! Advertise fields + call ice_advertise_fields(gcomp, importState, exportState, flds_scalar_name, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call t_stopf ('cice_init_total') + + ! ******************* + ! *** RETURN HERE *** + ! ******************* + RETURN + end if + end if + + ! Read the cice namelist as part of the call to cice_init1 + ! Note that if single_column is true and scol_valid is not - will never get here + + call t_startf ('cice_init1') + call cice_init1 + call t_stopf ('cice_init1') + + ! Form of ocean freezing temperature + ! 'minus1p8' = -1.8 C + ! 'linear_salt' = -depressT * sss + ! 'mushy' conforms with ktherm=2 + call NUOPC_CompAttributeGet(gcomp, name="tfreeze_option", value=tfrz_option_driver, & + isPresent=isPresent, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (.not. isPresent) then + tfrz_option_driver = 'linear_salt' + end if + call icepack_query_parameters( tfrz_option_out=tfrz_option) + if (tfrz_option_driver /= tfrz_option) then + write(errmsg,'(a)') trim(subname)//'error: tfrz_option from driver '//trim(tfrz_option_driver)//& + ' must be the same as tfrz_option from cice namelist '//trim(tfrz_option) + call abort_ice(trim(errmsg)) + endif + + ! Flux convergence tolerance - always use the driver attribute value + call NUOPC_CompAttributeGet(gcomp, name="flux_convergence", value=cvalue, & + isPresent=isPresent, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + read(cvalue,*) atmiter_conv_driver + call icepack_query_parameters( atmiter_conv_out=atmiter_conv) + if (atmiter_conv_driver /= atmiter_conv) then + write(errmsg,'(a,d13.5,a,d13.5)') trim(subname)//'warning: atmiter_ from driver ',& + atmiter_conv_driver,' is overwritting atmiter_conv from cice namelist ',atmiter_conv + write(nu_diag,*) trim(errmsg) + call icepack_warnings_flush(nu_diag) + call icepack_init_parameters(atmiter_conv_in=atmiter_conv_driver) + end if + end if + + ! Number of iterations for boundary layer calculations + call NUOPC_CompAttributeGet(gcomp, name="flux_max_iteration", value=cvalue, isPresent=isPresent, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + read(cvalue,*) natmiter_driver + else + natmiter_driver = 5 + end if + call icepack_query_parameters( natmiter_out=natmiter) + if (natmiter_driver /= natmiter) then + write(errmsg,'(a,i8,a,i8)') trim(subname)//'error: natmiter_driver ',natmiter_driver, & + ' must be the same as natmiter from cice namelist ',natmiter + call abort_ice(trim(errmsg)) + endif + +#else + + ! Read the cice namelist as part of the call to cice_init1 + call t_startf ('cice_init1') + call cice_init1 + call t_stopf ('cice_init1') + +#endif + + !---------------------------------------------------------------------------- + ! Initialize grid info + !---------------------------------------------------------------------------- + + if (single_column .and. scol_valid) then + call ice_mesh_init_tlon_tlat_area_hm() + else + ! Determine mesh input file + call NUOPC_CompAttributeGet(gcomp, name='mesh_ice', value=ice_meshfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Determine mask input file + call NUOPC_CompAttributeGet(gcomp, name='mesh_mask', value=cvalue, isPresent=isPresent, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + ice_maskfile = trim(cvalue) + else + ice_maskfile = ice_meshfile + end if + if (my_task == master_task) then + write(nu_diag,*)'mesh file for cice domain is ',trim(ice_meshfile) + write(nu_diag,*)'mask file for cice domain is ',trim(ice_maskfile) + end if + + ! Determine the model distgrid using the decomposition obtained in + ! call to init_grid1 called from cice_init1 + call ice_mesh_set_distgrid(localpet, npes, ice_distgrid, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Read in the ice mesh on the cice distribution + ice_mesh = ESMF_MeshCreate(filename=trim(ice_meshfile), fileformat=ESMF_FILEFORMAT_ESMFMESH, & + elementDistGrid=ice_distgrid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Initialize the cice mesh and the cice mask + if (trim(grid_type) == 'setmask') then + ! In this case cap code determines the mask file + call ice_mesh_setmask_from_maskfile(ice_maskfile, ice_mesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ice_mesh_init_tlon_tlat_area_hm() + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + ! In this case init_grid2 will initialize tlon, tlat, area and hm + call init_grid2() + call ice_mesh_check(gcomp,ice_mesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + end if + + !---------------------------------------------------------------------------- + ! Second cice initialization phase -after initializing grid info + !---------------------------------------------------------------------------- + ! Note that cice_init2 also sets time manager info as well as mpi communicator info, + ! including master_task and my_task + ! Note that cice_init2 calls ice_init() which in turn calls icepack_init_parameters + ! which sets the tfrz_option + call t_startf ('cice_init2') + call cice_init2() + call t_stopf ('cice_init2') !---------------------------------------------------------------------------- ! reset shr logging to my log file @@ -573,14 +699,14 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! Now write output to nu_diag - this must happen AFTER call to cice_init if (mastertask) then - write(nu_diag,F00) trim(subname),' cice init nextsw_cday = ',nextsw_cday - write(nu_diag,*) trim(subname),' tfrz_option = ',trim(tfrz_option) + write(nu_diag,'(a,d21.14)') trim(subname)//' cice init nextsw_cday = ',nextsw_cday + write(nu_diag,'(a)') trim(subname)//' tfrz_option = '//trim(tfrz_option) if (ktherm == 2 .and. trim(tfrz_option) /= 'mushy') then write(nu_diag,*) trim(subname),' Warning: Using ktherm = 2 and tfrz_option = ', trim(tfrz_option) endif - write(nu_diag,*) trim(subname),' inst_name = ',trim(inst_name) - write(nu_diag,*) trim(subname),' inst_index = ',inst_index - write(nu_diag,*) trim(subname),' inst_suffix = ',trim(inst_suffix) + write(nu_diag,'(a )') trim(subname)//' inst_name = '//trim(inst_name) + write(nu_diag,'(a,i8 )') trim(subname)//' inst_index = ',inst_index + write(nu_diag,'(a )') trim(subname)//' inst_suffix = ',trim(inst_suffix) endif !--------------------------------------------------------------------------- @@ -589,7 +715,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! - on initial run ! - iyear, month and mday obtained from sync clock - ! - time determined from iyear, month and mday + ! - time determined from myear, month and mday ! - istep0 and istep1 are set to 0 ! - on restart run ! - istep0, time and time_forc are read from restart file @@ -618,28 +744,18 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) end if call abort_ice(subname//' :: ERROR idate lt zero') endif - iyear = (idate/10000) ! integer year of basedate - mmonth= (idate-iyear*10000)/100 ! integer month of basedate - mday = idate-iyear*10000-mmonth*100 ! day of month of basedate + myear = (idate/10000) ! integer year of basedate + mmonth= (idate-myear*10000)/100 ! integer month of basedate + mday = idate-myear*10000-mmonth*100 ! day of month of basedate if (my_task == master_task) then write(nu_diag,*) trim(subname),' curr_ymd = ',curr_ymd write(nu_diag,*) trim(subname),' cice year_init = ',year_init write(nu_diag,*) trim(subname),' cice start date = ',idate - write(nu_diag,*) trim(subname),' cice start ymds = ',iyear,mmonth,mday,start_tod + write(nu_diag,*) trim(subname),' cice start ymds = ',myear,mmonth,mday,start_tod write(nu_diag,*) trim(subname),' cice calendar_type = ',trim(calendar_type) endif -#ifdef CESMCOUPLED - if (calendar_type == "GREGORIAN" .or. & - calendar_type == "Gregorian" .or. & - calendar_type == "gregorian") then - call time2sec(iyear-(year_init-1),mmonth,mday,time) - else - call time2sec(iyear-year_init,mmonth,mday,time) - endif -#endif - timesecs = timesecs+start_tod end if call calendar() ! update calendar info @@ -647,239 +763,106 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call accum_hist(dt) ! write initial conditions end if - !--------------------------------------------------------------------------- - ! Determine the global index space needed for the distgrid - !--------------------------------------------------------------------------- - - ! number the local grid to get allocation size for gindex_ice - lsize = 0 - do iblk = 1, nblocks - this_block = get_block(blocks_ice(iblk),iblk) - ilo = this_block%ilo - ihi = this_block%ihi - jlo = this_block%jlo - jhi = this_block%jhi - do j = jlo, jhi - do i = ilo, ihi - lsize = lsize + 1 - enddo - enddo - enddo - - ! set global index array - allocate(gindex_ice(lsize)) - n = 0 - do iblk = 1, nblocks - this_block = get_block(blocks_ice(iblk),iblk) - ilo = this_block%ilo - ihi = this_block%ihi - jlo = this_block%jlo - jhi = this_block%jhi - do j = jlo, jhi - do i = ilo, ihi - n = n+1 - ig = this_block%i_glob(i) - jg = this_block%j_glob(j) - gindex_ice(n) = (jg-1)*nx_global + ig - enddo - enddo - enddo - - ! Determine total number of eliminated blocks globally - globalID = 0 - num_elim_global = 0 ! number of eliminated blocks - num_total_blocks = 0 - do jblk=1,nblocks_y - do iblk=1,nblocks_x - globalID = globalID + 1 - num_total_blocks = num_total_blocks + 1 - if (distrb_info%blockLocation(globalID) == 0) then - num_elim_global = num_elim_global + 1 - end if - end do - end do - - if (num_elim_global > 0) then - - ! Distribute the eliminated blocks in a round robin fashion amoung processors - num_elim_local = num_elim_global / npes - my_elim_start = num_elim_local*localPet + min(localPet, mod(num_elim_global, npes)) + 1 - if (localPet < mod(num_elim_global, npes)) then - num_elim_local = num_elim_local + 1 - end if - my_elim_end = my_elim_start + num_elim_local - 1 - - ! Determine the number of eliminated gridcells locally - globalID = 0 - num_elim_blocks = 0 ! local number of eliminated blocks - num_elim_gcells = 0 - do jblk=1,nblocks_y - do iblk=1,nblocks_x - globalID = globalID + 1 - if (distrb_info%blockLocation(globalID) == 0) then - num_elim_blocks = num_elim_blocks + 1 - if (num_elim_blocks >= my_elim_start .and. num_elim_blocks <= my_elim_end) then - this_block = get_block(globalID, globalID) - num_elim_gcells = num_elim_gcells + & - (this_block%jhi-this_block%jlo+1) * (this_block%ihi-this_block%ilo+1) - end if - end if - end do - end do - - ! Determine the global index space of the eliminated gridcells - allocate(gindex_elim(num_elim_gcells)) - globalID = 0 - num_elim_gcells = 0 ! local number of eliminated gridcells - num_elim_blocks = 0 ! local number of eliminated blocks - do jblk=1,nblocks_y - do iblk=1,nblocks_x - globalID = globalID + 1 - if (distrb_info%blockLocation(globalID) == 0) then - this_block = get_block(globalID, globalID) - num_elim_blocks = num_elim_blocks + 1 - if (num_elim_blocks >= my_elim_start .and. num_elim_blocks <= my_elim_end) then - do j=this_block%jlo,this_block%jhi - do i=this_block%ilo,this_block%ihi - num_elim_gcells = num_elim_gcells + 1 - ig = this_block%i_glob(i) - jg = this_block%j_glob(j) - gindex_elim(num_elim_gcells) = (jg-1)*nx_global + ig - end do - end do - end if - end if - end do - end do - - ! create a global index that includes both active and eliminated gridcells - num_ice = size(gindex_ice) - num_elim = size(gindex_elim) - allocate(gindex(num_elim + num_ice)) - do n = 1,num_ice - gindex(n) = gindex_ice(n) - end do - do n = num_ice+1,num_ice+num_elim - gindex(n) = gindex_elim(n-num_ice) - end do - - deallocate(gindex_elim) - - else - - ! No eliminated land blocks - num_ice = size(gindex_ice) - allocate(gindex(num_ice)) - do n = 1,num_ice - gindex(n) = gindex_ice(n) - end do + !----------------------------------------------------------------- + ! Prescribed ice initialization + !----------------------------------------------------------------- - end if + call ice_prescribed_init(clock, ice_mesh, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------------------------------------------------------------------- - ! Create distGrid from global index array - !--------------------------------------------------------------------------- + !----------------------------------------------------------------- + ! Advertise fields + !----------------------------------------------------------------- - DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) + ! NOTE: the advertise phase needs to be called after the ice + ! initialization since the number of ice categories is needed for + ! ice_fraction_n and mean_sw_pen_to_ocn_ifrac_n + call ice_advertise_fields(gcomp, importState, exportState, flds_scalar_name, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------------------------------------------------------------------- - ! Create the CICE mesh - !--------------------------------------------------------------------------- + call t_stopf ('cice_init_total') - ! read in the mesh - call NUOPC_CompAttributeGet(gcomp, name='mesh_ice', value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + end subroutine InitializeAdvertise - EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (my_task == master_task) then - write(nu_diag,*)'mesh file for cice domain is ',trim(cvalue) - end if + !=============================================================================== - ! recreate the mesh using the above distGrid - EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) - ! obtain mesh lats and lons - call ESMF_MeshGet(Emesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate(ownedElemCoords(spatialDim*numOwnedElements)) - allocate(lonMesh(numOwnedElements), latMesh(numOwnedElements)) - call ESMF_MeshGet(Emesh, ownedElemCoords=ownedElemCoords) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Arguments + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState + type(ESMF_State) :: exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc - do n = 1,numOwnedElements - lonMesh(n) = ownedElemCoords(2*n-1) - latMesh(n) = ownedElemCoords(2*n) - end do + ! Local variables + integer :: n + integer :: fieldcount + type(ESMF_Field) :: lfield + character(len=char_len_long) :: cvalue + real(dbl_kind) :: scol_lon + real(dbl_kind) :: scol_lat + real(dbl_kind) :: scol_spval + real(dbl_kind), pointer :: fldptr1d(:) + real(dbl_kind), pointer :: fldptr2d(:,:) + integer :: rank + character(len=char_len_long) :: single_column_lnd_domainfile + character(len=char_len_long) , pointer :: lfieldnamelist(:) => null() + character(len=*), parameter :: subname=trim(modName)//':(InitializeRealize) ' + !-------------------------------- - call icepack_query_parameters(rad_to_deg_out=rad_to_deg) - call icepack_warnings_flush(nu_diag) - if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & - file=__FILE__, line=__LINE__) + rc = ESMF_SUCCESS + if (dbug > 5) call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) - ! obtain internally generated cice lats and lons for error checks - allocate(lon(lsize)) - allocate(lat(lsize)) - n = 0 - do iblk = 1, nblocks - this_block = get_block(blocks_ice(iblk),iblk) - ilo = this_block%ilo - ihi = this_block%ihi - jlo = this_block%jlo - jhi = this_block%jhi - do j = jlo, jhi - do i = ilo, ihi - n = n+1 - lon(n) = tlon(i,j,iblk)*rad_to_deg - lat(n) = tlat(i,j,iblk)*rad_to_deg - enddo +#ifdef CESMCOUPLED + ! if single column is not valid - set all export state fields to zero and return + if (single_column .and. .not. scol_valid) then + write(nu_diag,'(a)')' (ice_comp_nuopc) single column mode point does not contain any ocn/ice '& + //' - setting all export data to 0' + call ice_realize_fields(gcomp, mesh=ice_mesh, & + flds_scalar_name=flds_scalar_name, flds_scalar_num=flds_scalar_num, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_StateGet(exportState, itemCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(lfieldnamelist(fieldCount)) + call ESMF_StateGet(exportState, itemNameList=lfieldnamelist, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1, fieldCount + if (trim(lfieldnamelist(n)) /= flds_scalar_name) then + call ESMF_StateGet(exportState, itemName=trim(lfieldnamelist(n)), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, rank=rank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (rank == 2) then + call ESMF_FieldGet(lfield, farrayPtr=fldptr2d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr2d(:,:) = 0._dbl_kind + else + call ESMF_FieldGet(lfield, farrayPtr=fldptr1d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr1d(:) = 0._dbl_kind + end if + end if enddo - enddo - - ! error check differences between internally generated lons and those read in - do n = 1,lsize - diff_lon = abs(lonMesh(n) - lon(n)) - if ( (diff_lon > 1.e2 .and. abs(diff_lon - 360_dbl_kind) > 1.e-1) .or.& - (diff_lon > 1.e-3 .and. diff_lon < 1._dbl_kind) ) then - !write(6,100)n,lonMesh(n),lon(n), diff_lon -100 format('ERROR: CICE n, lonmesh(n), lon(n), diff_lon = ',i6,2(f21.13,3x),d21.5) - !call abort_ice() - end if - if (abs(latMesh(n) - lat(n)) > 1.e-1) then - !write(6,101)n,latMesh(n),lat(n), abs(latMesh(n)-lat(n)) -101 format('ERROR: CICE n, latmesh(n), lat(n), diff_lat = ',i6,2(f21.13,3x),d21.5) - !call abort_ice() - end if - end do - - ! deallocate memory - deallocate(ownedElemCoords) - deallocate(lon, lonMesh) - deallocate(lat, latMesh) + deallocate(lfieldnamelist) + ! ******************* + ! *** RETURN HERE *** + ! ******************* + RETURN + else + write(nu_diag,'(a,3(f10.5,2x))')' (ice_comp_nuopc) single column mode lon/lat/frac is ',& + scmlon,scmlat,scol_frac + end if +#endif !----------------------------------------------------------------- ! Realize the actively coupled fields !----------------------------------------------------------------- - call ice_realize_fields(gcomp, mesh=Emesh, & + call ice_realize_fields(gcomp, mesh=ice_mesh, & flds_scalar_name=flds_scalar_name, flds_scalar_num=flds_scalar_num, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !----------------------------------------------------------------- - ! Prescribed ice initialization - first get compid - !----------------------------------------------------------------- - - call NUOPC_CompAttributeGet(gcomp, name='MCTID', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) compid ! convert from string to integer - else - compid = 0 - end if - call ice_prescribed_init(lmpicom, compid, gindex_ice) - !----------------------------------------------------------------- ! Create cice export state !----------------------------------------------------------------- @@ -894,16 +877,16 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) flds_scalar_name, flds_scalar_num, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + !-------------------------------- + ! diagnostics + !-------------------------------- + ! TODO (mvertens, 2018-12-21): fill in iceberg_prognostic as .false. if (debug_export > 0 .and. my_task==master_task) then call State_fldDebug(exportState, flds_scalar_name, 'cice_export:', & idate, msec, nu_diag, rc=rc) end if - !-------------------------------- - ! diagnostics - !-------------------------------- - if (dbug > 0) then call state_diagnose(exportState,subname//':ES',rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -911,11 +894,6 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (dbug > 5) call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) - call t_stopf ('cice_init_total') - - deallocate(gindex_ice) - deallocate(gindex) - call flush_fileunit(nu_diag) end subroutine InitializeRealize @@ -958,12 +936,21 @@ subroutine ModelAdvance(gcomp, rc) character(char_len_long) :: restart_date character(char_len_long) :: restart_filename logical :: isPresent, isSet - character(*) , parameter :: F00 = "('(ice_comp_nuopc) ',2a,i8,d21.14)" character(len=*),parameter :: subname=trim(modName)//':(ModelAdvance) ' character(char_len_long) :: msgString !-------------------------------- rc = ESMF_SUCCESS + + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + + if (single_column .and. .not. scol_valid) then + ! ******************* + ! *** RETURN HERE *** + ! ******************* + RETURN + end if + if (dbug > 5) call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) ! query the Component for its clock, importState and exportState @@ -1024,7 +1011,7 @@ subroutine ModelAdvance(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if if (my_task == master_task) then - write(nu_diag,F00) trim(subname),' cice istep, nextsw_cday = ',istep, nextsw_cday + write(nu_diag,'(a,2x,i8,2x,d24.14)') trim(subname)//' cice istep, nextsw_cday = ',istep, nextsw_cday end if !-------------------------------- @@ -1304,28 +1291,26 @@ end subroutine ModelSetRunClock !=============================================================================== subroutine ModelFinalize(gcomp, rc) + + !-------------------------------- + ! Finalize routine + !-------------------------------- + type(ESMF_GridComp) :: gcomp integer, intent(out) :: rc ! local variables - character(*), parameter :: F00 = "('(ice_comp_nuopc) ',8a)" - character(*), parameter :: F91 = "('(ice_comp_nuopc) ',73('-'))" + character(*), parameter :: F91 = "('(ice_comp_nuopc) ',73('-'))" character(len=*),parameter :: subname=trim(modName)//':(ModelFinalize) ' !-------------------------------- - !-------------------------------- - ! Finalize routine - !-------------------------------- - rc = ESMF_SUCCESS if (dbug > 5) call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) - if (my_task == master_task) then write(nu_diag,F91) - write(nu_diag,F00) 'CICE: end of main integration loop' + write(nu_diag,'(a)') 'CICE: end of main integration loop' write(nu_diag,F91) end if - if (dbug > 5) call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) end subroutine ModelFinalize @@ -1490,7 +1475,4 @@ subroutine ice_cal_ymd2date(year, month, day, date) end subroutine ice_cal_ymd2date - !=============================================================================== - - end module ice_comp_nuopc diff --git a/cicecore/drivers/nuopc/cmeps/ice_import_export.F90 b/cicecore/drivers/nuopc/cmeps/ice_import_export.F90 index 78d381d58..8fe939785 100644 --- a/cicecore/drivers/nuopc/cmeps/ice_import_export.F90 +++ b/cicecore/drivers/nuopc/cmeps/ice_import_export.F90 @@ -4,7 +4,7 @@ module ice_import_export use NUOPC use NUOPC_Model use ice_kinds_mod , only : int_kind, dbl_kind, char_len, log_kind - use ice_constants , only : c0, c1, spval_dbl + use ice_constants , only : c0, c1, spval_dbl, radius use ice_constants , only : field_loc_center, field_type_scalar, field_type_vector use ice_blocks , only : block, get_block, nx_block, ny_block use ice_domain , only : nblocks, blocks_ice, halo_info, distrb_info @@ -21,10 +21,12 @@ module ice_import_export use ice_flux , only : fresh, fsalt, zlvl, uatm, vatm, potT, Tair, Qa use ice_flux , only : rhoa, swvdr, swvdf, swidr, swidf, flw, frain use ice_flux , only : fsnow, uocn, vocn, sst, ss_tltx, ss_tlty, frzmlt + use ice_flux , only : send_i2x_per_cat use ice_flux , only : sss, Tf, wind, fsw use ice_state , only : vice, vsno, aice, aicen_init, trcr - use ice_grid , only : tlon, tlat, tarea, tmask, anglet, hm, ocn_gridcell_frac + use ice_grid , only : tlon, tlat, tarea, tmask, anglet, hm use ice_grid , only : grid_type, t2ugrid_vector + use ice_mesh_mod , only : ocn_gridcell_frac use ice_boundary , only : ice_HaloUpdate use ice_fileunits , only : nu_diag, flush_fileunit use ice_communicate , only : my_task, master_task, MPI_COMM_ICE @@ -34,9 +36,10 @@ module ice_import_export use icepack_intfc , only : icepack_query_parameters, icepack_query_tracer_flags use icepack_intfc , only : icepack_liquidus_temperature use icepack_intfc , only : icepack_sea_freezing_temperature - use cice_wrapper_mod , only : t_startf, t_stopf, t_barrierf + use cice_wrapper_mod , only : t_startf, t_stopf, t_barrierf #ifdef CESMCOUPLED use shr_frz_mod , only : shr_frz_freezetemp + use shr_mpi_mod , only : shr_mpi_min, shr_mpi_max #endif implicit none @@ -54,20 +57,18 @@ module ice_import_export interface state_getfldptr module procedure state_getfldptr_1d module procedure state_getfldptr_2d - module procedure state_getfldptr_3d - module procedure state_getfldptr_4d end interface state_getfldptr private :: state_getfldptr interface state_getimport - module procedure state_getimport_4d_output - module procedure state_getimport_3d_output + module procedure state_getimport_4d + module procedure state_getimport_3d end interface state_getimport private :: state_getimport interface state_setexport - module procedure state_setexport_4d_input - module procedure state_setexport_3d_input + module procedure state_setexport_4d + module procedure state_setexport_3d end interface state_setexport private :: state_setexport @@ -79,12 +80,15 @@ module ice_import_export integer :: ungridded_ubound = 0 end type fld_list_type + ! area correction factors for fluxes send and received from mediator + real(dbl_kind), allocatable :: mod2med_areacor(:) ! ratios of model areas to input mesh areas + real(dbl_kind), allocatable :: med2mod_areacor(:) ! ratios of input mesh areas to model areas + integer, parameter :: fldsMax = 100 integer :: fldsToIce_num = 0 integer :: fldsFrIce_num = 0 type (fld_list_type) :: fldsToIce(fldsMax) type (fld_list_type) :: fldsFrIce(fldsMax) - type(ESMF_GeomType_Flag) :: geomtype integer , parameter :: io_dbug = 10 ! i/o debug messages character(*), parameter :: u_FILE_u = & @@ -108,7 +112,6 @@ subroutine ice_advertise_fields(gcomp, importState, exportState, flds_scalar_nam character(char_len) :: stdname character(char_len) :: cvalue logical :: flds_wiso ! use case - logical :: flds_i2o_per_cat ! .true. => select per ice thickness category logical :: isPresent, isSet character(len=*), parameter :: subname='(ice_import_export:ice_advertise_fields)' !------------------------------------------------------------------------------- @@ -116,21 +119,33 @@ subroutine ice_advertise_fields(gcomp, importState, exportState, flds_scalar_nam rc = ESMF_SUCCESS if (io_dbug > 5) call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) - ! Determine if the following attributes are sent by the driver and if so read them in - flds_wiso = .false. - call NUOPC_CompAttributeGet(gcomp, name='flds_wiso', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + ! Determine if ice sends multiple ice category info back to mediator + send_i2x_per_cat = .false. + call NUOPC_CompAttributeGet(gcomp, name='flds_i2o_per_cat', value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(cvalue,*) flds_wiso - call ESMF_LogWrite('flds_wiso = '// trim(cvalue), ESMF_LOGMSG_INFO) + read(cvalue,*) send_i2x_per_cat + end if + if (my_task == master_task) then + write(nu_diag,*)'send_i2x_per_cat = ',send_i2x_per_cat + end if + if (.not.send_i2x_per_cat) then + if (allocated(fswthrun_ai)) then + deallocate(fswthrun_ai) + end if end if - flds_i2o_per_cat = .false. - call NUOPC_CompAttributeGet(gcomp, name='flds_i2o_per_cat', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + ! Determine if the following attributes are sent by the driver and if so read them in + flds_wiso = .false. + call NUOPC_CompAttributeGet(gcomp, name='flds_wiso', value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(cvalue,*) send_i2x_per_cat - call ESMF_LogWrite('flds_i2o_per_cat = '// trim(cvalue), ESMF_LOGMSG_INFO) + read(cvalue,*) flds_wiso + end if + if (my_task == master_task) then + write(nu_diag,*)'flds_wiso = ',flds_wiso end if !----------------- @@ -262,21 +277,35 @@ subroutine ice_advertise_fields(gcomp, importState, exportState, flds_scalar_nam end subroutine ice_advertise_fields -!============================================================================== - - subroutine ice_realize_fields(gcomp, mesh, grid, flds_scalar_name, flds_scalar_num, rc) + !============================================================================== + subroutine ice_realize_fields(gcomp, mesh, flds_scalar_name, flds_scalar_num, rc) ! input/output variables - type(ESMF_GridComp) :: gcomp - type(ESMF_Mesh) , optional , intent(in) :: mesh - type(ESMF_Grid) , optional , intent(in) :: grid - character(len=*) , intent(in) :: flds_scalar_name - integer , intent(in) :: flds_scalar_num - integer , intent(out) :: rc + type(ESMF_GridComp) :: gcomp + type(ESMF_Mesh) , intent(in) :: mesh + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(in) :: flds_scalar_num + integer , intent(out) :: rc ! local variables - type(ESMF_State) :: importState - type(ESMF_State) :: exportState + type(ESMF_State) :: importState + type(ESMF_State) :: exportState + type(ESMF_Field) :: lfield + integer :: numOwnedElements + integer :: i, j, iblk, n + integer :: ilo, ihi, jlo, jhi ! beginning and end of physical domain + type(block) :: this_block ! block information for current block + real(dbl_kind), allocatable :: mesh_areas(:) + real(dbl_kind), allocatable :: model_areas(:) + real(dbl_kind), pointer :: dataptr(:) + real(dbl_kind) :: max_mod2med_areacor + real(dbl_kind) :: max_med2mod_areacor + real(dbl_kind) :: min_mod2med_areacor + real(dbl_kind) :: min_med2mod_areacor + real(dbl_kind) :: max_mod2med_areacor_glob + real(dbl_kind) :: max_med2mod_areacor_glob + real(dbl_kind) :: min_mod2med_areacor_glob + real(dbl_kind) :: min_med2mod_areacor_glob character(len=*), parameter :: subname='(ice_import_export:realize_fields)' !--------------------------------------------------------------------------- @@ -285,60 +314,86 @@ subroutine ice_realize_fields(gcomp, mesh, grid, flds_scalar_name, flds_scalar_n call NUOPC_ModelGet(gcomp, importState=importState, exportState=exportState, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (present(mesh)) then - - geomtype = ESMF_GEOMTYPE_MESH - - call fldlist_realize( & - state=ExportState, & - fldList=fldsFrIce, & - numflds=fldsFrIce_num, & - flds_scalar_name=flds_scalar_name, & - flds_scalar_num=flds_scalar_num, & - tag=subname//':CICE_Export',& - mesh=mesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call fldlist_realize( & - state=importState, & - fldList=fldsToIce, & - numflds=fldsToIce_num, & - flds_scalar_name=flds_scalar_name, & - flds_scalar_num=flds_scalar_num, & - tag=subname//':CICE_Import',& - mesh=mesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - else if (present(grid)) then - - geomtype = ESMF_GEOMTYPE_GRID + call fldlist_realize( & + state=ExportState, & + fldList=fldsFrIce, & + numflds=fldsFrIce_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':CICE_Export',& + mesh=mesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call fldlist_realize( & - state=ExportState, & - fldList=fldsFrIce, & - numflds=fldsFrIce_num, & - flds_scalar_name=flds_scalar_name, & - flds_scalar_num=flds_scalar_num, & - tag=subname//':CICE_Export',& - grid=grid, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call fldlist_realize( & + state=importState, & + fldList=fldsToIce, & + numflds=fldsToIce_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':CICE_Import',& + mesh=mesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call fldlist_realize( & - state=importState, & - fldList=fldsToIce, & - numflds=fldsToIce_num, & - flds_scalar_name=flds_scalar_name, & - flds_scalar_num=flds_scalar_num, & - tag=subname//':CICE_Import',& - grid=grid, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return +#ifdef CESMCOUPLED + ! Get mesh areas from second field - using second field since the + ! first field is the scalar field + call ESMF_MeshGet(mesh, numOwnedElements=numOwnedElements, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_StateGet(exportState, itemName=trim(fldsFrIce(2)%stdname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridGetArea(lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=dataptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(mesh_areas(numOwnedElements)) + mesh_areas(:) = dataptr(:) + + ! Determine flux correction factors (module variables) + allocate(model_areas(numOwnedElements)) + allocate(mod2med_areacor(numOwnedElements)) + allocate(med2mod_areacor(numOwnedElements)) + mod2med_areacor(:) = 1._dbl_kind + med2mod_areacor(:) = 1._dbl_kind + n = 0 + do iblk = 1, nblocks + this_block = get_block(blocks_ice(iblk),iblk) + ilo = this_block%ilo + ihi = this_block%ihi + jlo = this_block%jlo + jhi = this_block%jhi + do j = jlo, jhi + do i = ilo, ihi + n = n+1 + model_areas(n) = tarea(i,j,iblk)/(radius*radius) + mod2med_areacor(n) = model_areas(n) / mesh_areas(n) + med2mod_areacor(n) = mesh_areas(n) / model_areas(n) + enddo + enddo + enddo + deallocate(model_areas) + deallocate(mesh_areas) + + min_mod2med_areacor = minval(mod2med_areacor) + max_mod2med_areacor = maxval(mod2med_areacor) + min_med2mod_areacor = minval(med2mod_areacor) + max_med2mod_areacor = maxval(med2mod_areacor) + call shr_mpi_max(max_mod2med_areacor, max_mod2med_areacor_glob, mpi_comm_ice) + call shr_mpi_min(min_mod2med_areacor, min_mod2med_areacor_glob, mpi_comm_ice) + call shr_mpi_max(max_med2mod_areacor, max_med2mod_areacor_glob, mpi_comm_ice) + call shr_mpi_min(min_med2mod_areacor, min_med2mod_areacor_glob, mpi_comm_ice) + + if (my_task == master_task) then + write(nu_diag,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& + min_mod2med_areacor_glob, max_mod2med_areacor_glob, 'CICE6' + write(nu_diag,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& + min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'CICE6' end if +#endif end subroutine ice_realize_fields !============================================================================== - subroutine ice_import( importState, rc ) ! input/output variables @@ -355,7 +410,11 @@ subroutine ice_import( importState, rc ) real (kind=dbl_kind) :: workx, worky real (kind=dbl_kind) :: MIN_RAIN_TEMP, MAX_SNOW_TEMP real (kind=dbl_kind) :: Tffresh - real (kind=dbl_kind) :: inst_pres_height_lowest + real (kind=dbl_kind) :: inst_pres_height_lowest + real (kind=dbl_kind), pointer :: dataptr2d(:,:) + real (kind=dbl_kind), pointer :: dataptr1d(:) + real (kind=dbl_kind), pointer :: dataptr2d_dstwet(:,:) + real (kind=dbl_kind), pointer :: dataptr2d_dstdry(:,:) character(len=char_len) :: tfrz_option integer(int_kind) :: ktherm character(len=*), parameter :: subname = 'ice_import' @@ -365,17 +424,20 @@ subroutine ice_import( importState, rc ) call icepack_query_parameters(Tffresh_out=Tffresh) call icepack_query_parameters(tfrz_option_out=tfrz_option) call icepack_query_parameters(ktherm_out=ktherm) - if (io_dbug > 5) then - write(msgString,'(A,i8)')trim(subname)//' tfrz_option = ' & - // trim(tfrz_option)//', ktherm = ',ktherm - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + + if (io_dbug > 5) then + write(msgString,'(A,i8)')trim(subname)//' tfrz_option = ' & + // trim(tfrz_option)//', ktherm = ',ktherm + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) end if -! call icepack_query_parameters(tfrz_option_out=tfrz_option, & -! modal_aero_out=modal_aero, z_tracers_out=z_tracers, skl_bgc_out=skl_bgc, & -! Tffresh_out=Tffresh) -! call icepack_query_tracer_flags(tr_aero_out=tr_aero, tr_iage_out=tr_iage, & -! tr_FY_out=tr_FY, tr_pond_out=tr_pond, tr_lvl_out=tr_lvl, & -! tr_zaero_out=tr_zaero, tr_bgc_Nit_out=tr_bgc_Nit) + + ! call icepack_query_parameters(tfrz_option_out=tfrz_option, & + ! modal_aero_out=modal_aero, z_tracers_out=z_tracers, skl_bgc_out=skl_bgc, & + ! Tffresh_out=Tffresh) + ! call icepack_query_tracer_flags(tr_aero_out=tr_aero, tr_iage_out=tr_iage, & + ! tr_FY_out=tr_FY, tr_pond_out=tr_pond, tr_lvl_out=tr_lvl, & + ! tr_zaero_out=tr_zaero, tr_bgc_Nit_out=tr_bgc_Nit) + call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=u_FILE_u, line=__LINE__) @@ -429,30 +491,38 @@ subroutine ice_import( importState, rc ) ! import ocn/ice fluxes - call state_getimport(importState, 'freezing_melting_potential', output=aflds, index=9, rc=rc) + call state_getimport(importState, 'freezing_melting_potential', output=aflds, index=9, & + areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! import atm fluxes - call state_getimport(importState, 'mean_down_sw_vis_dir_flx', output=aflds, index=10, rc=rc) + call state_getimport(importState, 'mean_down_sw_vis_dir_flx', output=aflds, index=10, & + areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'mean_down_sw_ir_dir_flx', output=aflds, index=11, rc=rc) + call state_getimport(importState, 'mean_down_sw_ir_dir_flx', output=aflds, index=11, & + areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'mean_down_sw_vis_dif_flx', output=aflds, index=12, rc=rc) + call state_getimport(importState, 'mean_down_sw_vis_dif_flx', output=aflds, index=12, & + areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'mean_down_sw_ir_dif_flx', output=aflds, index=13, rc=rc) + call state_getimport(importState, 'mean_down_sw_ir_dif_flx', output=aflds, index=13, & + areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'mean_down_lw_flx', output=aflds, index=14, rc=rc) + call state_getimport(importState, 'mean_down_lw_flx', output=aflds, index=14, & + areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'mean_prec_rate', output=aflds, index=15, rc=rc) + call state_getimport(importState, 'mean_prec_rate', output=aflds, index=15, & + areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'mean_fprec_rate', output=aflds, index=16, rc=rc) + call state_getimport(importState, 'mean_fprec_rate', output=aflds, index=16, & + areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! perform a halo update @@ -488,7 +558,7 @@ subroutine ice_import( importState, rc ) end do !$OMP END PARALLEL DO - if ( State_fldChk(importState, 'Sa_ptem') .and. State_fldchk(importState,'air_density_height_lowest')) then + if ( State_fldChk(importState, 'Sa_ptem') .and. State_fldchk(importState,'air_density_height_lowest')) then !$OMP PARALLEL DO PRIVATE(iblk,i,j) do iblk = 1, nblocks do j = 1,ny_block @@ -518,7 +588,7 @@ subroutine ice_import( importState, rc ) endif end do !i end do !j - end do !iblk + end do !iblk !$OMP END PARALLEL DO end if @@ -577,34 +647,45 @@ subroutine ice_import( importState, rc ) ! bcphodry ungridded_index=2 ! bcphiwet ungridded_index=3 - ! bcphodry - call state_getimport(importState, 'Faxa_bcph', output=faero_atm, index=1, ungridded_index=2, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! bcphidry + bcphiwet - call state_getimport(importState, 'Faxa_bcph', output=faero_atm, index=2, ungridded_index=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Faxa_bcph', output=faero_atm, index=2, do_sum=.true., ungridded_index=3, rc=rc) + call state_getfldptr(importState, 'Faxa_bcph', fldptr=dataPtr2d, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + n = 0 + do iblk = 1, nblocks + this_block = get_block(blocks_ice(iblk),iblk) + ilo = this_block%ilo; ihi = this_block%ihi + jlo = this_block%jlo; jhi = this_block%jhi + do j = jlo, jhi + do i = ilo, ihi + n = n+1 + faero_atm(i,j,1,iblk) = dataPtr2d(2,n) * med2mod_areacor(n) ! bcphodry + faero_atm(i,j,2,iblk) = (dataptr2d(1,n) + dataPtr2d(3,n)) * med2mod_areacor(n) ! bcphidry + bcphiwet + end do + end do + end do end if ! Sum over all dry and wet dust fluxes from ath atmosphere if (State_FldChk(importState, 'Faxa_dstwet') .and. State_FldChk(importState, 'Faxa_dstdry')) then - call state_getimport(importState, 'Faxa_dstwet', output=faero_atm, index=3, ungridded_index=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Faxa_dstdry', output=faero_atm, index=3, do_sum=.true., ungridded_index=1, rc=rc) + call state_getfldptr(importState, 'Faxa_dstwet', fldptr=dataPtr2d_dstwet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Faxa_dstwet', output=faero_atm, index=3, do_sum=.true., ungridded_index=2, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Faxa_dstdry', output=faero_atm, index=3, do_sum=.true., ungridded_index=2, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Faxa_dstwet', output=faero_atm, index=3, do_sum=.true., ungridded_index=3, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Faxa_dstdry', output=faero_atm, index=3, do_sum=.true., ungridded_index=3, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Faxa_dstwet', output=faero_atm, index=3, do_sum=.true., ungridded_index=4, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Faxa_dstdry', output=faero_atm, index=3, do_sum=.true., ungridded_index=4, rc=rc) + call state_getfldptr(importState, 'Faxa_dstdry', fldptr=dataPtr2d_dstdry, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + n = 0 + do iblk = 1, nblocks + this_block = get_block(blocks_ice(iblk),iblk) + ilo = this_block%ilo; ihi = this_block%ihi + jlo = this_block%jlo; jhi = this_block%jhi + do j = jlo, jhi + do i = ilo, ihi + n = n+1 + faero_atm(i,j,3,iblk) = dataPtr2d_dstwet(1,n) + dataptr2d_dstdry(1,n) + & + dataPtr2d_dstwet(2,n) + dataptr2d_dstdry(2,n) + & + dataPtr2d_dstwet(3,n) + dataptr2d_dstdry(3,n) + & + dataPtr2d_dstwet(4,n) + dataptr2d_dstdry(4,n) + faero_atm(i,j,3,iblk) = faero_atm(i,j,3,iblk) * med2mod_areacor(n) + end do + end do + end do end if !------------------------------------------------------- @@ -623,12 +704,15 @@ subroutine ice_import( importState, rc ) call state_getimport(importState, 'inst_spec_humid_height_lowest_wiso', output=Qa_iso, index=3, ungridded_index=2, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return -! call state_getimport(importState, 'mean_prec_rate_wiso', output=fiso_rain, index=1, ungridded_index=3, rc=rc) -! if (ChkErr(rc,__LINE__,u_FILE_u)) return -! call state_getimport(importState, 'mean_prec_rate_wiso', output=fiso_rain, index=2, ungridded_index=1, rc=rc) -! if (ChkErr(rc,__LINE__,u_FILE_u)) return -! call state_getimport(importState, 'mean_prec_rate_wiso', output=fiso_rain, index=3, ungridded_index=2, rc=rc) -! if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! call state_getimport(importState, 'mean_prec_rate_wiso', output=fiso_rain, index=1, ungridded_index=3, & + ! areacor=med2mod_areacor, rc=rc) + ! if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! call state_getimport(importState, 'mean_prec_rate_wiso', output=fiso_rain, index=2, ungridded_index=1, & + ! areacor=med2mod_areacor, rc=rc) + ! if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! call state_getimport(importState, 'mean_prec_rate_wiso', output=fiso_rain, index=3, ungridded_index=2, & + ! areacor=med2mod_areacor, rc=rc) + ! if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_getimport(importState, 'mean_fprec_rate_wiso', output=fiso_atm, index=1, ungridded_index=3, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -637,11 +721,14 @@ subroutine ice_import( importState, rc ) call state_getimport(importState, 'mean_fprec_rate_wiso', output=fiso_atm, index=3, ungridded_index=2, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'So_roce_wiso', output=HDO_ocn , ungridded_index=3, rc=rc) + call state_getimport(importState, 'So_roce_wiso', output=HDO_ocn , ungridded_index=3, & + areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'So_roce_wiso', output=H2_16O_ocn, ungridded_index=1, rc=rc) + call state_getimport(importState, 'So_roce_wiso', output=H2_16O_ocn, ungridded_index=1, & + areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'So_roce_wiso', output=H2_18O_ocn, ungridded_index=2, rc=rc) + call state_getimport(importState, 'So_roce_wiso', output=H2_18O_ocn, ungridded_index=2, & + areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -690,9 +777,11 @@ subroutine ice_import( importState, rc ) #ifdef CESMCOUPLED ! Use shr_frz_mod for this - Tf(:,:,iblk) = shr_frz_freezetemp(sss(:,:,iblk)) -#else - !$OMP PARALLEL DO PRIVATE(iblk,i,j,workx,worky) + do iblk = 1, nblocks + Tf(:,:,iblk) = shr_frz_freezetemp(sss(:,:,iblk)) + end do +#else + !$OMP PARALLEL DO PRIVATE(iblk,i,j) do iblk = 1, nblocks do j = 1,ny_block do i = 1,nx_block @@ -747,7 +836,6 @@ subroutine ice_import( importState, rc ) end subroutine ice_import !=============================================================================== - subroutine ice_export( exportState, rc ) ! input/output variables @@ -770,8 +858,10 @@ subroutine ice_export( exportState, rc ) real (kind=dbl_kind) :: tauxo (nx_block,ny_block,max_blocks) ! ice/ocean stress real (kind=dbl_kind) :: tauyo (nx_block,ny_block,max_blocks) ! ice/ocean stress real (kind=dbl_kind) :: ailohi(nx_block,ny_block,max_blocks) ! fractional ice area - real (kind=dbl_kind), allocatable :: tempfld(:,:,:) real (kind=dbl_kind) :: Tffresh + real (kind=dbl_kind), allocatable :: tempfld(:,:,:) + real (kind=dbl_kind), pointer :: dataptr_ifrac_n(:,:) + real (kind=dbl_kind), pointer :: dataptr_swpen_n(:,:) character(len=*),parameter :: subname = 'ice_export' !----------------------------------------------------- @@ -779,12 +869,13 @@ subroutine ice_export( exportState, rc ) if (io_dbug > 5) call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) call icepack_query_parameters(Tffresh_out=Tffresh) -! call icepack_query_parameters(tfrz_option_out=tfrz_option, & -! modal_aero_out=modal_aero, z_tracers_out=z_tracers, skl_bgc_out=skl_bgc, & -! Tffresh_out=Tffresh) -! call icepack_query_tracer_flags(tr_aero_out=tr_aero, tr_iage_out=tr_iage, & -! tr_FY_out=tr_FY, tr_pond_out=tr_pond, tr_lvl_out=tr_lvl, & -! tr_zaero_out=tr_zaero, tr_bgc_Nit_out=tr_bgc_Nit) + ! call icepack_query_parameters(tfrz_option_out=tfrz_option, & + ! modal_aero_out=modal_aero, z_tracers_out=z_tracers, skl_bgc_out=skl_bgc, & + ! Tffresh_out=Tffresh) + ! call icepack_query_tracer_flags(tr_aero_out=tr_aero, tr_iage_out=tr_iage, & + ! tr_FY_out=tr_FY, tr_pond_out=tr_pond, tr_lvl_out=tr_lvl, & + ! tr_zaero_out=tr_zaero, tr_bgc_Nit_out=tr_bgc_Nit) + call icepack_warnings_flush(nu_diag) if (icepack_warnings_aborted()) call abort_ice(error_message=subname, & file=u_FILE_u, line=__LINE__) @@ -880,7 +971,7 @@ subroutine ice_export( exportState, rc ) call state_setexport(exportState, 'ice_fraction', input=ailohi, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (trim(grid_type) == 'latlon') then + if (trim(grid_type) == 'setmask') then call state_setexport(exportState, 'ice_mask', input=ocn_gridcell_frac, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return else @@ -967,31 +1058,38 @@ subroutine ice_export( exportState, rc ) ! ------ ! Zonal air/ice stress - call state_setexport(exportState, 'stress_on_air_ice_zonal' , input=tauxa, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'stress_on_air_ice_zonal' , input=tauxa, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Meridional air/ice stress - call state_setexport(exportState, 'stress_on_air_ice_merid' , input=tauya, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'stress_on_air_ice_merid' , input=tauya, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Latent heat flux (atm into ice) - call state_setexport(exportState, 'mean_laten_heat_flx_atm_into_ice' , input=flat, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'mean_laten_heat_flx_atm_into_ice' , input=flat, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Sensible heat flux (atm into ice) - call state_setexport(exportState, 'mean_sensi_heat_flx_atm_into_ice' , input=fsens, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'mean_sensi_heat_flx_atm_into_ice' , input=fsens, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! longwave outgoing (upward), average over ice fraction only - call state_setexport(exportState, 'mean_up_lw_flx_ice' , input=flwout, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'mean_up_lw_flx_ice' , input=flwout, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Evaporative water flux (kg/m^2/s) - call state_setexport(exportState, 'mean_evap_rate_atm_into_ice' , input=evap, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'mean_evap_rate_atm_into_ice' , input=evap, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Shortwave flux absorbed in ice and ocean (W/m^2) - call state_setexport(exportState, 'Faii_swnet' , input=fswabs, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'Faii_swnet' , input=fswabs, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! ------ @@ -999,43 +1097,53 @@ subroutine ice_export( exportState, rc ) ! ------ ! flux of shortwave through ice to ocean - call state_setexport(exportState, 'mean_sw_pen_to_ocn' , input=fswthru, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'mean_sw_pen_to_ocn' , input=fswthru, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! flux of vis dir shortwave through ice to ocean - call state_setexport(exportState, 'mean_sw_pen_to_ocn_vis_dir_flx' , input=fswthru_vdr, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'mean_sw_pen_to_ocn_vis_dir_flx' , input=fswthru_vdr, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! flux of vis dif shortwave through ice to ocean - call state_setexport(exportState, 'mean_sw_pen_to_ocn_vis_dif_flx' , input=fswthru_vdf, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'mean_sw_pen_to_ocn_vis_dif_flx' , input=fswthru_vdf, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! flux of ir dir shortwave through ice to ocean - call state_setexport(exportState, 'mean_sw_pen_to_ocn_ir_dir_flx' , input=fswthru_idr, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'mean_sw_pen_to_ocn_ir_dir_flx' , input=fswthru_idr, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! flux of ir dif shortwave through ice to ocean - call state_setexport(exportState, 'mean_sw_pen_to_ocn_ir_dif_flx' , input=fswthru_idf, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'mean_sw_pen_to_ocn_ir_dif_flx' , input=fswthru_idf, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! heat exchange with ocean - call state_setexport(exportState, 'net_heat_flx_to_ocn' , input=fhocn, lmask=tmask, ifrac=ailohi, rc=rc) + ! flux of heat exchange with ocean + call state_setexport(exportState, 'net_heat_flx_to_ocn' , input=fhocn, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! fresh water to ocean (h2o flux from melting) - call state_setexport(exportState, 'mean_fresh_water_to_ocean_rate' , input=fresh, lmask=tmask, ifrac=ailohi, rc=rc) + ! flux fresh water to ocean (h2o flux from melting) + call state_setexport(exportState, 'mean_fresh_water_to_ocean_rate' , input=fresh, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! salt to ocean (salt flux from melting) - call state_setexport(exportState, 'mean_salt_rate' , input=fsalt, lmask=tmask, ifrac=ailohi, rc=rc) + ! flux of salt to ocean (salt flux from melting) + call state_setexport(exportState, 'mean_salt_rate' , input=fsalt, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! stress n i/o zonal - call state_setexport(exportState, 'stress_on_ocn_ice_zonal' , input=tauxo, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'stress_on_ocn_ice_zonal' , input=tauxo, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! stress n i/o meridional - call state_setexport(exportState, 'stress_on_ocn_ice_merid' , input=tauyo, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'stress_on_ocn_ice_merid' , input=tauyo, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! ------ @@ -1044,19 +1152,22 @@ subroutine ice_export( exportState, rc ) ! hydrophobic bc if (State_FldChk(exportState, 'Fioi_bcpho')) then - call state_setexport(exportState, 'Fioi_bcpho' , input=faero_ocn, index=1, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'Fioi_bcpho' , input=faero_ocn, index=1, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if ! hydrophilic bc if (State_FldChk(exportState, 'Fioi_bcphi')) then - call state_setexport(exportState, 'Fioi_bcphi' , input=faero_ocn, index=2, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'Fioi_bcphi' , input=faero_ocn, index=2, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if ! dust if (State_FldChk(exportState, 'Fioi_flxdst')) then - call state_setexport(exportState, 'Fioi_flxdst' , input=faero_ocn, index=3, lmask=tmask, ifrac=ailohi, rc=rc) + call state_setexport(exportState, 'Fioi_flxdst' , input=faero_ocn, index=3, lmask=tmask, ifrac=ailohi, & + areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -1070,13 +1181,13 @@ subroutine ice_export( exportState, rc ) ! HDO => ungridded_index=3 call state_setexport(exportState, 'mean_fresh_water_to_ocean_rate_wiso' , input=fiso_ocn, index=1, & - lmask=tmask, ifrac=ailohi, ungridded_index=3, rc=rc) + lmask=tmask, ifrac=ailohi, ungridded_index=3, areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_setexport(exportState, 'mean_fresh_water_to_ocean_rate_wiso' , input=fiso_ocn, index=2, & - lmask=tmask, ifrac=ailohi, ungridded_index=1, rc=rc) + lmask=tmask, ifrac=ailohi, ungridded_index=1, areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_setexport(exportState, 'mean_fresh_water_to_ocean_rate_wiso' , input=fiso_ocn, index=3, & - lmask=tmask, ifrac=ailohi, ungridded_index=2, rc=rc) + lmask=tmask, ifrac=ailohi, ungridded_index=2, areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -1087,16 +1198,16 @@ subroutine ice_export( exportState, rc ) if (State_FldChk(exportState, 'mean_evap_rate_atm_into_ice_wiso')) then ! Isotope evap to atm call state_setexport(exportState, 'mean_evap_rate_atm_into_ice_wiso' , input=fiso_evap, index=1, & - lmask=tmask, ifrac=ailohi, ungridded_index=3, rc=rc) + lmask=tmask, ifrac=ailohi, ungridded_index=3, areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_setexport(exportState, 'mean_evap_rate_atm_into_ice_wiso' , input=fiso_evap, index=2, & - lmask=tmask, ifrac=ailohi, ungridded_index=1, rc=rc) + lmask=tmask, ifrac=ailohi, ungridded_index=1, areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call state_setexport(exportState, 'mean_evap_rate_atm_into_ice_wiso' , input=fiso_evap, index=3, & - lmask=tmask, ifrac=ailohi, ungridded_index=2, rc=rc) + lmask=tmask, ifrac=ailohi, ungridded_index=2, areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Isotope evap to atm + ! qref to atm call state_setexport(exportState, 'Si_qref_wiso' , input=Qref_iso, index=1, & lmask=tmask, ifrac=ailohi, ungridded_index=3, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1124,7 +1235,7 @@ subroutine ice_export( exportState, rc ) ! Note: no need zero out pass-through fields over land for benefit of x2oacc fields in cpl hist files since ! the export state has been zeroed out at the beginning call state_setexport(exportState, 'mean_sw_pen_to_ocn_ifrac_n', input=fswthrun_ai, index=n, & - lmask=tmask, ifrac=ailohi, ungridded_index=n, rc=rc) + lmask=tmask, ifrac=ailohi, ungridded_index=n, areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end do end if @@ -1132,7 +1243,6 @@ subroutine ice_export( exportState, rc ) end subroutine ice_export !=============================================================================== - subroutine fldlist_add(num, fldlist, stdname, ungridded_lbound, ungridded_ubound) ! input/output variables @@ -1162,7 +1272,6 @@ subroutine fldlist_add(num, fldlist, stdname, ungridded_lbound, ungridded_ubound end subroutine fldlist_add !=============================================================================== - subroutine fldlist_realize(state, fldList, numflds, flds_scalar_name, flds_scalar_num, mesh, grid, tag, rc) use NUOPC, only : NUOPC_IsConnected, NUOPC_Realize @@ -1187,6 +1296,7 @@ subroutine fldlist_realize(state, fldList, numflds, flds_scalar_name, flds_scala integer :: n type(ESMF_Field) :: field character(len=80) :: stdname + character(ESMF_MAXSTR) :: msg character(len=*),parameter :: subname='(ice_import_export:fld_list_realize)' ! ---------------------------------------------- @@ -1203,8 +1313,6 @@ subroutine fldlist_realize(state, fldList, numflds, flds_scalar_name, flds_scala if (ChkErr(rc,__LINE__,u_FILE_u)) return else if (present(mesh)) then - call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is connected using mesh", & - ESMF_LOGMSG_INFO) ! Create the field if (fldlist(n)%ungridded_lbound > 0 .and. fldlist(n)%ungridded_ubound > 0) then field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, & @@ -1212,9 +1320,16 @@ subroutine fldlist_realize(state, fldList, numflds, flds_scalar_name, flds_scala ungriddedUbound=(/fldlist(n)%ungridded_ubound/), & gridToFieldMap=(/2/), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(msg, '(a,i4,2x,i4)') trim(subname)//trim(tag)//" Field = "//trim(stdname)//& + " is connected using mesh with lbound, ubound = ",& + fldlist(n)%ungridded_lbound,fldlist(n)%ungridded_ubound + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO) else field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(msg, '(a,i4,a,i4)') trim(subname)//trim(tag)//" Field = "//trim(stdname)//& + " is connected using mesh without ungridded dimension" + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO) end if else if (present(grid)) then call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is connected using grid", & @@ -1287,7 +1402,6 @@ end subroutine SetScalarField end subroutine fldlist_realize !=============================================================================== - logical function State_FldChk(State, fldname) ! ---------------------------------------------- ! Determine if field is in state @@ -1302,27 +1416,25 @@ logical function State_FldChk(State, fldname) ! ---------------------------------------------- call ESMF_StateGet(State, trim(fldname), itemType) - State_FldChk = (itemType /= ESMF_STATEITEM_NOTFOUND) end function State_FldChk !=============================================================================== - - subroutine state_getimport_4d_output(state, fldname, output, index, do_sum, ungridded_index, rc) + subroutine state_getimport_4d(state, fldname, output, index, ungridded_index, areacor, rc) ! ---------------------------------------------- ! Map import state field to output array ! ---------------------------------------------- ! input/output variables - type(ESMF_State) , intent(in) :: state - character(len=*) , intent(in) :: fldname - real (kind=dbl_kind) , intent(inout) :: output(:,:,:,:) - integer , intent(in) :: index - logical, optional , intent(in) :: do_sum - integer, optional , intent(in) :: ungridded_index - integer , intent(out) :: rc + type(ESMF_State) , intent(in) :: state + character(len=*) , intent(in) :: fldname + real (kind=dbl_kind) , intent(inout) :: output(:,:,:,:) + integer , intent(in) :: index + integer, optional , intent(in) :: ungridded_index + real(kind=dbl_kind), optional , intent(in) :: areacor(:) + integer , intent(out) :: rc ! local variables type(block) :: this_block ! block information for current block @@ -1330,9 +1442,7 @@ subroutine state_getimport_4d_output(state, fldname, output, index, do_sum, ungr integer :: i, j, iblk, n, i1, j1 ! incides real(kind=dbl_kind), pointer :: dataPtr1d(:) ! mesh real(kind=dbl_kind), pointer :: dataPtr2d(:,:) ! mesh - real(kind=dbl_kind), pointer :: dataPtr3d(:,:,:) ! grid - real(kind=dbl_kind), pointer :: dataPtr4d(:,:,:,:) ! grid - character(len=*), parameter :: subname='(ice_import_export:state_getimport)' + character(len=*), parameter :: subname='(ice_import_export:state_getimport_4d)' ! ---------------------------------------------- rc = ESMF_SUCCESS @@ -1340,103 +1450,65 @@ subroutine state_getimport_4d_output(state, fldname, output, index, do_sum, ungr ! check that fieldname exists if (.not. State_FldChk(state, trim(fldname))) return - if (geomtype == ESMF_GEOMTYPE_MESH) then - - ! get field pointer - if (present(ungridded_index)) then - call state_getfldptr(state, trim(fldname), dataPtr2d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - call state_getfldptr(state, trim(fldname), dataPtr1d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + ! get field pointer + if (present(ungridded_index)) then + call state_getfldptr(state, trim(fldname), dataPtr2d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call state_getfldptr(state, trim(fldname), dataPtr1d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if - ! set values of output array - n=0 + ! set values of output array + n=0 + do iblk = 1, nblocks + this_block = get_block(blocks_ice(iblk),iblk) + ilo = this_block%ilo + ihi = this_block%ihi + jlo = this_block%jlo + jhi = this_block%jhi + do j = jlo, jhi + do i = ilo, ihi + n = n+1 + if (present(ungridded_index)) then + output(i,j,index,iblk) = dataPtr2d(ungridded_index,n) + else + output(i,j,index,iblk) = dataPtr1d(n) + end if + end do + end do + end do + if (present(areacor)) then + n = 0 do iblk = 1, nblocks this_block = get_block(blocks_ice(iblk),iblk) - ilo = this_block%ilo - ihi = this_block%ihi - jlo = this_block%jlo - jhi = this_block%jhi + ilo = this_block%ilo; ihi = this_block%ihi + jlo = this_block%jlo; jhi = this_block%jhi do j = jlo, jhi do i = ilo, ihi - n = n+1 - if (present(do_sum)) then ! do sum - if (present(ungridded_index)) then - output(i,j,index,iblk) = output(i,j,index, iblk) + dataPtr2d(ungridded_index,n) - else - output(i,j,index,iblk) = output(i,j,index, iblk) + dataPtr1d(n) - end if - else ! do not do sum - if (present(ungridded_index)) then - output(i,j,index,iblk) = dataPtr2d(ungridded_index,n) - else - output(i,j,index,iblk) = dataPtr1d(n) - end if - end if + n = n + 1 + output(i,j,index,iblk) = output(i,j,index,iblk) * areacor(n) end do end do end do - - else if (geomtype == ESMF_GEOMTYPE_GRID) then - - ! get field pointer - if (present(ungridded_index)) then - call state_getfldptr(state, trim(fldname), dataptr4d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - call state_getfldptr(state, trim(fldname), dataptr3d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - - ! set values of output array - do iblk = 1,nblocks - this_block = get_block(blocks_ice(iblk),iblk) - ilo = this_block%ilo - ihi = this_block%ihi - jlo = this_block%jlo - jhi = this_block%jhi - do j = jlo,jhi - do i = ilo,ihi - i1 = i - ilo + 1 - j1 = j - jlo + 1 - if (present(do_sum)) then - if (present(ungridded_index)) then - output(i,j,index,iblk) = output(i,j,index,iblk) + dataPtr4d(i1,j1,iblk,ungridded_index) - else - output(i,j,index,iblk) = output(i,j,index,iblk) + dataPtr3d(i1,j1,iblk) - end if - else - if (present(ungridded_index)) then - output(i,j,index,iblk) = dataPtr4d(i1,j1,iblk,ungridded_index) - else - output(i,j,index,iblk) = dataPtr3d(i1,j1,iblk) - end if - end if - end do - end do - end do - end if - end subroutine state_getimport_4d_output + end subroutine state_getimport_4d !=============================================================================== - - subroutine state_getimport_3d_output(state, fldname, output, do_sum, ungridded_index, rc) + subroutine state_getimport_3d(state, fldname, output, ungridded_index, areacor, rc) ! ---------------------------------------------- ! Map import state field to output array ! ---------------------------------------------- ! input/output variables - type(ESMF_State) , intent(in) :: state - character(len=*) , intent(in) :: fldname - real (kind=dbl_kind) , intent(inout) :: output(:,:,:) - logical, optional , intent(in) :: do_sum - integer, optional , intent(in) :: ungridded_index - integer , intent(out) :: rc + type(ESMF_State) , intent(in) :: state + character(len=*) , intent(in) :: fldname + real (kind=dbl_kind) , intent(inout) :: output(:,:,:) + integer, optional , intent(in) :: ungridded_index + real(kind=dbl_kind), optional , intent(in) :: areacor(:) + integer , intent(out) :: rc ! local variables type(block) :: this_block ! block information for current block @@ -1444,9 +1516,7 @@ subroutine state_getimport_3d_output(state, fldname, output, do_sum, ungridded_i integer :: i, j, iblk, n, i1, j1 ! incides real(kind=dbl_kind), pointer :: dataPtr1d(:) ! mesh real(kind=dbl_kind), pointer :: dataPtr2d(:,:) ! mesh - real(kind=dbl_kind), pointer :: dataPtr3d(:,:,:) ! grid - real(kind=dbl_kind), pointer :: dataPtr4d(:,:,:,:) ! grid - character(len=*) , parameter :: subname='(ice_import_export:state_getimport)' + character(len=*) , parameter :: subname='(ice_import_export:state_getimport_3d)' ! ---------------------------------------------- rc = ESMF_SUCCESS @@ -1454,83 +1524,53 @@ subroutine state_getimport_3d_output(state, fldname, output, do_sum, ungridded_i ! check that fieldname exists if (.not. State_FldChk(state, trim(fldname))) return - if (geomtype == ESMF_GEOMTYPE_MESH) then - - ! get field pointer - if (present(ungridded_index)) then - call state_getfldptr(state, trim(fldname), dataPtr2d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - call state_getfldptr(state, trim(fldname), dataPtr1d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + ! get field pointer + if (present(ungridded_index)) then + call state_getfldptr(state, trim(fldname), dataPtr2d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call state_getfldptr(state, trim(fldname), dataPtr1d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if - ! determine output array - n=0 + ! determine output array + n = 0 + do iblk = 1, nblocks + this_block = get_block(blocks_ice(iblk),iblk) + ilo = this_block%ilo + ihi = this_block%ihi + jlo = this_block%jlo + jhi = this_block%jhi + do j = jlo, jhi + do i = ilo, ihi + n = n+1 + if (present(ungridded_index)) then + output(i,j,iblk) = dataPtr2d(ungridded_index,n) + else + output(i,j,iblk) = dataPtr1d(n) + end if + end do + end do + end do + if (present(areacor)) then + n = 0 do iblk = 1, nblocks this_block = get_block(blocks_ice(iblk),iblk) - ilo = this_block%ilo - ihi = this_block%ihi - jlo = this_block%jlo - jhi = this_block%jhi + ilo = this_block%ilo; ihi = this_block%ihi + jlo = this_block%jlo; jhi = this_block%jhi do j = jlo, jhi do i = ilo, ihi - n = n+1 - if (present(do_sum) .and. present(ungridded_index)) then - output(i,j,iblk) = output(i,j,iblk) + dataPtr2d(ungridded_index,n) - else if (present(do_sum)) then - output(i,j,iblk) = output(i,j,iblk) + dataPtr1d(n) - else if (present(ungridded_index)) then - output(i,j,iblk) = dataPtr2d(ungridded_index,n) - else - output(i,j,iblk) = dataPtr1d(n) - end if - end do - end do - end do - - else if (geomtype == ESMF_GEOMTYPE_GRID) then - - ! get field pointer - if (present(ungridded_index)) then - call state_getfldptr(state, trim(fldname), dataptr4d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - call state_getfldptr(state, trim(fldname), dataptr3d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - - ! set values of output array - do iblk = 1,nblocks - this_block = get_block(blocks_ice(iblk),iblk) - ilo = this_block%ilo - ihi = this_block%ihi - jlo = this_block%jlo - jhi = this_block%jhi - do j = jlo,jhi - do i = ilo,ihi - i1 = i - ilo + 1 - j1 = j - jlo + 1 - if (present(do_sum) .and. present(ungridded_index)) then - output(i,j,iblk) = output(i,j,iblk) + dataPtr4d(i1,j1,iblk,ungridded_index) - else if (present(do_sum)) then - output(i,j,iblk) = output(i,j,iblk) + dataPtr3d(i1,j1,iblk) - else if (present(ungridded_index)) then - output(i,j,iblk) = dataPtr4d(i1,j1,iblk, ungridded_index) - else - output(i,j,iblk) = dataPtr3d(i1,j1,iblk) - end if + n = n + 1 + output(i,j,iblk) = output(i,j,iblk) * areacor(n) end do end do end do - end if - end subroutine state_getimport_3d_output + end subroutine state_getimport_3d !=============================================================================== - - subroutine state_setexport_4d_input(state, fldname, input, index, lmask, ifrac, ungridded_index, rc) + subroutine state_setexport_4d(state, fldname, input, index, lmask, ifrac, ungridded_index, areacor, rc) ! ---------------------------------------------- ! Map 4d input array to export state field @@ -1544,6 +1584,7 @@ subroutine state_setexport_4d_input(state, fldname, input, index, lmask, ifrac, logical , optional, intent(in) :: lmask(:,:,:) real(kind=dbl_kind) , optional, intent(in) :: ifrac(:,:,:) integer , optional, intent(in) :: ungridded_index + real(kind=dbl_kind) , optional, intent(in) :: areacor(:) integer , intent(out) :: rc ! local variables @@ -1552,9 +1593,8 @@ subroutine state_setexport_4d_input(state, fldname, input, index, lmask, ifrac, integer :: i, j, iblk, n, i1, j1 ! indices real(kind=dbl_kind), pointer :: dataPtr1d(:) ! mesh real(kind=dbl_kind), pointer :: dataPtr2d(:,:) ! mesh - real(kind=dbl_kind), pointer :: dataPtr3d(:,:,:) ! grid - real(kind=dbl_kind), pointer :: dataPtr4d(:,:,:,:) ! grid - character(len=*), parameter :: subname='(ice_import_export:state_setexport)' + integer :: ice_num + character(len=*), parameter :: subname='(ice_import_export:state_setexport_4d)' ! ---------------------------------------------- rc = ESMF_SUCCESS @@ -1562,93 +1602,81 @@ subroutine state_setexport_4d_input(state, fldname, input, index, lmask, ifrac, ! check that fieldname exists if (.not. State_FldChk(state, trim(fldname))) return - if (geomtype == ESMF_GEOMTYPE_MESH) then - - ! get field pointer - if (present(ungridded_index)) then - call state_getfldptr(state, trim(fldname), dataPtr2d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - call state_getfldptr(state, trim(fldname), dataPtr1d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! get field pointer + if (present(ungridded_index)) then + call state_getfldptr(state, trim(fldname), dataPtr2d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ungridded_index == 1) then + dataptr2d(:,:) = c0 end if - - ! set values of field pointer n = 0 do iblk = 1, nblocks this_block = get_block(blocks_ice(iblk),iblk) - ilo = this_block%ilo - ihi = this_block%ihi - jlo = this_block%jlo - jhi = this_block%jhi - do j = jlo, jhi - do i = ilo, ihi - n = n+1 - if (present(lmask) .and. present(ifrac)) then + ilo = this_block%ilo; ihi = this_block%ihi + jlo = this_block%jlo; jhi = this_block%jhi + if (present(lmask) .and. present(ifrac)) then + do j = jlo, jhi + do i = ilo, ihi + n = n+1 if ( lmask(i,j,iblk) .and. ifrac(i,j,iblk) > c0 ) then - if (present(ungridded_index)) then - dataPtr2d(ungridded_index,n) = input(i,j,index,iblk) - else - dataPtr1d(n) = input(i,j,index,iblk) - end if - end if - else - if (present(ungridded_index)) then dataPtr2d(ungridded_index,n) = input(i,j,index,iblk) else - dataPtr1d(n) = input(i,j,index,iblk) + dataPtr2d(ungridded_index,n) = c0 end if - end if + end do end do - end do + else + do j = jlo, jhi + do i = ilo, ihi + n = n+1 + dataPtr2d(ungridded_index,n) = input(i,j,index,iblk) + end do + end do + end if end do - - else if (geomtype == ESMF_GEOMTYPE_GRID) then - - if (present(ungridded_index)) then - call state_getfldptr(state, trim(fldname), dataptr4d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - call state_getfldptr(state, trim(fldname), dataptr3d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ice_num = n + if (present(areacor)) then + do n = 1,ice_num + dataPtr2d(ungridded_index,n) = dataPtr2d(ungridded_index,n) * areacor(n) + end do end if - - do iblk = 1,nblocks + else + call state_getfldptr(state, trim(fldname), dataPtr1d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + dataptr1d(:) = c0 + n = 0 + do iblk = 1, nblocks this_block = get_block(blocks_ice(iblk),iblk) - ilo = this_block%ilo - ihi = this_block%ihi - jlo = this_block%jlo - jhi = this_block%jhi - do j = jlo,jhi - do i = ilo,ihi - i1 = i - ilo + 1 - j1 = j - jlo + 1 - if (present(lmask) .and. present(ifrac)) then + ilo = this_block%ilo; ihi = this_block%ihi + jlo = this_block%jlo; jhi = this_block%jhi + if (present(lmask) .and. present(ifrac)) then + do j = jlo, jhi + do i = ilo, ihi + n = n+1 if ( lmask(i,j,iblk) .and. ifrac(i,j,iblk) > c0 ) then - if (present(ungridded_index)) then - dataPtr4d(i1,j1,iblk,ungridded_index) = input(i,j,index,iblk) - end if - else - dataPtr3d(i1,j1,iblk) = input(i,j,index,iblk) - end if - else - if (present(ungridded_index)) then - dataPtr4d(i1,j1,iblk,ungridded_index) = input(i,j,index,iblk) - else - dataPtr3d(i1,j1,iblk) = input(i,j,index,iblk) + dataPtr1d(n) = input(i,j,index,iblk) end if - end if + end do end do - end do + else + do i = ilo, ihi + n = n+1 + dataPtr1d(n) = input(i,j,index,iblk) + end do + end if end do - + ice_num = n + if (present(areacor)) then + do n = 1,ice_num + dataPtr1d(n) = dataPtr1d(n) * areacor(n) + end do + end if end if - end subroutine state_setexport_4d_input + end subroutine state_setexport_4d !=============================================================================== - - subroutine state_setexport_3d_input(state, fldname, input, lmask, ifrac, ungridded_index, rc) + subroutine state_setexport_3d(state, fldname, input, lmask, ifrac, ungridded_index, areacor, rc) ! ---------------------------------------------- ! Map 3d input array to export state field @@ -1661,6 +1689,7 @@ subroutine state_setexport_3d_input(state, fldname, input, lmask, ifrac, ungridd logical , optional , intent(in) :: lmask(:,:,:) real(kind=dbl_kind) , optional , intent(in) :: ifrac(:,:,:) integer , optional , intent(in) :: ungridded_index + real(kind=dbl_kind) , optional , intent(in) :: areacor(:) integer , intent(out) :: rc ! local variables @@ -1669,9 +1698,8 @@ subroutine state_setexport_3d_input(state, fldname, input, lmask, ifrac, ungridd integer :: i, j, iblk, n, i1, j1 ! incides real(kind=dbl_kind), pointer :: dataPtr1d(:) ! mesh real(kind=dbl_kind), pointer :: dataPtr2d(:,:) ! mesh - real(kind=dbl_kind), pointer :: dataPtr3d(:,:,:) ! grid - real(kind=dbl_kind), pointer :: dataPtr4d(:,:,:,:) ! grid - character(len=*), parameter :: subname='(ice_import_export:state_setexport)' + integer :: num_ice + character(len=*), parameter :: subname='(ice_import_export:state_setexport_3d)' ! ---------------------------------------------- rc = ESMF_SUCCESS @@ -1679,92 +1707,59 @@ subroutine state_setexport_3d_input(state, fldname, input, lmask, ifrac, ungridd ! check that fieldname exists if (.not. State_FldChk(state, trim(fldname))) return - if (geomtype == ESMF_GEOMTYPE_MESH) then - - ! get field pointer - if (present(ungridded_index)) then - call state_getfldptr(state, trim(fldname), dataPtr2d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - call state_getfldptr(state, trim(fldname), dataPtr1d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + ! get field pointer + if (present(ungridded_index)) then + call state_getfldptr(state, trim(fldname), dataPtr2d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call state_getfldptr(state, trim(fldname), dataPtr1d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if - n = 0 - do iblk = 1, nblocks - this_block = get_block(blocks_ice(iblk),iblk) - ilo = this_block%ilo - ihi = this_block%ihi - jlo = this_block%jlo - jhi = this_block%jhi - do j = jlo, jhi - do i = ilo, ihi - n = n+1 - if (present(lmask) .and. present(ifrac)) then - if ( lmask(i,j,iblk) .and. ifrac(i,j,iblk) > c0 ) then - if (present(ungridded_index)) then - dataPtr2d(ungridded_index,n) = input(i,j,iblk) - else - dataPtr1d(n) = input(i,j,iblk) - end if - end if - else + n = 0 + do iblk = 1, nblocks + this_block = get_block(blocks_ice(iblk),iblk) + ilo = this_block%ilo + ihi = this_block%ihi + jlo = this_block%jlo + jhi = this_block%jhi + do j = jlo, jhi + do i = ilo, ihi + n = n+1 + if (present(lmask) .and. present(ifrac)) then + if ( lmask(i,j,iblk) .and. ifrac(i,j,iblk) > c0 ) then if (present(ungridded_index)) then dataPtr2d(ungridded_index,n) = input(i,j,iblk) else dataPtr1d(n) = input(i,j,iblk) end if end if - end do + else + if (present(ungridded_index)) then + dataPtr2d(ungridded_index,n) = input(i,j,iblk) + else + dataPtr1d(n) = input(i,j,iblk) + end if + end if end do end do - - else if (geomtype == ESMF_GEOMTYPE_GRID) then - - ! get field pointer + end do + num_ice = n + if (present(areacor)) then if (present(ungridded_index)) then - call state_getfldptr(state, trim(fldname), dataptr4d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + do n = 1,num_ice + dataPtr2d(:,n) = dataPtr2d(:,n) * areacor(n) + end do else - call state_getfldptr(state, trim(fldname), dataptr3d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - - do iblk = 1,nblocks - this_block = get_block(blocks_ice(iblk),iblk) - ilo = this_block%ilo - ihi = this_block%ihi - jlo = this_block%jlo - jhi = this_block%jhi - do j = jlo,jhi - do i = ilo,ihi - i1 = i - ilo + 1 - j1 = j - jlo + 1 - if (present(lmask) .and. present(ifrac)) then - if ( lmask(i,j,iblk) .and. ifrac(i,j,iblk) > c0 ) then - if (present(ungridded_index)) then - dataPtr4d(i1,j1,iblk,ungridded_index) = input(i,j,iblk) - else - dataPtr3d(i1,j1,iblk) = input(i,j,iblk) - end if - end if - else - if (present(ungridded_index)) then - dataPtr4d(i1,j1,iblk,ungridded_index) = input(i,j,iblk) - else - dataPtr3d(i1,j1,iblk) = input(i,j,iblk) - end if - end if - end do + do n = 1,num_ice + dataPtr1d(n) = dataPtr1d(n) * areacor(n) end do - end do - + end if end if - end subroutine state_setexport_3d_input + end subroutine state_setexport_3d !=============================================================================== - subroutine State_GetFldPtr_1d(State, fldname, fldptr, rc) ! ---------------------------------------------- ! Get pointer to a state field @@ -1788,10 +1783,10 @@ subroutine State_GetFldPtr_1d(State, fldname, fldptr, rc) call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + end subroutine State_GetFldPtr_1d !=============================================================================== - subroutine State_GetFldPtr_2d(State, fldname, fldptr, rc) ! ---------------------------------------------- ! Get pointer to a state field @@ -1815,60 +1810,7 @@ subroutine State_GetFldPtr_2d(State, fldname, fldptr, rc) call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - end subroutine State_GetFldPtr_2d - - !=============================================================================== - - subroutine State_GetFldPtr_3d(State, fldname, fldptr, rc) - ! ---------------------------------------------- - ! Get pointer to a state field - ! ---------------------------------------------- - - ! input/output variables - type(ESMF_State) , intent(in) :: State - character(len=*) , intent(in) :: fldname - real(kind=dbl_kind) , pointer , intent(inout) :: fldptr(:,:,:) - integer , optional , intent(out) :: rc - - ! local variables - type(ESMF_Field) :: lfield - character(len=*),parameter :: subname='(ice_import_export:State_GetFldPtr_3d)' - ! ---------------------------------------------- - - rc = ESMF_SUCCESS - - call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end subroutine State_GetFldPtr_3d - !=============================================================================== - - subroutine State_GetFldPtr_4d(State, fldname, fldptr, rc) - ! ---------------------------------------------- - ! Get pointer to a state field - ! ---------------------------------------------- - - ! input/output variables - type(ESMF_State) , intent(in) :: State - character(len=*) , intent(in) :: fldname - real(kind=dbl_kind) , pointer , intent(inout) :: fldptr(:,:,:,:) - integer , optional , intent(out) :: rc - - ! local variables - type(ESMF_Field) :: lfield - character(len=*),parameter :: subname='(ice_import_export:State_GetFldPtr_3d)' - ! ---------------------------------------------- - - rc = ESMF_SUCCESS - - call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end subroutine State_GetFldPtr_4d + end subroutine State_GetFldPtr_2d end module ice_import_export diff --git a/cicecore/drivers/nuopc/cmeps/ice_mesh_mod.F90 b/cicecore/drivers/nuopc/cmeps/ice_mesh_mod.F90 index ae0a2d070..fffe575de 100644 --- a/cicecore/drivers/nuopc/cmeps/ice_mesh_mod.F90 +++ b/cicecore/drivers/nuopc/cmeps/ice_mesh_mod.F90 @@ -202,7 +202,7 @@ subroutine ice_mesh_set_distgrid(localpet, npes, distgrid, rc) deallocate(gindex) end subroutine ice_mesh_set_distgrid - + !======================================================================= subroutine ice_mesh_setmask_from_maskfile(ice_maskfile, ice_mesh, rc) @@ -427,17 +427,17 @@ subroutine ice_mesh_create_scolumn(scol_lon, scol_lat, ice_mesh, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Allocate module variable ocn_gridcell_frac - allocate(ocn_gridcell_frac(2,2,1)) + allocate(ocn_gridcell_frac(nx_block,ny_block,max_blocks)) ocn_gridcell_frac(:,:,:) = scol_frac - + end subroutine ice_mesh_create_scolumn !=============================================================================== subroutine ice_mesh_init_tlon_tlat_area_hm() use ice_grid , only : tlon, tlat, hm, tarea, ULON, ULAT, HTN, HTE, ANGLE, ANGLET - use ice_grid , only : uarea, uarear, tarear!, tinyarea - use ice_grid , only : dxT, dyT, dxU, dyU + use ice_grid , only : uarea, uarear, tarear, tinyarea + use ice_grid , only : dxt, dyt, dxu, dyu, dyhx, dxhy, cyp, cxp, cym, cxm use ice_grid , only : makemask use ice_boundary , only : ice_HaloUpdate use ice_domain , only : blocks_ice, nblocks, halo_info, distrb_info @@ -517,7 +517,7 @@ subroutine ice_mesh_init_tlon_tlat_area_hm() endif tarear(i,j,iblk) = c1/tarea(i,j,iblk) uarear(i,j,iblk) = c1/uarea(i,j,iblk) -! tinyarea(i,j,iblk) = puny*tarea(i,j,iblk) + tinyarea(i,j,iblk) = puny*tarea(i,j,iblk) if (.not. single_column) then if (ny_global == 1) then @@ -531,10 +531,16 @@ subroutine ice_mesh_init_tlon_tlat_area_hm() HTN (i,j,iblk) = 1.e36_dbl_kind HTE (i,j,iblk) = 1.e36_dbl_kind - dxT (i,j,iblk) = 1.e36_dbl_kind - dyT (i,j,iblk) = 1.e36_dbl_kind - dxU (i,j,iblk) = 1.e36_dbl_kind - dyU (i,j,iblk) = 1.e36_dbl_kind + dxt (i,j,iblk) = 1.e36_dbl_kind + dyt (i,j,iblk) = 1.e36_dbl_kind + dxu (i,j,iblk) = 1.e36_dbl_kind + dyu (i,j,iblk) = 1.e36_dbl_kind + dxhy (i,j,iblk) = 1.e36_dbl_kind + dyhx (i,j,iblk) = 1.e36_dbl_kind + cyp (i,j,iblk) = 1.e36_dbl_kind + cxp (i,j,iblk) = 1.e36_dbl_kind + cym (i,j,iblk) = 1.e36_dbl_kind + cxm (i,j,iblk) = 1.e36_dbl_kind enddo enddo enddo @@ -553,8 +559,8 @@ subroutine ice_mesh_check(gcomp, ice_mesh, rc) ! Check CICE mesh - use ice_constants, only : c1,c0,c180,c360 - use ice_grid , only : tlon, tlat, hm + use ice_constants, only : c1,c0,c360 + use ice_grid , only : tlon, tlat ! input/output parameters type(ESMF_GridComp) , intent(inout) :: gcomp @@ -563,8 +569,7 @@ subroutine ice_mesh_check(gcomp, ice_mesh, rc) ! local variables type(ESMF_DistGrid) :: distGrid - type(ESMF_Array) :: elemMaskArray - integer :: n,i,j ! indices + integer :: n,c,g,i,j,m ! indices integer :: iblk, jblk ! indices integer :: ilo, ihi, jlo, jhi ! beginning and end of physical domain type(block) :: this_block ! block information for current block @@ -573,15 +578,11 @@ subroutine ice_mesh_check(gcomp, ice_mesh, rc) real(dbl_kind), pointer :: ownedElemCoords(:) real(dbl_kind), pointer :: lat(:), latMesh(:) real(dbl_kind), pointer :: lon(:), lonMesh(:) - integer , pointer :: model_mask(:) real(dbl_kind) :: diff_lon real(dbl_kind) :: diff_lat real(dbl_kind) :: rad_to_deg - real(dbl_kind) :: eps_imesh + real(dbl_kind) :: tmplon, eps_imesh logical :: isPresent, isSet - logical :: mask_error - integer :: mask_internal - integer :: mask_file character(len=char_len_long) :: cvalue character(len=char_len_long) :: logmsg character(len=*), parameter :: subname = ' ice_mesh_check: ' @@ -605,7 +606,7 @@ subroutine ice_mesh_check(gcomp, ice_mesh, rc) allocate(ownedElemCoords(spatialDim*numownedelements)) allocate(lonmesh(numOwnedElements)) allocate(latmesh(numOwnedElements)) - call ESMF_MeshGet(ice_mesh, ownedElemCoords=ownedElemCoords, rc=rc) + call ESMF_MeshGet(ice_mesh, ownedElemCoords=ownedElemCoords) if (ChkErr(rc,__LINE__,u_FILE_u)) return do n = 1,numOwnedElements lonMesh(n) = ownedElemCoords(2*n-1) @@ -631,63 +632,26 @@ subroutine ice_mesh_check(gcomp, ice_mesh, rc) lon(n) = tlon(i,j,iblk)*rad_to_deg lat(n) = tlat(i,j,iblk)*rad_to_deg + tmplon = lon(n) + if(tmplon < c0)tmplon = tmplon + c360 + ! error check differences between internally generated lons and those read in - diff_lon = mod(abs(lonMesh(n) - lon(n)),360.0) - if (diff_lon > c180) then - diff_lon = diff_lon - c360 - endif - if (abs(diff_lon) > eps_imesh ) then - write(6,100)n,lonMesh(n),lon(n), diff_lon - call abort_ice(error_message=subname, file=__FILE__, line=__LINE__) + diff_lon = abs(mod(lonMesh(n) - tmplon,360.0)) + if (diff_lon > eps_imesh ) then + write(6,100)n,lonMesh(n),tmplon, diff_lon + !call abort_ice(error_message=subname, file=__FILE__, line=__LINE__) end if diff_lat = abs(latMesh(n) - lat(n)) if (diff_lat > eps_imesh) then write(6,101)n,latMesh(n),lat(n), diff_lat - call abort_ice(error_message=subname, file=__FILE__, line=__LINE__) + !call abort_ice(error_message=subname, file=__FILE__, line=__LINE__) end if enddo enddo enddo - ! obtain internally generated ice mask for error checks - allocate(model_mask(numOwnedElements)) - call ESMF_MeshGet(ice_mesh, elementdistGrid=distGrid, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - elemMaskArray = ESMF_ArrayCreate(distGrid, model_mask, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_MeshGet(ice_mesh, elemMaskArray=elemMaskArray, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - mask_error = .false. - n=0 - do iblk = 1, nblocks - this_block = get_block(blocks_ice(iblk),iblk) - ilo = this_block%ilo - ihi = this_block%ihi - jlo = this_block%jlo - jhi = this_block%jhi - do j = jlo, jhi - do i = ilo, ihi - n = n + 1 - mask_internal = nint(hm(i,j,iblk),kind=dbl_kind) - mask_file = model_mask(n) - if (mask_internal /= mask_file) then - write(6,102) n,mask_internal,mask_file - mask_error = .true. - end if - enddo !i - enddo !j - enddo !iblk - if (mask_error) then - call abort_ice(error_message=subname, file=__FILE__, line=__LINE__) - end if - - call ESMF_ArrayDestroy(elemMaskArray, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - -100 format('ERROR: CICE n, mesh_lon , lon, diff_lon = ',i8,2(f21.13,3x),d21.5) -101 format('ERROR: CICE n, mesh_lat , lat, diff_lat = ',i8,2(f21.13,3x),d21.5) -102 format('ERROR: CICE n, mesh_internal, mask_file = ',i8,2(i2,2x)) +100 format('ERROR: CICE n, lonmesh, lon, diff_lon = ',i6,2(f21.13,3x),d21.5) +101 format('ERROR: CICE n, latmesh, lat, diff_lat = ',i6,2(f21.13,3x),d21.5) ! deallocate memory deallocate(ownedElemCoords) diff --git a/cicecore/shared/ice_init_column.F90 b/cicecore/shared/ice_init_column.F90 index 664d88e5a..82031abc7 100644 --- a/cicecore/shared/ice_init_column.F90 +++ b/cicecore/shared/ice_init_column.F90 @@ -1300,27 +1300,28 @@ subroutine input_zbgc ! read from input file !----------------------------------------------------------------- - call get_fileunit(nu_nml) - if (my_task == master_task) then + write(nu_diag,*) subname,' Reading zbgc_nml' + + call get_fileunit(nu_nml) open (nu_nml, file=trim(nml_filename), status='old',iostat=nml_error) if (nml_error /= 0) then - nml_error = -1 - else - nml_error = 1 - endif + call abort_ice(subname//'ERROR: zbgc_nml open file '// & + trim(nml_filename), & + file=__FILE__, line=__LINE__) + endif - print*,'Reading zbgc_nml' + nml_error = 1 do while (nml_error > 0) read(nu_nml, nml=zbgc_nml,iostat=nml_error) end do - if (nml_error == 0) close(nu_nml) - endif - call broadcast_scalar(nml_error, master_task) - if (nml_error /= 0) then - call abort_ice(subname//'ERROR: reading zbgc namelist') + if (nml_error /= 0) then + call abort_ice(subname//'ERROR: zbgc_nml reading ', & + file=__FILE__, line=__LINE__) + endif + close(nu_nml) + call release_fileunit(nu_nml) endif - call release_fileunit(nu_nml) !----------------------------------------------------------------- ! broadcast diff --git a/configuration/scripts/cice.batch.csh b/configuration/scripts/cice.batch.csh index 024270039..f86b55502 100755 --- a/configuration/scripts/cice.batch.csh +++ b/configuration/scripts/cice.batch.csh @@ -91,7 +91,26 @@ cat >> ${jobfile} << EOFB #PBS -l walltime=${batchtime} EOFB -else if (${ICE_MACHINE} =~ gordon* || ${ICE_MACHINE} =~ conrad* || ${ICE_MACHINE} =~ gaffney* || ${ICE_MACHINE} =~ koehr* || ${ICE_MACHINE} =~ mustang) then +else if (${ICE_MACHINE} =~ gordon* || ${ICE_MACHINE} =~ conrad* || ${ICE_MACHINE} =~ gaffney* || ${ICE_MACHINE} =~ koehr* || ${ICE_MACHINE} =~ mustang*) then +cat >> ${jobfile} << EOFB +#PBS -N ${shortcase} +#PBS -q ${queue} +#PBS -A ${acct} +#PBS -l select=${nnodes}:ncpus=${maxtpn}:mpiprocs=${taskpernode} +#PBS -l walltime=${batchtime} +#PBS -j oe +#PBS -W umask=022 +###PBS -M username@domain.com +###PBS -m be +EOFB + +else if (${ICE_MACHINE} =~ narwhal*) then +if (${runlength} <= 0) then + set batchtime = "00:29:59" + set queue = "debug" +else + set queue = "standard" +endif cat >> ${jobfile} << EOFB #PBS -N ${shortcase} #PBS -q ${queue} diff --git a/configuration/scripts/cice.launch.csh b/configuration/scripts/cice.launch.csh index 40b8996b4..a63c802ed 100755 --- a/configuration/scripts/cice.launch.csh +++ b/configuration/scripts/cice.launch.csh @@ -58,7 +58,7 @@ EOFR endif #======= -else if (${ICE_MACHINE} =~ onyx*) then +else if (${ICE_MACHINE} =~ onyx* || ${ICE_MACHINE} =~ narwhal) then cat >> ${jobfile} << EOFR aprun -n ${ntasks} -N ${taskpernodelimit} -d ${nthrds} ./cice >&! \$ICE_RUNLOG_FILE EOFR diff --git a/configuration/scripts/machines/Macros.narwhal_aocc b/configuration/scripts/machines/Macros.narwhal_aocc index b22aeda64..44b1dc2f6 100644 --- a/configuration/scripts/machines/Macros.narwhal_aocc +++ b/configuration/scripts/machines/Macros.narwhal_aocc @@ -3,7 +3,7 @@ #============================================================================== CPP := ftn -E -CPPDEFS := -DFORTRANUNDERSCORE -DNO_R16 ${ICE_CPPDEFS} +CPPDEFS := -DNO_R16 -DFORTRANUNDERSCORE ${ICE_CPPDEFS} CFLAGS := -c -O2 FIXEDFLAGS := -ffixed-form @@ -49,7 +49,7 @@ INCLDIR := $(INCLDIR) ifeq ($(ICE_THREADED), true) LDFLAGS += -mp -# CFLAGS += -mp + CFLAGS += -mp FFLAGS += -mp else LDFLAGS += -nomp diff --git a/configuration/scripts/machines/Macros.narwhal_cray b/configuration/scripts/machines/Macros.narwhal_cray index 8496f7a9b..ab0e6378e 100644 --- a/configuration/scripts/machines/Macros.narwhal_cray +++ b/configuration/scripts/machines/Macros.narwhal_cray @@ -3,7 +3,7 @@ #============================================================================== CPP := ftn -e P -CPPDEFS := -DFORTRANUNDERSCORE -DNO_R16 ${ICE_CPPDEFS} +CPPDEFS := -DFORTRANUNDERSCORE ${ICE_CPPDEFS} CFLAGS := -c -O2 FIXEDFLAGS := -132 diff --git a/configuration/scripts/machines/env.narwhal_aocc b/configuration/scripts/machines/env.narwhal_aocc old mode 100644 new mode 100755 index 875296520..a392f9363 --- a/configuration/scripts/machines/env.narwhal_aocc +++ b/configuration/scripts/machines/env.narwhal_aocc @@ -14,31 +14,32 @@ module unload PrgEnv-cray module unload PrgEnv-gnu module unload PrgEnv-intel module unload PrgEnv-nvidia -module load PrgEnv-aocc -module load cpe/22.03 -module load aocc/3.0.0 -module unload cray-pals -module load cray-pals/1.2.2 +module load PrgEnv-aocc/8.1.0 +module load cray-pals/1.0.17 +module load bct-env/0.1 +module unload aocc +module load aocc/2.2.0.1 +module unload cray-mpich +module load cray-mpich/8.1.5 + module unload cray-hdf5 module unload cray-hdf5-parallel module unload cray-netcdf-hdf5parallel module unload cray-parallel-netcdf module unload netcdf -module load cray-netcdf/4.8.1.1 -module load cray-hdf5/1.12.1.1 +module load cray-netcdf/4.7.4.4 +module load cray-hdf5/1.12.0.4 setenv NETCDF_PATH ${NETCDF_DIR} limit coredumpsize unlimited limit stacksize unlimited -setenv OMP_STACKSIZE 128M -setenv OMP_WAIT_POLICY PASSIVE endif setenv ICE_MACHINE_MACHNAME narwhal -setenv ICE_MACHINE_MACHINFO "Cray EX AMD EPYC 7H12 2.6GHz, Slingshot-10 Interconnect" +setenv ICE_MACHINE_MACHINFO "Cray EX AMD EPYC 7H12" setenv ICE_MACHINE_ENVNAME intel -setenv ICE_MACHINE_ENVINFO "aocc_3.0.0-Build#78 2020_12_10 clang/flang 12.0.0, cray-mpich/8.1.14, netcdf/4.8.1.1" +setenv ICE_MACHINE_ENVINFO "aocc_3.0.0-Build#78 2020_12_10 clang/flang 12.0.0, cray-mpich/8.1.9, netcdf/4.7.4.4" setenv ICE_MACHINE_MAKE gmake setenv ICE_MACHINE_WKDIR $WORKDIR/CICE_RUNS setenv ICE_MACHINE_INPUTDATA /p/work1/projects/RASM/cice_consortium diff --git a/configuration/scripts/machines/env.narwhal_cray b/configuration/scripts/machines/env.narwhal_cray old mode 100644 new mode 100755 index a9e5bd14a..eb9e42bb2 --- a/configuration/scripts/machines/env.narwhal_cray +++ b/configuration/scripts/machines/env.narwhal_cray @@ -14,30 +14,33 @@ module unload PrgEnv-cray module unload PrgEnv-gnu module unload PrgEnv-intel module unload PrgEnv-nvidia -module load PrgEnv-cray -module load cpe/22.03 -module unload cray-pals -module load cray-pals/1.2.2 +module load PrgEnv-cray/8.1.0 +module load cray-pals/1.0.17 +module load bct-env/0.1 +module unload cce +module load cce/12.0.3 +module unload cray-mpich +module load cray-mpich/8.1.9 + module unload cray-hdf5 module unload cray-hdf5-parallel module unload cray-netcdf-hdf5parallel module unload cray-parallel-netcdf module unload netcdf -module load cray-netcdf/4.8.1.1 -module load cray-hdf5/1.12.1.1 +module load cray-netcdf/4.7.4.4 +module load cray-hdf5/1.12.0.4 setenv NETCDF_PATH ${NETCDF_DIR} limit coredumpsize unlimited limit stacksize unlimited -setenv OMP_STACKSIZE 128M -setenv OMP_WAIT_POLICY PASSIVE +setenv OMP_WAIT_POLICY passive endif setenv ICE_MACHINE_MACHNAME narwhal -setenv ICE_MACHINE_MACHINFO "Cray EX AMD EPYC 7H12 2.6GHz, Slingshot-10 Interconnect" +setenv ICE_MACHINE_MACHINFO "Cray EX AMD EPYC 7H12" setenv ICE_MACHINE_ENVNAME cray -setenv ICE_MACHINE_ENVINFO "cce 13.0.2, cray-mpich/8.1.14, netcdf/4.8.1.1" +setenv ICE_MACHINE_ENVINFO "cce 12.0.3, cray-mpich/8.1.9, netcdf/4.7.4.4" setenv ICE_MACHINE_MAKE gmake setenv ICE_MACHINE_WKDIR $WORKDIR/CICE_RUNS setenv ICE_MACHINE_INPUTDATA /p/work1/projects/RASM/cice_consortium diff --git a/configuration/scripts/machines/env.narwhal_gnu b/configuration/scripts/machines/env.narwhal_gnu old mode 100644 new mode 100755 index 701920161..4df81b957 --- a/configuration/scripts/machines/env.narwhal_gnu +++ b/configuration/scripts/machines/env.narwhal_gnu @@ -14,30 +14,32 @@ module unload PrgEnv-cray module unload PrgEnv-gnu module unload PrgEnv-intel module unload PrgEnv-nvidia -module load PrgEnv-gnu -module load cpe/22.03 -module unload cray-pals -module load cray-pals/1.2.2 +module load PrgEnv-gnu/8.1.0 +module load cray-pals/1.0.17 +module load bct-env/0.1 +module unload gcc +module load gcc/11.2.0 +module unload cray-mpich +module load cray-mpich/8.1.9 + module unload cray-hdf5 module unload cray-hdf5-parallel module unload cray-netcdf-hdf5parallel module unload cray-parallel-netcdf module unload netcdf -module load cray-netcdf/4.8.1.1 -module load cray-hdf5/1.12.1.1 +module load cray-netcdf/4.7.4.4 +module load cray-hdf5/1.12.0.4 setenv NETCDF_PATH ${NETCDF_DIR} limit coredumpsize unlimited limit stacksize unlimited -setenv OMP_STACKSIZE 128M -setenv OMP_WAIT_POLICY PASSIVE endif setenv ICE_MACHINE_MACHNAME narwhal -setenv ICE_MACHINE_MACHINFO "Cray EX AMD EPYC 7H12 2.6GHz, Slingshot-10 Interconnect" -setenv ICE_MACHINE_ENVNAME gnu -setenv ICE_MACHINE_ENVINFO "gnu c/fortran 11.2.0 20210728, cray-mpich/8.1.14, netcdf/4.8.1.1" +setenv ICE_MACHINE_MACHINFO "Cray EX AMD EPYC 7H12" +setenv ICE_MACHINE_ENVNAME intel +setenv ICE_MACHINE_ENVINFO "gnu fortran/c 11.2.0, cray-mpich/8.1.9, netcdf/4.7.4.4" setenv ICE_MACHINE_MAKE gmake setenv ICE_MACHINE_WKDIR $WORKDIR/CICE_RUNS setenv ICE_MACHINE_INPUTDATA /p/work1/projects/RASM/cice_consortium diff --git a/configuration/scripts/machines/env.narwhal_intel b/configuration/scripts/machines/env.narwhal_intel old mode 100644 new mode 100755 index 4cc60acac..2cdf4f93c --- a/configuration/scripts/machines/env.narwhal_intel +++ b/configuration/scripts/machines/env.narwhal_intel @@ -14,30 +14,32 @@ module unload PrgEnv-cray module unload PrgEnv-gnu module unload PrgEnv-intel module unload PrgEnv-nvidia -module load PrgEnv-intel -module load cpe/22.03 -module unload cray-pals -module load cray-pals/1.2.2 +module load PrgEnv-intel/8.0.0 +module load cray-pals/1.0.17 +module load bct-env/0.1 +module unload intel +module load intel/2021.1 +module unload cray-mpich +module load cray-mpich/8.1.9 + module unload cray-hdf5 module unload cray-hdf5-parallel module unload cray-netcdf-hdf5parallel module unload cray-parallel-netcdf module unload netcdf -module load cray-netcdf/4.8.1.1 -module load cray-hdf5/1.12.1.1 +module load cray-netcdf/4.7.4.4 +module load cray-hdf5/1.12.0.4 setenv NETCDF_PATH ${NETCDF_DIR} limit coredumpsize unlimited limit stacksize unlimited -setenv OMP_STACKSIZE 128M -setenv OMP_WAIT_POLICY PASSIVE endif setenv ICE_MACHINE_MACHNAME narwhal -setenv ICE_MACHINE_MACHINFO "Cray EX AMD EPYC 7H12 2.6GHz, Slingshot-10 Interconnect" +setenv ICE_MACHINE_MACHINFO "Cray EX AMD EPYC 7H12" setenv ICE_MACHINE_ENVNAME intel -setenv ICE_MACHINE_ENVINFO "ifort 2021.4.0 20210910, cray-mpich/8.1.14, netcdf/4.8.1.1" +setenv ICE_MACHINE_ENVINFO "ifort 2021.1 Beta 20201112, cray-mpich/8.1.9, netcdf/4.7.4.4" setenv ICE_MACHINE_MAKE gmake setenv ICE_MACHINE_WKDIR $WORKDIR/CICE_RUNS setenv ICE_MACHINE_INPUTDATA /p/work1/projects/RASM/cice_consortium diff --git a/configuration/scripts/tests/perf_suite.ts b/configuration/scripts/tests/perf_suite.ts index a4d8ef588..859b9f21b 100644 --- a/configuration/scripts/tests/perf_suite.ts +++ b/configuration/scripts/tests/perf_suite.ts @@ -1,29 +1,27 @@ # Test Grid PEs Sets BFB-compare -smoke gx1 32x1x16x16x15 run2day,droundrobin +smoke gx1 1x1x320x384x1 run2day,droundrobin smoke gx1 64x1x16x16x8 run2day,droundrobin,thread +sleep 180 # -smoke gx1 1x1x320x384x1 run2day,droundrobin smoke_gx1_32x1x16x16x15_droundrobin_run2day -smoke gx1 1x1x160x192x4 run2day,droundrobin smoke_gx1_32x1x16x16x15_droundrobin_run2day -smoke gx1 1x1x80x96x16 run2day,droundrobin smoke_gx1_32x1x16x16x15_droundrobin_run2day -smoke gx1 1x1x40x48x64 run2day,droundrobin smoke_gx1_32x1x16x16x15_droundrobin_run2day -smoke gx1 1x1x20x24x256 run2day,droundrobin smoke_gx1_32x1x16x16x15_droundrobin_run2day +smoke gx1 1x1x320x384x1 run2day,droundrobin +smoke gx1 1x1x160x192x4 run2day,droundrobin smoke_gx1_1x1x320x384x1_droundrobin_run2day +smoke gx1 1x1x80x96x16 run2day,droundrobin smoke_gx1_1x1x320x384x1_droundrobin_run2day +smoke gx1 1x1x40x48x64 run2day,droundrobin smoke_gx1_1x1x320x384x1_droundrobin_run2day +smoke gx1 1x1x20x24x256 run2day,droundrobin smoke_gx1_1x1x320x384x1_droundrobin_run2day # -smoke gx1 1x1x16x16x480 run2day,droundrobin smoke_gx1_32x1x16x16x15_droundrobin_run2day -smoke gx1 2x1x16x16x240 run2day,droundrobin smoke_gx1_32x1x16x16x15_droundrobin_run2day -smoke gx1 4x1x16x16x120 run2day,droundrobin smoke_gx1_32x1x16x16x15_droundrobin_run2day -smoke gx1 8x1x16x16x60 run2day,droundrobin smoke_gx1_32x1x16x16x15_droundrobin_run2day -smoke gx1 16x1x16x16x30 run2day,droundrobin smoke_gx1_32x1x16x16x15_droundrobin_run2day -#smoke gx1 32x1x16x16x15 run2day,droundrobin -smoke gx1 64x1x16x16x8 run2day,droundrobin smoke_gx1_32x1x16x16x15_droundrobin_run2day -smoke gx1 128x1x16x16x4 run2day,droundrobin smoke_gx1_32x1x16x16x15_droundrobin_run2day +smoke gx1 1x1x16x16x480 run2day,droundrobin smoke_gx1_1x1x320x384x1_droundrobin_run2day +smoke gx1 2x1x16x16x240 run2day,droundrobin smoke_gx1_1x1x320x384x1_droundrobin_run2day +smoke gx1 4x1x16x16x120 run2day,droundrobin smoke_gx1_1x1x320x384x1_droundrobin_run2day +smoke gx1 8x1x16x16x60 run2day,droundrobin smoke_gx1_1x1x320x384x1_droundrobin_run2day +smoke gx1 16x1x16x16x30 run2day,droundrobin smoke_gx1_1x1x320x384x1_droundrobin_run2day +smoke gx1 32x1x16x16x15 run2day,droundrobin smoke_gx1_1x1x320x384x1_droundrobin_run2day +smoke gx1 64x1x16x16x8 run2day,droundrobin smoke_gx1_1x1x320x384x1_droundrobin_run2day +smoke gx1 128x1x16x16x4 run2day,droundrobin smoke_gx1_1x1x320x384x1_droundrobin_run2day # -smoke gx1 64x1x16x16x8 run2day,droundrobin smoke_gx1_32x1x16x16x15_droundrobin_run2day -#smoke gx1 64x1x16x16x8 run2day,droundrobin,thread +smoke gx1 64x1x16x16x8 run2day,droundrobin smoke_gx1_1x1x320x384x1_droundrobin_run2day +smoke gx1 64x1x16x16x8 run2day,droundrobin,thread smoke gx1 32x2x16x16x16 run2day,droundrobin smoke_gx1_64x1x16x16x8_droundrobin_run2day_thread smoke gx1 16x4x16x16x32 run2day,droundrobin smoke_gx1_64x1x16x16x8_droundrobin_run2day_thread smoke gx1 8x8x16x16x64 run2day,droundrobin smoke_gx1_64x1x16x16x8_droundrobin_run2day_thread smoke gx1 4x16x16x16x128 run2day,droundrobin smoke_gx1_64x1x16x16x8_droundrobin_run2day_thread -smoke gx1 32x2x16x16x16 run2day,droundrobin,ompscheds smoke_gx1_64x1x16x16x8_droundrobin_run2day_thread -smoke gx1 32x2x16x16x16 run2day,droundrobin,ompschedd1 smoke_gx1_64x1x16x16x8_droundrobin_run2day_thread -smoke gx1 32x2x16x16x16 run2day,droundrobin,ompscheds1 smoke_gx1_64x1x16x16x8_droundrobin_run2day_thread #