From 2fe5224543c49c77c45fbca7d36a908543850231 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 23 Mar 2020 20:28:05 -0600 Subject: [PATCH 001/103] updates to clean up differences between nems and cmeps for restarts --- config_src/nuopc_driver/mom_cap.F90 | 894 ++++++++-------------------- 1 file changed, 246 insertions(+), 648 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 219245e473..ba3c3e80d8 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -70,6 +70,8 @@ module MOM_cap_mod use ESMF, only: ESMF_MESHLOC_ELEMENT, ESMF_RC_VAL_OUTOFRANGE, ESMF_StateGet use ESMF, only: ESMF_TimePrint, ESMF_AlarmSet, ESMF_FieldGet, ESMF_Array use ESMF, only: ESMF_ArrayCreate +use ESMF, only: ESMF_RC_FILE_OPEN, ESMF_RC_FILE_READ, ESMF_RC_FILE_WRITE +use ESMF, only: ESMF_VMBroadcast use ESMF, only: operator(==), operator(/=), operator(+), operator(-) ! TODO ESMF_GridCompGetInternalState does not have an explicit Fortran interface. @@ -258,95 +260,54 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) ! Switch to IPDv03 by filtering all other phaseMap entries call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, & acceptStringList=(/"IPDv03p"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return write_diagnostics = .false. call NUOPC_CompAttributeGet(gcomp, name="DumpFields", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) write_diagnostics=(trim(value)=="true") write(logmsg,*) write_diagnostics - call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO) overwrite_timeslice = .false. call NUOPC_CompAttributeGet(gcomp, name="OverwriteSlice", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) overwrite_timeslice=(trim(value)=="true") write(logmsg,*) overwrite_timeslice - call ESMF_LogWrite('MOM_cap:OverwriteSlice = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:OverwriteSlice = '//trim(logmsg), ESMF_LOGMSG_INFO) profile_memory = .false. call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) profile_memory=(trim(value)=="true") write(logmsg,*) profile_memory - call ESMF_LogWrite('MOM_cap:ProfileMemory = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ProfileMemory = '//trim(logmsg), ESMF_LOGMSG_INFO) grid_attach_area = .false. call NUOPC_CompAttributeGet(gcomp, name="GridAttachArea", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) grid_attach_area=(trim(value)=="true") write(logmsg,*) grid_attach_area - call ESMF_LogWrite('MOM_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO) scalar_field_name = "" call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then scalar_field_name = trim(value) - call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO) endif scalar_field_count = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_count if (iostat /= 0) then @@ -356,20 +317,13 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_count - call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO) endif scalar_field_idx_grid_nx = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_idx_grid_nx if (iostat /= 0) then @@ -379,20 +333,13 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_idx_grid_nx - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO) endif scalar_field_idx_grid_ny = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_idx_grid_ny if (iostat /= 0) then @@ -402,20 +349,9 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_idx_grid_ny - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) endif - call NUOPC_CompAttributeAdd(gcomp, & - attrList=(/'RestartFileToRead', 'RestartFileToWrite'/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - end subroutine !> Called by NUOPC to advertise import and export fields. "Advertise" @@ -462,6 +398,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) logical :: isPresent, isPresentDiro, isPresentLogfile, isSet logical :: existflag integer :: userRc + integer :: localPet + integer :: iostat + integer :: readunit character(len=512) :: restartfile ! Path/Name of restart file character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar @@ -469,11 +408,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) rc = ESMF_SUCCESS - call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO) allocate(Ice_ocean_boundary) !allocate(ocean_state) ! ocean_model_init allocate this pointer @@ -484,34 +419,19 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state call ESMF_VMGetCurrent(vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_VMGet(VM, mpiCommunicator=mpi_comm_mom, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_ClockGet(CLOCK, currTIME=MyTime, TimeStep=TINT, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_TimeGet (MyTime, YY=YEAR, MM=MONTH, DD=DAY, H=HOUR, M=MINUTE, S=SECOND, RC=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return CALL ESMF_TimeIntervalGet(TINT, S=DT_OCEAN, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call fms_init(mpi_comm_mom) call constants_init @@ -521,10 +441,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) calendar select case (trim(calendar)) @@ -558,16 +475,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! get start/reference time call ESMF_ClockGet(CLOCK, refTime=MyTime, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_TimeGet (MyTime, YY=YEAR, MM=MONTH, DD=DAY, H=HOUR, M=MINUTE, S=SECOND, RC=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return time0 = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) @@ -583,27 +494,15 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (is_root_pe()) then call NUOPC_CompAttributeGet(gcomp, name="diro", & isPresent=isPresentDiro, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call NUOPC_CompAttributeGet(gcomp, name="logfile", & isPresent=isPresentLogfile, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresentDiro .and. isPresentLogfile) then - call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) else logunit = output_unit @@ -615,19 +514,11 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) starttype = "" call NUOPC_CompAttributeGet(gcomp, name='start_type', value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) starttype else - call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', & - ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', ESMF_LOGMSG_INFO) endif runtype = "" @@ -645,58 +536,44 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) endif if (len_trim(runtype) > 0) then - call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) endif restartfile = "" if (runtype == "initial") then - ! startup (new run) - 'n' is needed below if we don't specify input_filename in input.nml + restartfile = "n" - else if (runtype == "continue") then ! hybrid or branch or continuos runs - ! optionally call into system-specific implementation to get restart file name - call ESMF_MethodExecute(gcomp, label="GetRestartFileToRead", & - existflag=existflag, userRc=userRc, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg="Error executing user method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (ESMF_LogFoundError(rcToCheck=userRc, msg="Error in method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (existflag) then - call ESMF_LogWrite('MOM_cap: called user GetRestartFileToRead', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif + else if (runtype == "continue") then ! hybrid or branch or continuos runs - call NUOPC_CompAttributeGet(gcomp, name='RestartFileToRead', & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - if (isPresent .and. isSet) then - restartfile = trim(cvalue) - call ESMF_LogWrite('MOM_cap: RestartFileToRead = '//trim(restartfile), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (cesm_coupled) then + call ESMF_LogWrite('MOM_cap: restart requested, using rpointer.ocn', ESMF_LOGMSG_WARNING) + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + if (localPet == 0) then + ! this hard coded for rpointer.ocn right now + open(newunit=readunit, file='rpointer.ocn', form='formatted', status='old', iostat=iostat) + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + read(readunit,'(a)', iostat=iostat) restartfile + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + close(readunit) + endif + ! broadcast attribute set on master task to all tasks + call ESMF_VMBroadcast(vm, restartfile, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return else - call ESMF_LogWrite('MOM_cap: restart requested, no RestartFileToRead attribute provided-will use input.nml',& - ESMF_LOGMSG_WARNING, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) endif endif @@ -905,10 +782,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !---------------------------------------------------------------------------- call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -919,16 +793,9 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !---------------------------------------------------------------------------- call ESMF_VMGetCurrent(vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_VMGet(vm, petCount=npet, mpiCommunicator=mpicom, localPet=localPet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return !--------------------------------- ! global mom grid size @@ -936,11 +803,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call mpp_get_global_domain(ocean_public%domain, xsize=nxg, ysize=nyg) write(tmpstr,'(a,2i6)') subname//' nxg,nyg = ',nxg,nyg - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) !--------------------------------- ! number of tiles per PET, assumed to be 1, and number of pes (tiles) total @@ -949,19 +812,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ntiles=mpp_get_ntile_count(ocean_public%domain) ! this is tiles on this pe if (ntiles /= 1) then rc = ESMF_FAILURE - call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR) endif ntiles=mpp_get_domain_npes(ocean_public%domain) write(tmpstr,'(a,1i6)') subname//' ntiles = ',ntiles - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) !--------------------------------- ! get start and end indices of each tile and their PET @@ -973,11 +828,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (debug > 0) then do n = 1,ntiles write(tmpstr,'(a,6i6)') subname//' tiles ',n,pe(n),xb(n),xe(n),yb(n),ye(n) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) enddo endif @@ -1010,23 +861,14 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) enddo DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! read in the mesh call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (localPet == 0) then write(logunit,*)'mesh file for mom6 domain is ',trim(cvalue) @@ -1034,17 +876,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! recreate the mesh using the above distGrid EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! Check for consistency of lat, lon and mask between mesh and mom6 grid call ESMF_MeshGet(Emesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return allocate(ownedElemCoords(spatialDim*numOwnedElements)) allocate(lonMesh(numOwnedElements), lon(numOwnedElements)) @@ -1062,15 +898,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) end do elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) n = 0 @@ -1117,16 +948,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deallocate(maskMesh, mask) ! realize the import and export fields using the mesh call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", mesh=Emesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return else if (geomtype == ESMF_GEOMTYPE_GRID) then @@ -1148,19 +973,16 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deBlockList(2,2,n) = ye(n) petMap(n) = pe(n) ! write(tmpstr,'(a,3i8)') subname//' iglo = ',n,deBlockList(1,1,n),deBlockList(1,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) ! write(tmpstr,'(a,3i8)') subname//' jglo = ',n,deBlockList(2,1,n),deBlockList(2,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) ! write(tmpstr,'(a,2i8)') subname//' pe = ',n,petMap(n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) !--- assume a tile with starting index of 1 has an equivalent wraparound tile on the other side enddo delayout = ESMF_DELayoutCreate(petMap, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! rsd this assumes tripole grid, but sometimes in CESM a bipole ! grid is used -- need to introduce conditional logic here @@ -1171,18 +993,12 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & tileIndexB=1, positionVector=(/nxg+1, 2*nyg+1/), & orientationVector=(/-1, -2/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! periodic boundary condition along first dimension call ESMF_DistGridConnectionSet(connectionList(2), tileIndexA=1, & tileIndexB=1, positionVector=(/nxg, 0/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/nxg,nyg/), & ! indexflag = ESMF_INDEX_DELOCAL, & @@ -1191,10 +1007,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) delayout=delayout, & connectionList=connectionList, & rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return deallocate(xb,xe,yb,ye,pe) deallocate(connectionList) @@ -1203,32 +1016,18 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deallocate(petMap) call ESMF_DistGridGet(distgrid=distgrid, localDE=0, elementCount=cnt, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return allocate(indexList(cnt)) write(tmpstr,'(a,i8)') subname//' distgrid cnt= ',cnt - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) call ESMF_DistGridGet(distgrid=distgrid, localDE=0, seqIndexList=indexList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return write(tmpstr,'(a,4i8)') subname//' distgrid list= ',& indexList(1),indexList(cnt),minval(indexList), maxval(indexList) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) deallocate(IndexList) @@ -1238,91 +1037,55 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), & coordSys = ESMF_COORDSYS_SPH_DEG, & rc = rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_MASK, itemTypeKind=ESMF_TYPEKIND_I4, & staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! Attach area to the Grid optionally. By default the cell areas are computed. if(grid_attach_area) then call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_AREA, itemTypeKind=ESMF_TYPEKIND_R8, & staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return endif call ESMF_GridGetCoord(gridIn, coordDim=1, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_xcen, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridGetCoord(gridIn, coordDim=2, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_ycen, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridGetCoord(gridIn, coordDim=1, & staggerloc=ESMF_STAGGERLOC_CORNER, & farrayPtr=dataPtr_xcor, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridGetCoord(gridIn, coordDim=2, & staggerloc=ESMF_STAGGERLOC_CORNER, & farrayPtr=dataPtr_ycor, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_MASK, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_mask, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if(grid_attach_area) then call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_AREA, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_area, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return endif ! load up area, mask, center and corner values @@ -1345,13 +1108,13 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ubnd4 = ubound(dataPtr_xcor,2) write(tmpstr,*) subname//' iscjsc = ',isc,iec,jsc,jec - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' lbub12 = ',lbnd1,ubnd1,lbnd2,ubnd2 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' lbub34 = ',lbnd3,ubnd3,lbnd4,ubnd4 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) if (iec-isc /= ubnd1-lbnd1 .or. jec-jsc /= ubnd2-lbnd2) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & @@ -1390,38 +1153,32 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) enddo write(tmpstr,*) subname//' mask = ',minval(dataPtr_mask),maxval(dataPtr_mask) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) if(grid_attach_area) then write(tmpstr,*) subname//' area = ',minval(dataPtr_area),maxval(dataPtr_area) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) endif write(tmpstr,*) subname//' xcen = ',minval(dataPtr_xcen),maxval(dataPtr_xcen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' ycen = ',minval(dataPtr_ycen),maxval(dataPtr_ycen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' xcor = ',minval(dataPtr_xcor),maxval(dataPtr_xcor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' ycor = ',minval(dataPtr_ycor),maxval(dataPtr_ycor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) gridOut = gridIn ! for now out same as in call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", grid=gridIn, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return endif @@ -1432,18 +1189,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (len_trim(scalar_field_name) > 0) then call State_SetScalar(dble(nxg),scalar_field_idx_grid_nx, exportState, localPet, & scalar_field_name, scalar_field_count, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call State_SetScalar(dble(nyg),scalar_field_idx_grid_ny, exportState, localPet, & scalar_field_name, scalar_field_count, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return endif !--------------------------------- @@ -1489,16 +1239,10 @@ subroutine DataInitialize(gcomp, rc) ! query the Component for its clock, importState and exportState call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -1506,48 +1250,27 @@ subroutine DataInitialize(gcomp, rc) call get_ocean_grid(ocean_state, ocean_grid) call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_StateGet(exportState, itemCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return allocate(fieldNameList(fieldCount)) call ESMF_StateGet(exportState, itemNameList=fieldNameList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return do n=1, fieldCount call ESMF_StateGet(exportState, itemName=fieldNameList(n), field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return enddo deallocate(fieldNameList) ! check whether all Fields in the exportState are "Updated" if (NUOPC_IsUpdated(exportState)) then call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="true", rc=rc) - - call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO) endif if(write_diagnostics) then @@ -1596,6 +1319,11 @@ subroutine ModelAdvance(gcomp, rc) integer :: seconds, day, year, month, hour, minute character(ESMF_MAXSTR) :: restartname, cvalue character(240) :: msgString + character(ESMF_MAXSTR) :: casename + integer :: iostat + integer :: writeunit + integer :: localPet + type(ESMF_VM) :: vm character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' rc = ESMF_SUCCESS @@ -1604,45 +1332,21 @@ subroutine ModelAdvance(gcomp, rc) call shr_file_setLogUnit (logunit) ! query the Component for its clock, importState and exportState - call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, & - exportState=exportState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! HERE THE MODEL ADVANCES: currTime -> currTime + timeStep - call ESMF_ClockPrint(clock, options="currTime", & - preString="------>Advancing OCN from: ", unit=msgString, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_LogWrite(subname//trim(msgString), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_ClockPrint(clock, options="currTime", preString="------>Advancing OCN from: ", unit=msgString, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_LogWrite(subname//trim(msgString), ESMF_LOGMSG_INFO) - call ESMF_ClockGet(clock, startTime=startTime, currTime=currTime, & - timeStep=timeStep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_ClockGet(clock, startTime=startTime, currTime=currTime, timeStep=timeStep, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - call ESMF_TimePrint(currTime + timeStep, & - preString="--------------------------------> to: ", unit=msgString, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_TimePrint(currTime + timeStep, preString="--------------------------------> to: ", unit=msgString, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) Time_step_coupled = esmf2fms_time(timeStep) Time = esmf2fms_time(currTime) @@ -1656,11 +1360,7 @@ subroutine ModelAdvance(gcomp, rc) ! Do not call MOM6 timestepping routine if the first cpl tstep of a startup run if (currTime == startTime) then - call ESMF_LogWrite("MOM6 - Skipping the first coupling timestep", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM6 - Skipping the first coupling timestep", ESMF_LOGMSG_INFO) do_advance = .false. else do_advance = .true. @@ -1669,18 +1369,9 @@ subroutine ModelAdvance(gcomp, rc) if (do_advance) then ! If the second cpl tstep of a startup run, step back a cpl tstep and advance for two cpl tsteps if (currTime == startTime + timeStep) then - call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO) Time = esmf2fms_time(currTime-timeStep) ! i.e., startTime - - call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO) Time_step_coupled = 2 * esmf2fms_time(timeStep) endif end if @@ -1691,10 +1382,7 @@ subroutine ModelAdvance(gcomp, rc) if (do_advance) then call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -1707,10 +1395,7 @@ subroutine ModelAdvance(gcomp, rc) if (write_diagnostics) then call NUOPC_Write(importState, fileNamePrefix='field_ocn_import_', & overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return import_slice = import_slice + 1 endif @@ -1725,10 +1410,7 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return !--------------- ! Update MOM6 @@ -1743,10 +1425,7 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return endif @@ -1755,78 +1434,67 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (ESMF_AlarmIsRinging(alarm, rc=rc)) then - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_AlarmRingerOff(alarm, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! call into system specific method to get desired restart filename - restartname = "" - call ESMF_MethodExecute(gcomp, label="GetRestartFileToWrite", & - existflag=existflag, userRc=userRc, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg="Error executing user method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - if (ESMF_LogFoundError(rcToCheck=userRc, msg="Error in method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (existflag) then - call ESMF_LogWrite("MOM_cap: called user GetRestartFileToWrite method", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call NUOPC_CompAttributeGet(gcomp, name='RestartFileToWrite', & - isPresent=isPresent, isSet=isSet, value=cvalue, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (isPresent .and. isSet) then - restartname = trim(cvalue) - call ESMF_LogWrite("MOM_cap: User RestartFileToWrite: "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + if (cesm_coupled) then + call NUOPC_CompAttributeGet(gcomp, name='case_name', value=casename, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') & + trim(casename), year, month, day, seconds + if (localPet == 0) then + ! Write name of restart file in the rpointer file - this is currently hard-coded for the ocean + open(newunit=writeunit, file='rpointer.ocn', form='formatted', status='unknown', iostat=iostat) + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, & + msg=subname//' ERROR opening rpointer.ocn', line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + write(writeunit,'(a)') trim(restartname)//'.nc' + close(writeunit) endif - endif - - if (len_trim(restartname) == 0) then - ! none provided, so use a default restart filename - call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, & - h=hour, m=minute, s=seconds, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + else write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & "ocn", year, month, day, hour, minute, seconds - call ESMF_LogWrite("MOM_cap: Using default restart filename: "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + endif + call ESMF_LogWrite("MOM_cap: Using restart filename: "//trim(restartname), ESMF_LOGMSG_INFO) + + ! TODO: address if this requirement is being met for the DA group + ! Optionally write restart files when currTime-startTime is integer multiples of restart_interval + ! if (restart_interval > 0 ) then + ! time_elapsed = currTime - startTime + ! call ESMF_TimeIntervalGet(time_elapsed, s_i8=time_elapsed_sec, rc=rc) + ! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + ! n_interval = time_elapsed_sec / restart_interval + ! if ((n_interval .gt. 0) .and. (n_interval*restart_interval == time_elapsed_sec)) then + ! time_restart_current = esmf2fms_time(currTime) + ! timestamp = date_to_string(time_restart_current) + ! call ESMF_LogWrite("MOM: Writing restart at "//trim(timestamp), ESMF_LOGMSG_INFO, rc=rc) + ! write(*,*) 'calling ocean_model_restart' + ! call ocean_model_restart(ocean_state, timestamp) + ! endif + ! endif + + ! write restart file(s) + call ocean_model_restart(ocean_state, restartname=restartname) + + if (is_root_pe()) then + write(logunit,*) subname//' writing restart file ',trim(restartname) endif ! TODO: address if this requirement is being met for the DA group @@ -1863,10 +1531,7 @@ subroutine ModelAdvance(gcomp, rc) if (write_diagnostics) then call NUOPC_Write(exportState, fileNamePrefix='field_ocn_export_', & overwrite=overwrite_timeslice,timeslice=export_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return export_slice = export_slice + 1 endif @@ -1899,22 +1564,13 @@ subroutine ModelSetRunClock(gcomp, rc) ! query the Component for its clock, importState and exportState call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return !-------------------------------- ! check that the current time in the model and driver are the same @@ -1922,17 +1578,9 @@ subroutine ModelSetRunClock(gcomp, rc) if (mcurrtime /= dcurrtime) then call ESMF_TimeGet(dcurrtime, timeString=dtimestring, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_TimeGet(mcurrtime, timeString=mtimestring, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & msg=subname//": ERROR in time consistency: "//trim(dtimestring)//" != "//trim(mtimestring), & line=__LINE__, file=__FILE__, rcToReturn=rc) @@ -1946,49 +1594,47 @@ subroutine ModelSetRunClock(gcomp, rc) mstoptime = mcurrtime + dtimestep call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (first_time) then !-------------------------------- ! set restart alarm !-------------------------------- - ! defaults + ! set ddefaults restart_n = 0 restart_ymd = 0 - call NUOPC_CompAttributeGet(gcomp, name="restart_option", isPresent=isPresent, & - isSet=isSet, value=restart_option, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + ! If restart_option is set then must also have set either restart_n or restart_ymd if (isPresent .and. isSet) then - call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_n endif call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_ymd endif + if (restart_n == 0 .and. restart_ymd == 0) then + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & + msg=subname//": ERROR both restart_n and restart_ymd are zero for restart_option set ", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + end if else restart_option = "none" endif + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) + ! initialize restart alarm call AlarmInit(mclock, & alarm = restart_alarm, & option = trim(restart_option), & @@ -1996,25 +1642,12 @@ subroutine ModelSetRunClock(gcomp, rc) opt_ymd = restart_ymd, & RefTime = mcurrTime, & alarmname = 'alarm_restart', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - first_time = .false. - - call ESMF_LogWrite(subname//" Set restart option = "//restart_option, & - ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + first_time = .false. endif !-------------------------------- @@ -2022,16 +1655,10 @@ subroutine ModelSetRunClock(gcomp, rc) !-------------------------------- call ESMF_ClockAdvance(mclock,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return end subroutine ModelSetRunClock @@ -2162,58 +1789,37 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) if (field_defs(i)%shortname == scalar_field_name) then - call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected on root pe.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) + call ESMF_LogWrite(subname//tag//" Field "//trim(field_defs(i)%stdname)//" is connected on root pe.", & + ESMF_LOGMSG_INFO) call SetScalarField(field, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return else call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) + ESMF_LOGMSG_INFO) if (present(grid)) then field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, indexflag=ESMF_INDEX_DELOCAL, & name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! initialize fldptr to zero call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return fldptr2d(:,:) = 0.0 else if (present(mesh)) then field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! initialize fldptr to zero call ESMF_FieldGet(field, farrayPtr=fldptr1d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return fldptr1d(:) = 0.0 endif @@ -2222,24 +1828,16 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) ! Realize connected field call NUOPC_Realize(state, field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return else ! field is not connected call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is not connected.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) + ESMF_LOGMSG_INFO) + ! remove a not connected Field from State call ESMF_StateRemove(state, (/field_defs(i)%shortname/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return endif From 1a6411f0c0a83e35b1613e0e829b408d0bf09fc8 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 6 Apr 2020 20:52:33 -0600 Subject: [PATCH 002/103] added changes to unify cap with EMC changes --- config_src/nuopc_driver/mom_cap.F90 | 1008 ++++++++++++++++++++------- 1 file changed, 745 insertions(+), 263 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index ba3c3e80d8..26cff18324 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -72,6 +72,9 @@ module MOM_cap_mod use ESMF, only: ESMF_ArrayCreate use ESMF, only: ESMF_RC_FILE_OPEN, ESMF_RC_FILE_READ, ESMF_RC_FILE_WRITE use ESMF, only: ESMF_VMBroadcast +use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag +use ESMF, only: ESMF_AlarmGet, ESMF_AlarmIsCreated, ESMF_ALARMLIST_ALL, ESMF_AlarmIsEnabled +use ESMF, only: ESMF_STATEITEM_NOTFOUND, ESMF_FieldWrite use ESMF, only: operator(==), operator(/=), operator(+), operator(-) ! TODO ESMF_GridCompGetInternalState does not have an explicit Fortran interface. @@ -83,16 +86,17 @@ module MOM_cap_mod use NUOPC, only: NUOPC_Advertise, NUOPC_SetAttribute, NUOPC_IsUpdated, NUOPC_Write use NUOPC, only: NUOPC_IsConnected, NUOPC_Realize, NUOPC_CompAttributeSet use NUOPC_Model, only: NUOPC_ModelGet -use NUOPC_Model, & - model_routine_SS => SetServices, & - model_label_Advance => label_Advance, & - model_label_DataInitialize => label_DataInitialize, & - model_label_SetRunClock => label_SetRunClock, & - model_label_Finalize => label_Finalize +use NUOPC_Model, only: model_routine_SS => SetServices +use NUOPC_Model, only: model_label_Advance => label_Advance +use NUOPC_Model, only: model_label_DataInitialize => label_DataInitialize +use NUOPC_Model, only: model_label_SetRunClock => label_SetRunClock +use NUOPC_Model, only: model_label_Finalize => label_Finalize +use NUOPC_Model, only: SetVM implicit none; private public SetServices +public SetVM !> Internal state type with pointers to three types defined by MOM. type ocean_internalstate_type @@ -260,54 +264,95 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) ! Switch to IPDv03 by filtering all other phaseMap entries call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, & acceptStringList=(/"IPDv03p"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return write_diagnostics = .false. call NUOPC_CompAttributeGet(gcomp, name="DumpFields", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) write_diagnostics=(trim(value)=="true") write(logmsg,*) write_diagnostics - call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return overwrite_timeslice = .false. call NUOPC_CompAttributeGet(gcomp, name="OverwriteSlice", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) overwrite_timeslice=(trim(value)=="true") write(logmsg,*) overwrite_timeslice - call ESMF_LogWrite('MOM_cap:OverwriteSlice = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:OverwriteSlice = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return profile_memory = .false. call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) profile_memory=(trim(value)=="true") write(logmsg,*) profile_memory - call ESMF_LogWrite('MOM_cap:ProfileMemory = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:ProfileMemory = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return grid_attach_area = .false. call NUOPC_CompAttributeGet(gcomp, name="GridAttachArea", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) grid_attach_area=(trim(value)=="true") write(logmsg,*) grid_attach_area - call ESMF_LogWrite('MOM_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return scalar_field_name = "" call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) then scalar_field_name = trim(value) - call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif scalar_field_count = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_count if (iostat /= 0) then @@ -317,13 +362,20 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_count - call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif scalar_field_idx_grid_nx = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_idx_grid_nx if (iostat /= 0) then @@ -333,13 +385,20 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_idx_grid_nx - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif scalar_field_idx_grid_ny = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_idx_grid_ny if (iostat /= 0) then @@ -349,7 +408,11 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_idx_grid_ny - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif end subroutine @@ -400,7 +463,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) integer :: userRc integer :: localPet integer :: iostat - integer :: readunit + integer :: readunit character(len=512) :: restartfile ! Path/Name of restart file character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar @@ -408,7 +471,11 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) rc = ESMF_SUCCESS - call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return allocate(Ice_ocean_boundary) !allocate(ocean_state) ! ocean_model_init allocate this pointer @@ -419,19 +486,34 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state call ESMF_VMGetCurrent(vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_VMGet(VM, mpiCommunicator=mpi_comm_mom, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_ClockGet(CLOCK, currTIME=MyTime, TimeStep=TINT, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_TimeGet (MyTime, YY=YEAR, MM=MONTH, DD=DAY, H=HOUR, M=MINUTE, S=SECOND, RC=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out CALL ESMF_TimeIntervalGet(TINT, S=DT_OCEAN, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call fms_init(mpi_comm_mom) call constants_init @@ -441,7 +523,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out if (isPresent .and. isSet) then read(cvalue,*) calendar select case (trim(calendar)) @@ -475,10 +560,16 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! get start/reference time call ESMF_ClockGet(CLOCK, refTime=MyTime, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_TimeGet (MyTime, YY=YEAR, MM=MONTH, DD=DAY, H=HOUR, M=MINUTE, S=SECOND, RC=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out time0 = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) @@ -494,15 +585,27 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (is_root_pe()) then call NUOPC_CompAttributeGet(gcomp, name="diro", & isPresent=isPresentDiro, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call NUOPC_CompAttributeGet(gcomp, name="logfile", & isPresent=isPresentLogfile, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresentDiro .and. isPresentLogfile) then - call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) else logunit = output_unit @@ -514,11 +617,19 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) starttype = "" call NUOPC_CompAttributeGet(gcomp, name='start_type', value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) then read(cvalue,*) starttype else - call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', & + ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif runtype = "" @@ -536,7 +647,11 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) endif if (len_trim(runtype) > 0) then - call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif restartfile = "" @@ -555,26 +670,26 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (localPet == 0) then ! this hard coded for rpointer.ocn right now - open(newunit=readunit, file='rpointer.ocn', form='formatted', status='old', iostat=iostat) - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening rpointer.ocn', & - line=__LINE__, file=u_FILE_u, rcToReturn=rc) - return - endif - read(readunit,'(a)', iostat=iostat) restartfile - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & - line=__LINE__, file=u_FILE_u, rcToReturn=rc) - return - endif - close(readunit) - endif - ! broadcast attribute set on master task to all tasks - call ESMF_VMBroadcast(vm, restartfile, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - else - call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) - endif + open(newunit=readunit, file='rpointer.ocn', form='formatted', status='old', iostat=iostat) + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + read(readunit,'(a)', iostat=iostat) restartfile + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + close(readunit) + endif + ! broadcast attribute set on master task to all tasks + call ESMF_VMBroadcast(vm, restartfile, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + else + call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) + endif endif @@ -782,7 +897,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !---------------------------------------------------------------------------- call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -793,9 +911,16 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !---------------------------------------------------------------------------- call ESMF_VMGetCurrent(vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_VMGet(vm, petCount=npet, mpiCommunicator=mpicom, localPet=localPet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out !--------------------------------- ! global mom grid size @@ -803,7 +928,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call mpp_get_global_domain(ocean_public%domain, xsize=nxg, ysize=nyg) write(tmpstr,'(a,2i6)') subname//' nxg,nyg = ',nxg,nyg - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out !--------------------------------- ! number of tiles per PET, assumed to be 1, and number of pes (tiles) total @@ -812,11 +941,19 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ntiles=mpp_get_ntile_count(ocean_public%domain) ! this is tiles on this pe if (ntiles /= 1) then rc = ESMF_FAILURE - call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR) + call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif ntiles=mpp_get_domain_npes(ocean_public%domain) write(tmpstr,'(a,1i6)') subname//' ntiles = ',ntiles - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return !--------------------------------- ! get start and end indices of each tile and their PET @@ -828,7 +965,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (debug > 0) then do n = 1,ntiles write(tmpstr,'(a,6i6)') subname//' tiles ',n,pe(n),xb(n),xe(n),yb(n),ye(n) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return enddo endif @@ -861,14 +1002,23 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) enddo DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! read in the mesh call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (localPet == 0) then write(logunit,*)'mesh file for mom6 domain is ',trim(cvalue) @@ -876,11 +1026,17 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! recreate the mesh using the above distGrid EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! Check for consistency of lat, lon and mask between mesh and mom6 grid call ESMF_MeshGet(Emesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return allocate(ownedElemCoords(spatialDim*numOwnedElements)) allocate(lonMesh(numOwnedElements), lon(numOwnedElements)) @@ -898,10 +1054,15 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) end do elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) n = 0 @@ -948,10 +1109,16 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deallocate(maskMesh, mask) ! realize the import and export fields using the mesh call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", mesh=Emesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return else if (geomtype == ESMF_GEOMTYPE_GRID) then @@ -973,16 +1140,19 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deBlockList(2,2,n) = ye(n) petMap(n) = pe(n) ! write(tmpstr,'(a,3i8)') subname//' iglo = ',n,deBlockList(1,1,n),deBlockList(1,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) ! write(tmpstr,'(a,3i8)') subname//' jglo = ',n,deBlockList(2,1,n),deBlockList(2,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) ! write(tmpstr,'(a,2i8)') subname//' pe = ',n,petMap(n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) !--- assume a tile with starting index of 1 has an equivalent wraparound tile on the other side enddo delayout = ESMF_DELayoutCreate(petMap, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out ! rsd this assumes tripole grid, but sometimes in CESM a bipole ! grid is used -- need to introduce conditional logic here @@ -993,12 +1163,18 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & tileIndexB=1, positionVector=(/nxg+1, 2*nyg+1/), & orientationVector=(/-1, -2/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out ! periodic boundary condition along first dimension call ESMF_DistGridConnectionSet(connectionList(2), tileIndexA=1, & tileIndexB=1, positionVector=(/nxg, 0/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/nxg,nyg/), & ! indexflag = ESMF_INDEX_DELOCAL, & @@ -1007,7 +1183,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) delayout=delayout, & connectionList=connectionList, & rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return deallocate(xb,xe,yb,ye,pe) deallocate(connectionList) @@ -1016,18 +1195,32 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deallocate(petMap) call ESMF_DistGridGet(distgrid=distgrid, localDE=0, elementCount=cnt, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return allocate(indexList(cnt)) write(tmpstr,'(a,i8)') subname//' distgrid cnt= ',cnt - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_DistGridGet(distgrid=distgrid, localDE=0, seqIndexList=indexList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return write(tmpstr,'(a,4i8)') subname//' distgrid list= ',& indexList(1),indexList(cnt),minval(indexList), maxval(indexList) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return deallocate(IndexList) @@ -1037,55 +1230,91 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), & coordSys = ESMF_COORDSYS_SPH_DEG, & rc = rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return + call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_MASK, itemTypeKind=ESMF_TYPEKIND_I4, & staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! Attach area to the Grid optionally. By default the cell areas are computed. if(grid_attach_area) then call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_AREA, itemTypeKind=ESMF_TYPEKIND_R8, & staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return + endif call ESMF_GridGetCoord(gridIn, coordDim=1, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_xcen, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_GridGetCoord(gridIn, coordDim=2, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_ycen, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return + call ESMF_GridGetCoord(gridIn, coordDim=1, & staggerloc=ESMF_STAGGERLOC_CORNER, & farrayPtr=dataPtr_xcor, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_GridGetCoord(gridIn, coordDim=2, & staggerloc=ESMF_STAGGERLOC_CORNER, & farrayPtr=dataPtr_ycor, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_MASK, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_mask, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if(grid_attach_area) then call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_AREA, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_area, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif ! load up area, mask, center and corner values @@ -1108,13 +1337,13 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ubnd4 = ubound(dataPtr_xcor,2) write(tmpstr,*) subname//' iscjsc = ',isc,iec,jsc,jec - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) write(tmpstr,*) subname//' lbub12 = ',lbnd1,ubnd1,lbnd2,ubnd2 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) write(tmpstr,*) subname//' lbub34 = ',lbnd3,ubnd3,lbnd4,ubnd4 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) if (iec-isc /= ubnd1-lbnd1 .or. jec-jsc /= ubnd2-lbnd2) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & @@ -1153,32 +1382,38 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) enddo write(tmpstr,*) subname//' mask = ',minval(dataPtr_mask),maxval(dataPtr_mask) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) if(grid_attach_area) then write(tmpstr,*) subname//' area = ',minval(dataPtr_area),maxval(dataPtr_area) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) endif write(tmpstr,*) subname//' xcen = ',minval(dataPtr_xcen),maxval(dataPtr_xcen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) write(tmpstr,*) subname//' ycen = ',minval(dataPtr_ycen),maxval(dataPtr_ycen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) write(tmpstr,*) subname//' xcor = ',minval(dataPtr_xcor),maxval(dataPtr_xcor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) write(tmpstr,*) subname//' ycor = ',minval(dataPtr_ycor),maxval(dataPtr_ycor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) gridOut = gridIn ! for now out same as in call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", grid=gridIn, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif @@ -1189,11 +1424,18 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (len_trim(scalar_field_name) > 0) then call State_SetScalar(dble(nxg),scalar_field_idx_grid_nx, exportState, localPet, & scalar_field_name, scalar_field_count, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call State_SetScalar(dble(nyg),scalar_field_idx_grid_ny, exportState, localPet, & scalar_field_name, scalar_field_count, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return + endif !--------------------------------- @@ -1225,12 +1467,17 @@ subroutine DataInitialize(gcomp, rc) ! local variables type(ESMF_Clock) :: clock type(ESMF_State) :: importState, exportState + type(ESMF_Time) :: currTime + type(ESMF_TimeInterval) :: timeStep + type(ESMF_StateItem_Flag) :: itemType type (ocean_public_type), pointer :: ocean_public => NULL() type (ocean_state_type), pointer :: ocean_state => NULL() type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() type(ocean_internalstate_wrapper) :: ocean_internalstate type(ocean_grid_type), pointer :: ocean_grid character(240) :: msgString + character(240) :: fldname + character(240) :: timestr integer :: fieldCount, n type(ESMF_Field) :: field character(len=64),allocatable :: fieldNameList(:) @@ -1239,10 +1486,21 @@ subroutine DataInitialize(gcomp, rc) ! query the Component for its clock, importState and exportState call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call ESMF_ClockGet(clock, currTime=currTime, timeStep=timeStep, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_TimeGet(currTime, timestring=timestr, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -1250,38 +1508,66 @@ subroutine DataInitialize(gcomp, rc) call get_ocean_grid(ocean_state, ocean_grid) call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_StateGet(exportState, itemCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out allocate(fieldNameList(fieldCount)) call ESMF_StateGet(exportState, itemNameList=fieldNameList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out do n=1, fieldCount call ESMF_StateGet(exportState, itemName=fieldNameList(n), field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out enddo deallocate(fieldNameList) ! check whether all Fields in the exportState are "Updated" if (NUOPC_IsUpdated(exportState)) then call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="true", rc=rc) - call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO) - endif - - if(write_diagnostics) then - call NUOPC_Write(exportState, fileNamePrefix='field_init_ocn_export_', & - overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) + call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & return ! bail out endif + if(write_diagnostics) then + do n = 1,fldsFrOcn_num + fldname = fldsFrOcn(n)%shortname + call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(exportState, itemName=trim(fldname), field=field, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_FieldWrite(field, fileName='field_init_ocn_export_'//trim(timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + endif + enddo + endif + end subroutine DataInitialize !> Called by NUOPC to advance the model a single timestep. @@ -1297,13 +1583,15 @@ subroutine ModelAdvance(gcomp, rc) logical :: existflag, isPresent, isSet logical :: do_advance = .true. type(ESMF_Clock) :: clock!< ESMF Clock class definition - type(ESMF_Alarm) :: alarm + type(ESMF_Alarm) :: restart_alarm, stop_alarm type(ESMF_State) :: importState, exportState type(ESMF_Time) :: currTime type(ESMF_TimeInterval) :: timeStep type(ESMF_Time) :: startTime type(ESMF_TimeInterval) :: time_elapsed integer(ESMF_KIND_I8) :: n_interval, time_elapsed_sec + type(ESMF_Field) :: lfield + type(ESMF_StateItem_Flag) :: itemType character(len=64) :: timestamp type (ocean_public_type), pointer :: ocean_public => NULL() type (ocean_state_type), pointer :: ocean_state => NULL() @@ -1321,9 +1609,12 @@ subroutine ModelAdvance(gcomp, rc) character(240) :: msgString character(ESMF_MAXSTR) :: casename integer :: iostat - integer :: writeunit + integer :: writeunit integer :: localPet type(ESMF_VM) :: vm + integer :: n + character(240) :: import_timestr, export_timestr + character(len=128) :: fldname character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' rc = ESMF_SUCCESS @@ -1332,21 +1623,48 @@ subroutine ModelAdvance(gcomp, rc) call shr_file_setLogUnit (logunit) ! query the Component for its clock, importState and exportState - call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, & + exportState=exportState, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out ! HERE THE MODEL ADVANCES: currTime -> currTime + timeStep - call ESMF_ClockPrint(clock, options="currTime", preString="------>Advancing OCN from: ", unit=msgString, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - call ESMF_LogWrite(subname//trim(msgString), ESMF_LOGMSG_INFO) + call ESMF_ClockPrint(clock, options="currTime", & + preString="------>Advancing OCN from: ", unit=msgString, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_LogWrite(subname//trim(msgString), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - call ESMF_ClockGet(clock, startTime=startTime, currTime=currTime, timeStep=timeStep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_ClockGet(clock, startTime=startTime, currTime=currTime, & + timeStep=timeStep, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - call ESMF_TimePrint(currTime + timeStep, preString="--------------------------------> to: ", unit=msgString, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + call ESMF_TimePrint(currTime + timeStep, & + preString="--------------------------------> to: ", unit=msgString, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call ESMF_TimeGet(currTime, timestring=import_timestr, rc=rc) + call ESMF_TimeGet(currTime+timestep, timestring=export_timestr, rc=rc) Time_step_coupled = esmf2fms_time(timeStep) Time = esmf2fms_time(currTime) @@ -1360,7 +1678,11 @@ subroutine ModelAdvance(gcomp, rc) ! Do not call MOM6 timestepping routine if the first cpl tstep of a startup run if (currTime == startTime) then - call ESMF_LogWrite("MOM6 - Skipping the first coupling timestep", ESMF_LOGMSG_INFO) + call ESMF_LogWrite("MOM6 - Skipping the first coupling timestep", ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out do_advance = .false. else do_advance = .true. @@ -1369,9 +1691,18 @@ subroutine ModelAdvance(gcomp, rc) if (do_advance) then ! If the second cpl tstep of a startup run, step back a cpl tstep and advance for two cpl tsteps if (currTime == startTime + timeStep) then - call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO) + call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out Time = esmf2fms_time(currTime-timeStep) ! i.e., startTime - call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO) + + call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out Time_step_coupled = 2 * esmf2fms_time(timeStep) endif end if @@ -1382,7 +1713,10 @@ subroutine ModelAdvance(gcomp, rc) if (do_advance) then call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -1393,10 +1727,20 @@ subroutine ModelAdvance(gcomp, rc) !--------------- if (write_diagnostics) then - call NUOPC_Write(importState, fileNamePrefix='field_ocn_import_', & - overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - import_slice = import_slice + 1 + do n = 1,fldsToOcn_num + fldname = fldsToOcn(n)%shortname + call ESMF_StateGet(importState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(importState, itemName=trim(fldname), field=lfield, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_FieldWrite(lfield, fileName='field_ocn_import_'//trim(import_timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + endif + enddo endif !--------------- @@ -1410,7 +1754,10 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out !--------------- ! Update MOM6 @@ -1425,29 +1772,58 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out endif !--------------- - ! If restart alarm is ringing - write restart file + ! Get the stop alarm !--------------- - call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - if (ESMF_AlarmIsRinging(alarm, rc=rc)) then - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + !--------------- + ! If restart alarm exists and is ringing - write restart file + !--------------- - call ESMF_AlarmRingerOff(alarm, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - if (cesm_coupled) then + ! turn off the alarm + call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + ! determine restart filename + call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name='case_name', value=casename, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) @@ -1468,53 +1844,16 @@ subroutine ModelAdvance(gcomp, rc) write(writeunit,'(a)') trim(restartname)//'.nc' close(writeunit) endif - else - write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & - "ocn", year, month, day, hour, minute, seconds - endif - call ESMF_LogWrite("MOM_cap: Using restart filename: "//trim(restartname), ESMF_LOGMSG_INFO) - - ! TODO: address if this requirement is being met for the DA group - ! Optionally write restart files when currTime-startTime is integer multiples of restart_interval - ! if (restart_interval > 0 ) then - ! time_elapsed = currTime - startTime - ! call ESMF_TimeIntervalGet(time_elapsed, s_i8=time_elapsed_sec, rc=rc) - ! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - ! n_interval = time_elapsed_sec / restart_interval - ! if ((n_interval .gt. 0) .and. (n_interval*restart_interval == time_elapsed_sec)) then - ! time_restart_current = esmf2fms_time(currTime) - ! timestamp = date_to_string(time_restart_current) - ! call ESMF_LogWrite("MOM: Writing restart at "//trim(timestamp), ESMF_LOGMSG_INFO, rc=rc) - ! write(*,*) 'calling ocean_model_restart' - ! call ocean_model_restart(ocean_state, timestamp) - ! endif - ! endif - - ! write restart file(s) - call ocean_model_restart(ocean_state, restartname=restartname) - - if (is_root_pe()) then - write(logunit,*) subname//' writing restart file ',trim(restartname) - endif - - ! TODO: address if this requirement is being met for the DA group - ! Optionally write restart files when currTime-startTime is integer multiples of restart_interval - ! if (restart_interval > 0 ) then - ! time_elapsed = currTime - startTime - ! call ESMF_TimeIntervalGet(time_elapsed, s_i8=time_elapsed_sec, rc=rc) - ! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - ! line=__LINE__, & - ! file=__FILE__)) & - ! return ! bail out - ! n_interval = time_elapsed_sec / restart_interval - ! if ((n_interval .gt. 0) .and. (n_interval*restart_interval == time_elapsed_sec)) then - ! time_restart_current = esmf2fms_time(currTime) - ! timestamp = date_to_string(time_restart_current) - ! call ESMF_LogWrite("MOM: Writing restart at "//trim(timestamp), ESMF_LOGMSG_INFO, rc=rc) - ! write(*,*) 'calling ocean_model_restart' - ! call ocean_model_restart(ocean_state, timestamp) - ! endif - ! endif + else + ! write the final restart without a timestamp + if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then + write(restartname,'(A)')"MOM.res" + else + write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & + "MOM.res.", year, month, day, hour, minute, seconds + endif + end if + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) ! write restart file(s) call ocean_model_restart(ocean_state, restartname=restartname) @@ -1522,17 +1861,27 @@ subroutine ModelAdvance(gcomp, rc) if (is_root_pe()) then write(logunit,*) subname//' writing restart file ',trim(restartname) endif - endif + endif !--------------- ! Write diagnostics !--------------- if (write_diagnostics) then - call NUOPC_Write(exportState, fileNamePrefix='field_ocn_export_', & - overwrite=overwrite_timeslice,timeslice=export_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - export_slice = export_slice + 1 + do n = 1,fldsFrOcn_num + fldname = fldsFrOcn(n)%shortname + call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(exportState, itemName=trim(fldname), field=lfield, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_FieldWrite(lfield, fileName='field_ocn_export_'//trim(export_timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + endif + enddo endif if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ") @@ -1547,30 +1896,42 @@ subroutine ModelSetRunClock(gcomp, rc) ! local variables type(ESMF_Clock) :: mclock, dclock type(ESMF_Time) :: mcurrtime, dcurrtime - type(ESMF_Time) :: mstoptime + type(ESMF_Time) :: mstoptime, dstoptime type(ESMF_TimeInterval) :: mtimestep, dtimestep character(len=128) :: mtimestring, dtimestring character(len=256) :: cvalue character(len=256) :: restart_option ! Restart option units integer :: restart_n ! Number until restart interval integer :: restart_ymd ! Restart date (YYYYMMDD) - type(ESMF_ALARM) :: restart_alarm + type(ESMF_Alarm) :: restart_alarm + type(ESMF_Alarm) :: stop_alarm logical :: isPresent, isSet logical :: first_time = .true. character(len=*),parameter :: subname='MOM_cap:(ModelSetRunClock) ' + character(len=256) :: timestr !-------------------------------- rc = ESMF_SUCCESS ! query the Component for its clock, importState and exportState call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, & + stopTime=dstoptime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out !-------------------------------- ! check that the current time in the model and driver are the same @@ -1578,9 +1939,17 @@ subroutine ModelSetRunClock(gcomp, rc) if (mcurrtime /= dcurrtime) then call ESMF_TimeGet(dcurrtime, timeString=dtimestring, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_TimeGet(mcurrtime, timeString=mtimestring, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & msg=subname//": ERROR in time consistency: "//trim(dtimestring)//" != "//trim(mtimestring), & line=__LINE__, file=__FILE__, rcToReturn=rc) @@ -1594,25 +1963,27 @@ subroutine ModelSetRunClock(gcomp, rc) mstoptime = mcurrtime + dtimestep call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out if (first_time) then !-------------------------------- ! set restart alarm !-------------------------------- - ! set ddefaults + ! defaults restart_n = 0 restart_ymd = 0 - call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (cesm_coupled) then + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - ! If restart_option is set then must also have set either restart_n or restart_ymd - if (isPresent .and. isSet) then + ! If restart_option is set then must also have set either restart_n or restart_ymd call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) + isPresent=isPresent, isSet=isSet, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_n @@ -1628,26 +1999,83 @@ subroutine ModelSetRunClock(gcomp, rc) msg=subname//": ERROR both restart_n and restart_ymd are zero for restart_option set ", & line=__LINE__, file=__FILE__, rcToReturn=rc) return - end if + endif + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) + else - restart_option = "none" - endif - call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return - ! initialize restart alarm - call AlarmInit(mclock, & - alarm = restart_alarm, & - option = trim(restart_option), & - opt_n = restart_n, & - opt_ymd = restart_ymd, & - RefTime = mcurrTime, & - alarmname = 'alarm_restart', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + ! If restart_option is set then must also have set either restart_n or restart_ymd + if (isPresent .and. isSet) then + call ESMF_LogWrite(subname//" Restart_n = "//trim(cvalue), ESMF_LOGMSG_INFO, rc=rc) + read(cvalue,*) restart_n + if(restart_n /= 0)then + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_option + call ESMF_LogWrite(subname//" Restart_option = "//restart_option, & + ESMF_LOGMSG_INFO, rc=rc) + endif + + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_ymd + call ESMF_LogWrite(subname//" Restart_ymd = "//trim(cvalue), ESMF_LOGMSG_INFO, rc=rc) + endif + else + restart_option = 'none' + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, & + ESMF_LOGMSG_INFO, rc=rc) + !TODO: Find a better way + !Create but disable the restart_alarm; this is so restart writing can function w or w/o + !restart_n=0 + restart_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "restart_alarm", enabled = .false., rc=rc) + call ESMF_LogWrite(subname//" Restart alarm is Created but Disabled", ESMF_LOGMSG_INFO, rc=rc) + endif + endif + endif - call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + ! Do not initialize an alarm if the restart option is none + if (restart_option /= 'none') then + call AlarmInit(mclock, & + alarm = restart_alarm, & + option = trim(restart_option), & + opt_n = restart_n, & + opt_ymd = restart_ymd, & + RefTime = mcurrTime, & + alarmname = 'restart_alarm', rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO, rc=rc) + end if first_time = .false. + + ! create a 1-shot alarm at the driver stop time + stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) + call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + + call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) + call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO, rc=rc) endif !-------------------------------- @@ -1655,10 +2083,16 @@ subroutine ModelSetRunClock(gcomp, rc) !-------------------------------- call ESMF_ClockAdvance(mclock,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out end subroutine ModelSetRunClock @@ -1681,7 +2115,12 @@ subroutine ocean_model_finalize(gcomp, rc) type(TIME_TYPE) :: Time type(ESMF_Clock) :: clock type(ESMF_Time) :: currTime + type(ESMF_Alarm), allocatable :: alarmList(:) + integer :: alarmCount character(len=64) :: timestamp + character(len=64) :: alarm_name + logical :: write_restart + integer :: i character(len=*),parameter :: subname='(MOM_cap:ocean_model_finalize)' write(*,*) 'MOM: --- finalize called ---' @@ -1709,11 +2148,25 @@ subroutine ocean_model_finalize(gcomp, rc) return ! bail out Time = esmf2fms_time(currTime) - if (cesm_coupled) then - call ocean_model_end(ocean_public, ocean_State, Time, write_restart=.false.) - else - call ocean_model_end(ocean_public, ocean_State, Time, write_restart=.true.) - endif + ! Check if the clock has a restart alarm - and if it does do not write a restart + call ESMF_ClockGet(clock, alarmCount=alarmCount, rc = rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + + allocate(alarmList(1:alarmCount)) + call ESMF_ClockGetAlarmList(clock, alarmlistflag=ESMF_ALARMLIST_ALL, alarmList=alarmList, rc = rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + + write_restart = .true. + do i = 1,alarmCount + call ESMF_AlarmGet(alarmlist(i), name=alarm_name, rc = rc) + if(trim(alarm_name) == 'restart_alarm' .and. ESMF_AlarmIsEnabled(alarmlist(i), rc=rc))write_restart = .false. + enddo + deallocate(alarmList) + + if(write_restart)call ESMF_LogWrite("No Restart Alarm, writing restart at Finalize ", ESMF_LOGMSG_INFO, rc=rc) + call ocean_model_end(ocean_public, ocean_State, Time, write_restart=write_restart) call field_manager_end() call fms_io_exit() @@ -1789,37 +2242,58 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) if (field_defs(i)%shortname == scalar_field_name) then - call ESMF_LogWrite(subname//tag//" Field "//trim(field_defs(i)%stdname)//" is connected on root pe.", & - ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected on root pe.", & + ESMF_LOGMSG_INFO, & + line=__LINE__, & + file=__FILE__, & + rc=rc) call SetScalarField(field, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out else call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected.", & - ESMF_LOGMSG_INFO) + ESMF_LOGMSG_INFO, & + line=__LINE__, & + file=__FILE__, & + rc=rc) if (present(grid)) then field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, indexflag=ESMF_INDEX_DELOCAL, & name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out ! initialize fldptr to zero call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out fldptr2d(:,:) = 0.0 else if (present(mesh)) then field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out ! initialize fldptr to zero call ESMF_FieldGet(field, farrayPtr=fldptr1d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out fldptr1d(:) = 0.0 endif @@ -1828,16 +2302,24 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) ! Realize connected field call NUOPC_Realize(state, field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out else ! field is not connected call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is not connected.", & - ESMF_LOGMSG_INFO) - + ESMF_LOGMSG_INFO, & + line=__LINE__, & + file=__FILE__, & + rc=rc) ! remove a not connected Field from State call ESMF_StateRemove(state, (/field_defs(i)%shortname/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out endif From e089a159fdfb7c2cb143da83d6084e6860147c05 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 7 Apr 2020 12:55:57 -0600 Subject: [PATCH 003/103] bug fix for cesm when restart_option is none --- config_src/nuopc_driver/mom_cap.F90 | 51 +++++++++++++---------------- 1 file changed, 22 insertions(+), 29 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 26cff18324..232a97ad41 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -1978,6 +1978,7 @@ subroutine ModelSetRunClock(gcomp, rc) restart_ymd = 0 if (cesm_coupled) then + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return @@ -2033,40 +2034,29 @@ subroutine ModelSetRunClock(gcomp, rc) endif else restart_option = 'none' - call ESMF_LogWrite(subname//" Set restart option = "//restart_option, & - ESMF_LOGMSG_INFO, rc=rc) - !TODO: Find a better way - !Create but disable the restart_alarm; this is so restart writing can function w or w/o - !restart_n=0 - restart_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "restart_alarm", enabled = .false., rc=rc) - call ESMF_LogWrite(subname//" Restart alarm is Created but Disabled", ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO, rc=rc) endif endif endif - ! Do not initialize an alarm if the restart option is none - if (restart_option /= 'none') then - call AlarmInit(mclock, & - alarm = restart_alarm, & - option = trim(restart_option), & - opt_n = restart_n, & - opt_ymd = restart_ymd, & - RefTime = mcurrTime, & - alarmname = 'restart_alarm', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO, rc=rc) - end if + call AlarmInit(mclock, & + alarm = restart_alarm, & + option = trim(restart_option), & + opt_n = restart_n, & + opt_ymd = restart_ymd, & + RefTime = mcurrTime, & + alarmname = 'restart_alarm', rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - first_time = .false. + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO, rc=rc) ! create a 1-shot alarm at the driver stop time stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) @@ -2076,6 +2066,9 @@ subroutine ModelSetRunClock(gcomp, rc) call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO, rc=rc) + + first_time = .false. + endif !-------------------------------- From 0a2bb505fd0988371f7f7b6b9739ddd75ea33d3e Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Sun, 12 Apr 2020 17:42:31 -0600 Subject: [PATCH 004/103] uncomment omp directive for KPP_compute_BLD --- .../vertical/MOM_CVMix_KPP.F90 | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 5ed9e2a7a4..8c9c2b0e06 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -962,16 +962,16 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF buoy_scale = US%L_to_m**2*US%s_to_T**3 ! loop over horizontal points on processor - !GOMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & - !GOMP surfBuoyFlux, U_H, V_H, u, v, Coriolis, pRef, SLdepth_0d, & - !GOMP ksfc, surfHtemp, surfHsalt, surfHu, surfHv, surfHuS, & - !GOMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & - !GOMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, & - !GOMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_GUESS, LA, rho_1D, & - !GOMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & - !GOMP BulkRi_1d, zBottomMinusOffset) & - !GOMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & - !GOMP Temp, Salt, waves, EOS, GoRho) + !$OMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & + !$OMP surfBuoyFlux, U_H, V_H, Coriolis, pRef, SLdepth_0d, & + !$OMP ksfc, surfHtemp, surfHsalt, surfHu, surfHv, surfHuS, & + !$OMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & + !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, & + !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_GUESS, LA, rho_1D, & + !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & + !$OMP BulkRi_1d, zBottomMinusOffset) & + !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & + !$OMP Temp, Salt, waves, EOS, GoRho, u, v) do j = G%jsc, G%jec do i = G%isc, G%iec From 01f7c452e0808719dcebd7fb180024b83e1b80e8 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Sun, 12 Apr 2020 21:31:58 -0600 Subject: [PATCH 005/103] uncomment omp in barotropic solver --- src/core/MOM_barotropic.F90 | 108 ++++++++++++++++++------------------ 1 file changed, 54 insertions(+), 54 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 14fc918b60..d3dabd2147 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1584,24 +1584,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call find_face_areas(Datu, Datv, G, GV, US, CS, MS, eta, 1+iev-ie) endif - !GOMP parallel default(shared) + !$OMP parallel default(shared) if (CS%dynamic_psurf .or. .not.project_velocity) then if (use_BT_cont) then - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-2,iev+1 uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j), US) + uhbt0(I,j) enddo ; enddo - !GOMP do + !$OMP do do J=jsv-2,jev+1 ; do i=isv-1,iev+1 vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J), US) + vhbt0(i,J) enddo ; enddo - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) enddo ; enddo else - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & (((Datu(I-1,j)*ubt(I-1,j) + uhbt0(I-1,j)) - & @@ -1612,7 +1612,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%dynamic_psurf) then - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 p_surf_dyn(i,j) = dyn_coef_eta(i,j) * (eta_pred(i,j) - eta(i,j)) enddo ; enddo @@ -1623,7 +1623,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! eta_PF_BT => eta_pred ; if (project_velocity) eta_PF_BT => eta if (find_etaav) then - !GOMP do + !$OMP do do j=js,je ; do i=is,ie eta_sum(i,j) = eta_sum(i,j) + wt_accel2(n) * eta_PF_BT(i,j) enddo ; enddo @@ -1631,23 +1631,23 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (interp_eta_PF) then wt_end = n*Instep ! This could be (n-0.5)*Instep. - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 eta_PF(i,j) = eta_PF_1(i,j) + wt_end*d_eta_PF(i,j) enddo ; enddo endif if (apply_OBC_flather .or. apply_OBC_open) then - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-2,iev+1 ubt_old(I,j) = ubt(I,j) enddo ; enddo - !GOMP do + !$OMP do do J=jsv-2,jev+1 ; do i=isv,iev vbt_old(i,J) = vbt(i,J) enddo ; enddo endif - !GOMP end parallel + !$OMP end parallel if (apply_OBCs) then if (MOD(n+G%first_direction,2)==1) then @@ -1657,7 +1657,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%BT_OBC%apply_u_OBCs) then ! save the old value of ubt and uhbt - !GOMP parallel do default(shared) + !$OMP parallel do default(shared) do J=jsv-joff,jev+joff ; do i=isv-1,iev ubt_prev(i,J) = ubt(i,J) ; uhbt_prev(i,J) = uhbt(i,J) ubt_sum_prev(i,J) = ubt_sum(i,J) ; uhbt_sum_prev(i,J) = uhbt_sum(i,J) ; ubt_wtd_prev(i,J) = ubt_wtd(i,J) @@ -1665,7 +1665,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%BT_OBC%apply_v_OBCs) then ! save the old value of vbt and vhbt - !GOMP parallel do default(shared) + !$OMP parallel do default(shared) do J=jsv-1,jev ; do i=isv-ioff,iev+ioff vbt_prev(i,J) = vbt(i,J) ; vhbt_prev(i,J) = vhbt(i,J) vbt_sum_prev(i,J) = vbt_sum(i,J) ; vhbt_sum_prev(i,J) = vhbt_sum(i,J) ; vbt_wtd_prev(i,J) = vbt_wtd(i,J) @@ -1673,10 +1673,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif endif - !GOMP parallel default(shared) private(vel_prev) + !$OMP parallel default(shared) private(vel_prev) if (MOD(n+G%first_direction,2)==1) then ! On odd-steps, update v first. - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + & (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) @@ -1685,19 +1685,19 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, dgeo_de * CS%IdyCv(i,J) enddo ; enddo if (CS%dynamic_psurf) then - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J) enddo ; enddo endif if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then PFv(i,J) = 0.0 endif ; enddo ; enddo endif - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 vel_prev = vbt(i,J) vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & @@ -1713,24 +1713,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (use_BT_cont) then - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J), US) + vhbt0(i,J) enddo ; enddo else - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) enddo ; enddo endif if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then vbt(i,J) = vbt_prev(i,J) ; vhbt(i,J) = vhbt_prev(i,J) endif ; enddo ; enddo endif ! Now update the zonal velocity. - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + & (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - & @@ -1741,19 +1741,19 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (CS%dynamic_psurf) then - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j) enddo ; enddo endif if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then PFu(I,j) = 0.0 endif ; enddo ; enddo endif - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev vel_prev = ubt(I,j) ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & @@ -1770,25 +1770,25 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (use_BT_cont) then - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j), US) + uhbt0(I,j) enddo ; enddo else - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) enddo ; enddo endif if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo endif else ! On even steps, update u first. - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-1,iev Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + & (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - & @@ -1799,20 +1799,20 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (CS%dynamic_psurf) then - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-1,iev PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j) enddo ; enddo endif if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then PFu(I,j) = 0.0 endif ; enddo ; enddo endif - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-1,iev vel_prev = ubt(I,j) ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & @@ -1829,18 +1829,18 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (use_BT_cont) then - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-1,iev uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j), US) + uhbt0(I,j) enddo ; enddo else - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-1,iev uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) enddo ; enddo endif if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo @@ -1848,7 +1848,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Now update the meridional velocity. if (CS%use_old_coriolis_bracket_bug) then - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + bmer(I,j) * ubt(I,j)) + & (cmer(I,j+1) * ubt(I,j+1) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) @@ -1857,7 +1857,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, dgeo_de * CS%IdyCv(i,J) enddo ; enddo else - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + & (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) @@ -1868,20 +1868,20 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%dynamic_psurf) then - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J) enddo ; enddo endif if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then PFv(i,J) = 0.0 endif ; enddo ; enddo endif - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev vel_prev = vbt(i,J) vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & @@ -1897,64 +1897,64 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif enddo ; enddo if (use_BT_cont) then - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J), US) + vhbt0(i,J) enddo ; enddo else - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) enddo ; enddo endif if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev ; if (OBC%segnum_v(i,J) /= OBC_NONE) then vbt(i,J) = vbt_prev(i,J); vhbt(i,J) = vhbt_prev(i,J) endif ; enddo ; enddo endif endif - !GOMP end parallel + !$OMP end parallel - !GOMP parallel default(shared) + !$OMP parallel default(shared) if (find_PF) then - !GOMP do + !$OMP do do j=js,je ; do I=is-1,ie PFu_bt_sum(I,j) = PFu_bt_sum(I,j) + wt_accel2(n) * PFu(I,j) enddo ; enddo - !GOMP do + !$OMP do do J=js-1,je ; do i=is,ie PFv_bt_sum(i,J) = PFv_bt_sum(i,J) + wt_accel2(n) * PFv(i,J) enddo ; enddo endif if (find_Cor) then - !GOMP do + !$OMP do do j=js,je ; do I=is-1,ie Coru_bt_sum(I,j) = Coru_bt_sum(I,j) + wt_accel2(n) * Cor_u(I,j) enddo ; enddo - !GOMP do + !$OMP do do J=js-1,je ; do i=is,ie Corv_bt_sum(i,J) = Corv_bt_sum(i,J) + wt_accel2(n) * Cor_v(i,J) enddo ; enddo endif - !GOMP do + !$OMP do do j=js,je ; do I=is-1,ie ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) enddo ; enddo - !GOMP do + !$OMP do do J=js-1,je ; do i=is,ie vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) enddo ; enddo - !GOMP end parallel + !$OMP end parallel if (apply_OBCs) then if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !GOMP parallel do default(shared) + !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie if (OBC%segnum_u(I,j) /= OBC_NONE) then ubt_sum(I,j) = ubt_sum_prev(I,j) ; uhbt_sum(I,j) = uhbt_sum_prev(I,j) @@ -1964,7 +1964,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !GOMP parallel do default(shared) + !$OMP parallel do default(shared) do J=js-1,je ; do I=is,ie if (OBC%segnum_v(i,J) /= OBC_NONE) then vbt_sum(i,J) = vbt_sum_prev(i,J) ; vhbt_sum(i,J) = vhbt_sum_prev(i,J) From 2aa10917d947819a958610e611e8ce91858ef797 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 14 Apr 2020 11:01:53 -0600 Subject: [PATCH 006/103] optimize barotropic timestepping openmp --- src/core/MOM_barotropic.F90 | 137 ++++++++++++++++++++++-------------- 1 file changed, 83 insertions(+), 54 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index d3dabd2147..fbaadc869f 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1584,13 +1584,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call find_face_areas(Datu, Datv, G, GV, US, CS, MS, eta, 1+iev-ie) endif - !$OMP parallel default(shared) + !$OMP parallel default(shared) private(vel_prev, ioff, joff) if (CS%dynamic_psurf .or. .not.project_velocity) then if (use_BT_cont) then !$OMP do do j=jsv-1,jev+1 ; do I=isv-2,iev+1 uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j), US) + uhbt0(I,j) enddo ; enddo + !$OMP end do nowait !$OMP do do J=jsv-2,jev+1 ; do i=isv-1,iev+1 vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J), US) + vhbt0(i,J) @@ -1627,6 +1628,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do j=js,je ; do i=is,ie eta_sum(i,j) = eta_sum(i,j) + wt_accel2(n) * eta_PF_BT(i,j) enddo ; enddo + !$OMP end do nowait endif if (interp_eta_PF) then @@ -1647,7 +1649,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_old(i,J) = vbt(i,J) enddo ; enddo endif - !$OMP end parallel if (apply_OBCs) then if (MOD(n+G%first_direction,2)==1) then @@ -1657,7 +1658,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%BT_OBC%apply_u_OBCs) then ! save the old value of ubt and uhbt - !$OMP parallel do default(shared) + !$OMP do do J=jsv-joff,jev+joff ; do i=isv-1,iev ubt_prev(i,J) = ubt(i,J) ; uhbt_prev(i,J) = uhbt(i,J) ubt_sum_prev(i,J) = ubt_sum(i,J) ; uhbt_sum_prev(i,J) = uhbt_sum(i,J) ; ubt_wtd_prev(i,J) = ubt_wtd(i,J) @@ -1665,7 +1666,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%BT_OBC%apply_v_OBCs) then ! save the old value of vbt and vhbt - !$OMP parallel do default(shared) + !$OMP do do J=jsv-1,jev ; do i=isv-ioff,iev+ioff vbt_prev(i,J) = vbt(i,J) ; vhbt_prev(i,J) = vhbt(i,J) vbt_sum_prev(i,J) = vbt_sum(i,J) ; vhbt_sum_prev(i,J) = vhbt_sum(i,J) ; vbt_wtd_prev(i,J) = vbt_wtd(i,J) @@ -1673,10 +1674,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif endif - !$OMP parallel default(shared) private(vel_prev) if (MOD(n+G%first_direction,2)==1) then ! On odd-steps, update v first. - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + & (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) @@ -1684,20 +1684,23 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * & dgeo_de * CS%IdyCv(i,J) enddo ; enddo + !$OMP end do nowait if (CS%dynamic_psurf) then - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J) enddo ; enddo + !$OMP end do nowait endif if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then PFv(i,J) = 0.0 endif ; enddo ; enddo + !$OMP end do nowait endif - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 vel_prev = vbt(i,J) vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & @@ -1713,24 +1716,26 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (use_BT_cont) then - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J), US) + vhbt0(i,J) enddo ; enddo + !$OMP end do nowait else - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) enddo ; enddo + !$OMP end do nowait endif if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then vbt(i,J) = vbt_prev(i,J) ; vhbt(i,J) = vhbt_prev(i,J) endif ; enddo ; enddo endif ! Now update the zonal velocity. - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + & (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - & @@ -1739,21 +1744,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j)) * & dgeo_de * CS%IdxCu(I,j) enddo ; enddo + !$OMP end do nowait if (CS%dynamic_psurf) then - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j) enddo ; enddo + !$OMP end do nowait endif if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then PFu(I,j) = 0.0 endif ; enddo ; enddo + !$OMP end do nowait endif - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev vel_prev = ubt(I,j) ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & @@ -1768,27 +1776,28 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * (Cor_u(I,j) + PFu(I,j)) endif enddo ; enddo + !$OMP end do nowait if (use_BT_cont) then - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j), US) + uhbt0(I,j) enddo ; enddo else - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) enddo ; enddo endif if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo endif else ! On even steps, update u first. - !$OMP do + !$OMP do schedule(static) do j=jsv-1,jev+1 ; do I=isv-1,iev Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + & (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - & @@ -1797,22 +1806,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j)) * & dgeo_de * CS%IdxCu(I,j) enddo ; enddo + !$OMP end do nowait if (CS%dynamic_psurf) then - !$OMP do + !$OMP do schedule(static) do j=jsv-1,jev+1 ; do I=isv-1,iev PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j) enddo ; enddo + !$OMP end do nowait endif if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then PFu(I,j) = 0.0 endif ; enddo ; enddo endif - !$OMP do + !$OMP do schedule(static) do j=jsv-1,jev+1 ; do I=isv-1,iev vel_prev = ubt(I,j) ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & @@ -1829,18 +1840,20 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (use_BT_cont) then - !$OMP do + !$OMP do schedule(static) do j=jsv-1,jev+1 ; do I=isv-1,iev uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j), US) + uhbt0(I,j) enddo ; enddo + !$OMP end do nowait else - !$OMP do + !$OMP do schedule(static) do j=jsv-1,jev+1 ; do I=isv-1,iev uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) enddo ; enddo + !$OMP end do nowait endif if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !$OMP do + !$OMP do schedule(static) do j=jsv-1,jev+1 ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo @@ -1848,7 +1861,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Now update the meridional velocity. if (CS%use_old_coriolis_bracket_bug) then - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + bmer(I,j) * ubt(I,j)) + & (cmer(I,j+1) * ubt(I,j+1) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) @@ -1856,8 +1869,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * & dgeo_de * CS%IdyCv(i,J) enddo ; enddo + !$OMP end do nowait else - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + & (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) @@ -1865,23 +1879,25 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * & dgeo_de * CS%IdyCv(i,J) enddo ; enddo + !$OMP end do nowait endif if (CS%dynamic_psurf) then - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J) enddo ; enddo + !$OMP end do nowait endif if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then PFv(i,J) = 0.0 endif ; enddo ; enddo endif - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev vel_prev = vbt(i,J) vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & @@ -1896,46 +1912,49 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) endif enddo ; enddo + !$OMP end do nowait if (use_BT_cont) then - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J), US) + vhbt0(i,J) enddo ; enddo else - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) enddo ; enddo endif if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev ; if (OBC%segnum_v(i,J) /= OBC_NONE) then vbt(i,J) = vbt_prev(i,J); vhbt(i,J) = vhbt_prev(i,J) endif ; enddo ; enddo endif endif - !$OMP end parallel - !$OMP parallel default(shared) if (find_PF) then !$OMP do do j=js,je ; do I=is-1,ie PFu_bt_sum(I,j) = PFu_bt_sum(I,j) + wt_accel2(n) * PFu(I,j) enddo ; enddo + !$OMP end do nowait !$OMP do do J=js-1,je ; do i=is,ie PFv_bt_sum(i,J) = PFv_bt_sum(i,J) + wt_accel2(n) * PFv(i,J) enddo ; enddo + !$OMP end do nowait endif if (find_Cor) then !$OMP do do j=js,je ; do I=is-1,ie Coru_bt_sum(I,j) = Coru_bt_sum(I,j) + wt_accel2(n) * Cor_u(I,j) enddo ; enddo + !$OMP end do nowait !$OMP do do J=js-1,je ; do i=is,ie Corv_bt_sum(i,J) = Corv_bt_sum(i,J) + wt_accel2(n) * Cor_v(i,J) enddo ; enddo + !$OMP end do nowait endif !$OMP do @@ -1944,17 +1963,18 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) enddo ; enddo + !$OMP end do nowait !$OMP do do J=js-1,je ; do i=is,ie vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) enddo ; enddo - !$OMP end parallel + !$OMP end do nowait if (apply_OBCs) then if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !$OMP parallel do default(shared) + !$OMP do do j=js,je ; do I=is-1,ie if (OBC%segnum_u(I,j) /= OBC_NONE) then ubt_sum(I,j) = ubt_sum_prev(I,j) ; uhbt_sum(I,j) = uhbt_sum_prev(I,j) @@ -1964,7 +1984,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !$OMP parallel do default(shared) + !$OMP do do J=js-1,je ; do I=is,ie if (OBC%segnum_v(i,J) /= OBC_NONE) then vbt_sum(i,J) = vbt_sum_prev(i,J) ; vhbt_sum(i,J) = vhbt_sum_prev(i,J) @@ -1973,24 +1993,32 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo endif + !$OMP single call apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, & ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v, & uhbt0, vhbt0) - if (CS%BT_OBC%apply_u_OBCs) then ; do j=js,je ; do I=is-1,ie - if (OBC%segnum_u(I,j) /= OBC_NONE) then - ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) - uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) - ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) - endif - enddo ; enddo ; endif - if (CS%BT_OBC%apply_v_OBCs) then ; do J=js-1,je ; do i=is,ie - if (OBC%segnum_v(i,J) /= OBC_NONE) then - vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) - vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) - vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) - endif - enddo ; enddo ; endif + !$OMP end single + if (CS%BT_OBC%apply_u_OBCs) then + !$OMP do + do j=js,je ; do I=is-1,ie + if (OBC%segnum_u(I,j) /= OBC_NONE) then + ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) + uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) + ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) + endif + enddo ; enddo + endif + if (CS%BT_OBC%apply_v_OBCs) then + !$OMP do + do J=js-1,je ; do i=is,ie + if (OBC%segnum_v(i,J) /= OBC_NONE) then + vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) + vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) + vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) + endif + enddo ; enddo + endif endif if (CS%debug_bt) then @@ -1998,13 +2026,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) endif - !$OMP parallel do default(shared) + !$OMP do do j=jsv,jev ; do i=isv,iev eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) ! Should there be a concern if eta drops below 0 or G%bathyT? enddo ; enddo + !$OMP end parallel if (do_hifreq_output) then time_step_end = time_bt_start + real_to_time(n*US%T_to_s*dtbt) From 3dd70fe71930faaff5f8818ef3f9256335393ef4 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 15 Apr 2020 11:56:23 -0600 Subject: [PATCH 007/103] remove unnecessary kOBL computation --- .../vertical/MOM_CVMix_KPP.F90 | 25 ------------------- 1 file changed, 25 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 8c9c2b0e06..6056dd3eab 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1415,31 +1415,6 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) enddo ! s-loop - ! Update kOBL for smoothed OBL depths - do j = G%jsc, G%jec - do i = G%isc, G%iec - - ! skip land points - if (G%mask2dT(i,j)==0.) cycle - - iFaceHeight(1) = 0.0 ! BBL is all relative to the surface - hcorr = 0. - do k=1,G%ke - - ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment - dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) - hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 - dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh - enddo - - CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) - - enddo - enddo - end subroutine KPP_smooth_BLD From 6cf28bf15f06ce9f7015b2db1fc51d63438f4501 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 15 Apr 2020 15:06:55 -0600 Subject: [PATCH 008/103] Add option to scale AH via a biharmonic Reynolds # This is done via parameter RE_AH: if nonzero, the biharmonic coefficient is scaled so that the biharmonic Reynolds number is equal to this. --- .../lateral/MOM_hor_visc.F90 | 137 ++++-------------- 1 file changed, 30 insertions(+), 107 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index c3ec878bc1..f3c593819a 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -46,6 +46,8 @@ module MOM_hor_visc !! limited to guarantee stability. logical :: better_bound_Ah !< If true, use a more careful bounding of the !! biharmonic viscosity to guarantee stability. + real :: Re_Ah !! If nonzero, the biharmonic coefficient is scaled + !< so that the biharmonic Reynolds number is equal to this. real :: bound_coef !< The nondimensional coefficient of the ratio of !! the viscosity bounds to the theoretical maximum !! for stability without considering other terms [nondim]. @@ -163,14 +165,16 @@ module MOM_hor_visc Biharm5_const_xx, & !< Biharmonic metric-dependent constants [L5 ~> m5] Laplac3_const_xx, & !< Laplacian metric-dependent constants [L3 ~> m3] Biharm_const_xx, & !< Biharmonic metric-dependent constants [L4 ~> m4] - Biharm_const2_xx !< Biharmonic metric-dependent constants [T L4 ~> s m4] + Biharm_const2_xx, & !< Biharmonic metric-dependent constants [T L4 ~> s m4] + Re_Ah_const_xx !< Biharmonic metric-dependent constants [L3 ~> m3] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & Laplac2_const_xy, & !< Laplacian metric-dependent constants [L2 ~> m2] Biharm5_const_xy, & !< Biharmonic metric-dependent constants [L5 ~> m5] Laplac3_const_xy, & !< Laplacian metric-dependent constants [L3 ~> m3] Biharm_const_xy, & !< Biharmonic metric-dependent constants [L4 ~> m4] - Biharm_const2_xy !< Biharmonic metric-dependent constants [T L4 ~> s m4] + Biharm_const2_xy, & !< Biharmonic metric-dependent constants [T L4 ~> s m4] + Re_Ah_const_xy !< Biharmonic metric-dependent constants [L3 ~> m3] type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostics @@ -339,6 +343,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: backscat_subround ! The ratio of f over Shear_mag that is so small that the backscatter ! calculation gives the same value as if f were 0 [nondim]. real :: H0_GME ! Depth used to scale down GME coefficient in shallow areas [Z ~> m] + real :: KE ! Local kinetic energy [L2 T-2 ~> m2 s-2] logical :: rescale_Kh, legacy_bound logical :: find_FrictWork logical :: apply_OBC = .false. @@ -874,6 +879,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (use_MEKE_Au) Ah = Ah + MEKE%Au(i,j) ! *Add* the MEKE contribution + if (CS%Re_Ah > 0.0) then + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + Ah = sqrt(KE) * CS%Re_Ah_const_xx(i,j) + endif + if (CS%better_bound_Ah) then Ah = MIN(Ah, visc_bound_rem*hrat_min*CS%Ah_Max_xx(i,j)) endif @@ -1047,6 +1057,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, (MEKE%Au(I+1,J) + MEKE%Au(I,J+1)) ) endif + if (CS%Re_Ah > 0.0) then + KE = 0.125*((u(I,j,k)+u(I,j+1,k))**2 + (v(i,J,k)+v(i+1,J,k))**2) + Ah = sqrt(KE) * CS%Re_Ah_const_xy(i,j) + endif + if (CS%better_bound_Ah) then Ah = MIN(Ah, visc_bound_rem*hrat_min*CS%Ah_Max_xy(I,J)) endif @@ -1363,7 +1378,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) logical :: split ! If true, use the split time stepping scheme. ! If false and USE_GME = True, issue a FATAL error. logical :: default_2018_answers - character(len=64) :: inputdir, filename real :: deg2rad ! Converts degrees to radians real :: slat_fn ! sin(lat)**Kh_pwr_of_sine @@ -1372,28 +1386,22 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: i, j - ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_hor_visc" ! module name - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - if (associated(CS)) then call MOM_error(WARNING, "hor_visc_init called with an associated "// & "control structure.") return endif allocate(CS) - CS%diag => diag - ! Read parameters and write them to the model log. call log_version(param_file, mdl, version, "") - ! It is not clear whether these initialization lines are needed for the ! cases where the corresponding parameters are not read. CS%bound_Kh = .false. ; CS%better_bound_Kh = .false. ; CS%Smagorinsky_Kh = .false. ; CS%Leith_Kh = .false. @@ -1403,13 +1411,10 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%Modified_Leith = .false. CS%anisotropic = .false. CS%dynamic_aniso = .false. - Kh = 0.0 ; Ah = 0.0 - ! If GET_ALL_PARAMS is true, all parameters are read in all cases to enable ! parameter spelling checks. call get_param(param_file, mdl, "GET_ALL_PARAMS", get_all, default=.false.) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.true.) @@ -1417,9 +1422,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) - call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) - call get_param(param_file, mdl, "LAPLACIAN", CS%Laplacian, & "If true, use a Laplacian horizontal viscosity.", & default=.false.) @@ -1445,7 +1448,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "The power used to raise SIN(LAT) when using a latitudinally "//& "dependent background viscosity.", & units = "nondim", default=4.0) - call get_param(param_file, mdl, "SMAGORINSKY_KH", CS%Smagorinsky_Kh, & "If true, use a Smagorinsky nonlinear eddy viscosity.", & default=.false.) @@ -1454,11 +1456,9 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "The nondimensional Laplacian Smagorinsky constant, "//& "often 0.15.", units="nondim", default=0.0, & fail_if_missing = CS%Smagorinsky_Kh) - call get_param(param_file, mdl, "LEITH_KH", CS%Leith_Kh, & "If true, use a Leith nonlinear eddy viscosity.", & default=.false.) - call get_param(param_file, mdl, "MODIFIED_LEITH", CS%Modified_Leith, & "If true, add a term to Leith viscosity which is "//& "proportional to the gradient of divergence.", & @@ -1466,7 +1466,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) call get_param(param_file, mdl, "RES_SCALE_MEKE_VISC", CS%res_scale_MEKE, & "If true, the viscosity contribution from MEKE is scaled by "//& "the resolution function.", default=.false.) - if (CS%Leith_Kh .or. get_all) then call get_param(param_file, mdl, "LEITH_LAP_CONST", Leith_Lap_const, & "The nondimensional Laplacian Leith constant, "//& @@ -1525,7 +1524,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "to the spherical coordinates.", units = "nondim", fail_if_missing=.true.) end select endif - call get_param(param_file, mdl, "BIHARMONIC", CS%biharmonic, & "If true, use a biharmonic horizontal viscosity. "//& "BIHARMONIC may be used with LAPLACIAN.", & @@ -1552,7 +1550,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) call get_param(param_file, mdl, "LEITH_AH", CS%Leith_Ah, & "If true, use a biharmonic Leith nonlinear eddy "//& "viscosity.", default=.false.) - call get_param(param_file, mdl, "BOUND_AH", CS%bound_Ah, & "If true, the biharmonic coefficient is locally limited "//& "to be stable.", default=.true.) @@ -1560,13 +1557,16 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "If true, the biharmonic coefficient is locally limited "//& "to be stable with a better bounding than just BOUND_AH.", & default=CS%bound_Ah) + call get_param(param_file, mdl, "RE_AH", CS%Re_Ah, & + "If nonzero, the biharmonic coefficient is scaled "//& + "so that the biharmonic Reynolds number is equal to this.", & + units="nondim", default=0.0) if (CS%Smagorinsky_Ah .or. get_all) then call get_param(param_file, mdl, "SMAG_BI_CONST",Smag_bi_const, & "The nondimensional biharmonic Smagorinsky constant, "//& "typically 0.015 - 0.06.", units="nondim", default=0.0, & fail_if_missing = CS%Smagorinsky_Ah) - call get_param(param_file, mdl, "BOUND_CORIOLIS", bound_Cor_def, default=.false.) call get_param(param_file, mdl, "BOUND_CORIOLIS_BIHARM", CS%bound_Coriolis, & "If true use a viscosity that increases with the square "//& @@ -1585,29 +1585,24 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) units="m s-1", default=maxvel, scale=US%m_s_to_L_T) endif endif - if (CS%Leith_Ah .or. get_all) & call get_param(param_file, mdl, "LEITH_BI_CONST", Leith_bi_const, & "The nondimensional biharmonic Leith constant, "//& "typical values are thus far undetermined.", units="nondim", default=0.0, & fail_if_missing = CS%Leith_Ah) - endif - call get_param(param_file, mdl, "USE_LAND_MASK_FOR_HVISC", CS%use_land_mask, & "If true, use Use the land mask for the computation of thicknesses "//& "at velocity locations. This eliminates the dependence on arbitrary "//& "values over land or outside of the domain. Default is False in order to "//& "maintain answers with legacy experiments but should be changed to True "//& "for new experiments.", default=.false.) - if (CS%better_bound_Ah .or. CS%better_bound_Kh .or. get_all) & call get_param(param_file, mdl, "HORVISC_BOUND_COEF", CS%bound_coef, & "The nondimensional coefficient of the ratio of the "//& "viscosity bounds to the theoretical maximum for "//& "stability without considering other terms.", units="nondim", & default=0.8) - call get_param(param_file, mdl, "NOSLIP", CS%no_slip, & "If true, no slip boundary conditions are used; otherwise "//& "free slip boundary conditions are assumed. The "//& @@ -1615,47 +1610,37 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "cleaner than the no slip BCs. The use of free slip BCs "//& "is strongly encouraged, and no slip BCs are not used with "//& "the biharmonic viscosity.", default=.false.) - call get_param(param_file, mdl, "USE_KH_BG_2D", CS%use_Kh_bg_2d, & "If true, read a file containing 2-d background harmonic "//& "viscosities. The final viscosity is the maximum of the other "//& "terms and this background value.", default=.false.) - call get_param(param_file, mdl, "USE_GME", CS%use_GME, & "If true, use the GM+E backscatter scheme in association \n"//& "with the Gent and McWilliams parameterization.", default=.false.) - if (CS%use_GME) then call get_param(param_file, mdl, "SPLIT", split, & "Use the split time stepping if true.", default=.true., & do_not_log=.true.) if (.not. split) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// & "cannot be used with SPLIT=False.") - call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & "The strength of GME tapers quadratically to zero when the bathymetric "//& "depth is shallower than GME_H0.", units="m", scale=US%m_to_Z, & default=1000.0) - call get_param(param_file, mdl, "GME_EFFICIENCY", CS%GME_efficiency, & "The nondimensional prefactor multiplying the GME coefficient.", & units="nondim", default=1.0) - call get_param(param_file, mdl, "GME_LIMITER", CS%GME_limiter, & "The absolute maximum value the GME coefficient is allowed to take.", & units="m2 s-1", scale=US%m_to_L**2*US%T_to_s, default=1.0e7) - endif - if (CS%bound_Kh .or. CS%bound_Ah .or. CS%better_bound_Kh .or. CS%better_bound_Ah) & call get_param(param_file, mdl, "DT", dt, & "The (baroclinic) dynamics time step.", units="s", scale=US%s_to_T, & fail_if_missing=.true.) - if (CS%no_slip .and. CS%biharmonic) & call MOM_error(FATAL,"ERROR: NOSLIP and BIHARMONIC cannot be defined "// & "at the same time in MOM.") - if (.not.(CS%Laplacian .or. CS%biharmonic)) then ! Only issue inviscid warning if not in single column mode (usually 2x2 domain) if ( max(G%domain%niglobal, G%domain%njglobal)>2 ) call MOM_error(WARNING, & @@ -1663,9 +1648,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "LAPLACIAN or BIHARMONIC viscosity.") return ! We are not using either Laplacian or Bi-harmonic lateral viscosity endif - deg2rad = atan(1.0) / 45. - ALLOC_(CS%dx2h(isd:ied,jsd:jed)) ; CS%dx2h(:,:) = 0.0 ALLOC_(CS%dy2h(isd:ied,jsd:jed)) ; CS%dy2h(:,:) = 0.0 ALLOC_(CS%dx2q(IsdB:IedB,JsdB:JedB)) ; CS%dx2q(:,:) = 0.0 @@ -1674,7 +1657,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) ALLOC_(CS%dy_dxT(isd:ied,jsd:jed)) ; CS%dy_dxT(:,:) = 0.0 ALLOC_(CS%dx_dyBu(IsdB:IedB,JsdB:JedB)) ; CS%dx_dyBu(:,:) = 0.0 ALLOC_(CS%dy_dxBu(IsdB:IedB,JsdB:JedB)) ; CS%dy_dxBu(:,:) = 0.0 - if (CS%Laplacian) then ALLOC_(CS%Kh_bg_xx(isd:ied,jsd:jed)) ; CS%Kh_bg_xx(:,:) = 0.0 ALLOC_(CS%Kh_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_bg_xy(:,:) = 0.0 @@ -1693,7 +1675,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif ALLOC_(CS%reduction_xx(isd:ied,jsd:jed)) ; CS%reduction_xx(:,:) = 0.0 ALLOC_(CS%reduction_xy(IsdB:IedB,JsdB:JedB)) ; CS%reduction_xy(:,:) = 0.0 - if (CS%anisotropic) then ALLOC_(CS%n1n2_h(isd:ied,jsd:jed)) ; CS%n1n2_h(:,:) = 0.0 ALLOC_(CS%n1n1_m_n2n2_h(isd:ied,jsd:jed)) ; CS%n1n1_m_n2n2_h(:,:) = 0.0 @@ -1711,7 +1692,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "Runtime parameter ANISOTROPIC_MODE is out of range.") end select endif - if (CS%use_Kh_bg_2d) then ALLOC_(CS%Kh_bg_2d(isd:ied,jsd:jed)) ; CS%Kh_bg_2d(:,:) = 0.0 call get_param(param_file, mdl, "KH_BG_2D_FILENAME", filename, & @@ -1723,13 +1703,11 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) G%domain, timelevel=1, scale=US%m_to_L**2*US%T_to_s) call pass_var(CS%Kh_bg_2d, G%domain) endif - if (CS%biharmonic) then ALLOC_(CS%Idx2dyCu(IsdB:IedB,jsd:jed)) ; CS%Idx2dyCu(:,:) = 0.0 ALLOC_(CS%Idx2dyCv(isd:ied,JsdB:JedB)) ; CS%Idx2dyCv(:,:) = 0.0 ALLOC_(CS%Idxdy2u(IsdB:IedB,jsd:jed)) ; CS%Idxdy2u(:,:) = 0.0 ALLOC_(CS%Idxdy2v(isd:ied,JsdB:JedB)) ; CS%Idxdy2v(:,:) = 0.0 - ALLOC_(CS%Ah_bg_xx(isd:ied,jsd:jed)) ; CS%Ah_bg_xx(:,:) = 0.0 ALLOC_(CS%Ah_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_bg_xy(:,:) = 0.0 if (CS%bound_Ah .or. CS%better_bound_Ah) then @@ -1748,8 +1726,11 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) ALLOC_(CS%biharm5_const_xx(isd:ied,jsd:jed)) ; CS%biharm5_const_xx(:,:) = 0.0 ALLOC_(CS%biharm5_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm5_const_xy(:,:) = 0.0 endif + if (CS%Re_Ah > 0.0) then + ALLOC_(CS%Re_Ah_const_xx(isd:ied,jsd:jed)); CS%Re_Ah_const_xx(:,:) = 0.0 + ALLOC_(CS%Re_Ah_const_xy(IsdB:IedB,JsdB:JedB)); CS%Re_Ah_const_xy(:,:) = 0.0 + endif endif - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 CS%dx2q(I,J) = G%dxBu(I,J)*G%dxBu(I,J) ; CS%dy2q(I,J) = G%dyBu(I,J)*G%dyBu(I,J) CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) @@ -1758,7 +1739,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%dx2h(i,j) = G%dxT(i,j)*G%dxT(i,j) ; CS%dy2h(i,j) = G%dyT(i,j)*G%dyT(i,j) CS%DX_dyT(i,j) = G%dxT(i,j)*G%IdyT(i,j) ; CS%DY_dxT(i,j) = G%dyT(i,j)*G%IdxT(i,j) enddo ; enddo - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 CS%reduction_xx(i,j) = 1.0 if ((G%dy_Cu(I,j) > 0.0) .and. (G%dy_Cu(I,j) < G%dyCu(I,j)) .and. & @@ -1774,7 +1754,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) (G%dx_Cv(i,J-1) < G%dxCv(i,J-1) * CS%reduction_xx(i,j))) & CS%reduction_xx(i,j) = G%dx_Cv(i,J-1) / (G%dxCv(i,J-1)) enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq CS%reduction_xy(I,J) = 1.0 if ((G%dy_Cu(I,j) > 0.0) .and. (G%dy_Cu(I,j) < G%dyCu(I,j)) .and. & @@ -1790,12 +1769,10 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) (G%dx_Cv(i+1,J) < G%dxCv(i+1,J) * CS%reduction_xy(I,J))) & CS%reduction_xy(I,J) = G%dx_Cv(i+1,J) / (G%dxCv(i+1,J)) enddo ; enddo - if (CS%Laplacian) then ! The 0.3 below was 0.4 in MOM1.10. The change in hq requires ! this to be less than 1/3, rather than 1/2 as before. if (CS%bound_Kh .or. CS%bound_Ah) Kh_Limit = 0.3 / (dt*4.0) - ! Calculate and store the background viscosity at h-points do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ! Static factors in the Smagorinsky and Leith schemes @@ -1805,23 +1782,19 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) if (CS%Leith_Kh) CS%Laplac3_const_xx(i,j) = Leith_Lap_const * grid_sp_h3 ! Maximum of constant background and MICOM viscosity CS%Kh_bg_xx(i,j) = MAX(Kh, Kh_vel_scale * sqrt(grid_sp_h2)) - ! Use the larger of the above and values read from a file if (CS%use_Kh_bg_2d) CS%Kh_bg_xx(i,j) = MAX(CS%Kh_bg_2d(i,j), CS%Kh_bg_xx(i,j)) - ! Use the larger of the above and a function of sin(latitude) if (Kh_sin_lat>0.) then slat_fn = abs( sin( deg2rad * G%geoLatT(i,j) ) ) ** Kh_pwr_of_sine CS%Kh_bg_xx(i,j) = MAX(Kh_sin_lat * slat_fn, CS%Kh_bg_xx(i,j)) endif - if (CS%bound_Kh .and. .not.CS%better_bound_Kh) then ! Limit the background viscosity to be numerically stable CS%Kh_Max_xx(i,j) = Kh_Limit * grid_sp_h2 CS%Kh_bg_xx(i,j) = MIN(CS%Kh_bg_xx(i,j), CS%Kh_Max_xx(i,j)) endif enddo ; enddo - ! Calculate and store the background viscosity at q-points do J=js-1,Jeq ; do I=is-1,Ieq ! Static factors in the Smagorinsky and Leith schemes @@ -1831,17 +1804,14 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) if (CS%Leith_Kh) CS%Laplac3_const_xy(I,J) = Leith_Lap_const * grid_sp_q3 ! Maximum of constant background and MICOM viscosity CS%Kh_bg_xy(I,J) = MAX(Kh, Kh_vel_scale * sqrt(grid_sp_q2)) - ! Use the larger of the above and values read from a file !### This expression uses inconsistent staggering if (CS%use_Kh_bg_2d) CS%Kh_bg_xy(I,J) = MAX(CS%Kh_bg_2d(i,j), CS%Kh_bg_xy(I,J)) - ! Use the larger of the above and a function of sin(latitude) if (Kh_sin_lat>0.) then slat_fn = abs( sin( deg2rad * G%geoLatBu(I,J) ) ) ** Kh_pwr_of_sine CS%Kh_bg_xy(I,J) = MAX(Kh_sin_lat * slat_fn, CS%Kh_bg_xy(I,J)) endif - if (CS%bound_Kh .and. .not.CS%better_bound_Kh) then ! Limit the background viscosity to be numerically stable CS%Kh_Max_xy(I,J) = Kh_Limit * grid_sp_q2 @@ -1849,9 +1819,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif enddo ; enddo endif - if (CS%biharmonic) then - do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 CS%Idx2dyCu(I,j) = (G%IdxCu(I,j)*G%IdxCu(I,j)) * G%IdyCu(I,j) CS%Idxdy2u(I,j) = G%IdxCu(I,j) * (G%IdyCu(I,j)*G%IdyCu(I,j)) @@ -1860,7 +1828,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%Idx2dyCv(i,J) = (G%IdxCv(i,J)*G%IdxCv(i,J)) * G%IdyCv(i,J) CS%Idxdy2v(i,J) = G%IdxCv(i,J) * (G%IdyCv(i,J)*G%IdyCv(i,J)) enddo ; enddo - CS%Ah_bg_xy(:,:) = 0.0 ! The 0.3 below was 0.4 in MOM1.10. The change in hq requires ! this to be less than 1/3, rather than 1/2 as before. @@ -1870,7 +1837,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j)+CS%dy2h(i,j)) grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2) - if (CS%Smagorinsky_Ah) then CS%Biharm_const_xx(i,j) = Smag_bi_const * (grid_sp_h2 * grid_sp_h2) if (CS%bound_Coriolis) then @@ -1884,6 +1850,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%biharm5_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h2) endif CS%Ah_bg_xx(i,j) = MAX(Ah, Ah_vel_scale * grid_sp_h2 * sqrt(grid_sp_h2)) + if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xx(i,j) = grid_sp_h3 / CS%Re_Ah if (Ah_time_scale > 0.) CS%Ah_bg_xx(i,j) = & MAX(CS%Ah_bg_xx(i,j), (grid_sp_h2 * grid_sp_h2) / Ah_time_scale) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then @@ -1894,7 +1861,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) do J=js-1,Jeq ; do I=is-1,Ieq grid_sp_q2 = (2.0*CS%dx2q(I,J)*CS%dy2q(I,J)) / (CS%dx2q(I,J)+CS%dy2q(I,J)) grid_sp_q3 = grid_sp_q2*sqrt(grid_sp_q2) - if (CS%Smagorinsky_Ah) then CS%Biharm_const_xy(I,J) = Smag_bi_const * (grid_sp_q2 * grid_sp_q2) if (CS%bound_Coriolis) then @@ -1905,8 +1871,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) if (CS%Leith_Ah) then CS%biharm5_const_xy(i,j) = Leith_bi_const * (grid_sp_q3 * grid_sp_q2) endif - CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2)) + if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xy(i,j) = grid_sp_q3 / CS%Re_Ah if (Ah_time_scale > 0.) CS%Ah_bg_xy(i,j) = & MAX(CS%Ah_bg_xy(i,j), (grid_sp_q2 * grid_sp_q2) / Ah_time_scale) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then @@ -1915,7 +1881,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif enddo ; enddo endif - ! The Laplacian bounds should avoid overshoots when CS%bound_coef < 1. if (CS%Laplacian .and. CS%better_bound_Kh) then Idt = 1.0 / dt @@ -1944,7 +1909,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) call Bchksum(CS%Kh_Max_xy, "Kh_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) endif endif - ! The biharmonic bounds should avoid overshoots when CS%bound_coef < 0.5, but ! empirically work for CS%bound_coef <~ 1.0 if (CS%biharmonic .and. CS%better_bound_Ah) then @@ -1954,7 +1918,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) ) + & CS%Idx2dyCu(I,j)*(CS%dx2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j)) + & CS%dx2q(I,J-1)*CS%DX_dyBu(I,J-1)*(G%IdxCu(I,j) + G%IdxCu(I,j-1)) ) ) - u0v(I,j) = (CS%Idxdy2u(I,j)*(CS%dy2h(i+1,j)*CS%DX_dyT(i+1,j)*(G%IdxCv(i+1,J) + G%IdxCv(i+1,J-1)) + & CS%dy2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1)) ) + & CS%Idx2dyCu(I,j)*(CS%dx2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J)) + & @@ -1965,13 +1928,11 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%dy2q(I-1,J)*CS%DX_dyBu(I-1,J)*(G%IdxCu(I-1,j+1) + G%IdxCu(I-1,j)) ) + & CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*CS%DY_dxT(i,j+1)*(G%IdyCu(I,j+1) + G%IdyCu(I-1,j+1)) + & CS%dx2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) ) ) - v0v(i,J) = (CS%Idxdy2v(i,J)*(CS%dy2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J)) + & CS%dy2q(I-1,J)*CS%DY_dxBu(I-1,J)*(G%IdyCv(i,J) + G%IdyCv(i-1,J)) ) + & CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*CS%DX_dyT(i,j+1)*(G%IdxCv(i,J+1) + G%IdxCv(i,J)) + & CS%dx2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1)) ) ) enddo ; enddo - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 denom = max( & (CS%dy2h(i,j) * & @@ -1986,7 +1947,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) if (denom > 0.0) & CS%Ah_Max_xx(I,J) = CS%bound_coef * 0.5 * Idt / denom enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq denom = max( & (CS%dx2q(I,J) * & @@ -2006,74 +1966,56 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) call Bchksum(CS%Ah_Max_xy, "Ah_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) endif endif - ! Register fields for output from this module. - CS%id_diffu = register_diag_field('ocean_model', 'diffu', diag%axesCuL, Time, & 'Zonal Acceleration from Horizontal Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) - CS%id_diffv = register_diag_field('ocean_model', 'diffv', diag%axesCvL, Time, & 'Meridional Acceleration from Horizontal Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) - if (CS%biharmonic) then CS%id_Ah_h = register_diag_field('ocean_model', 'Ahh', diag%axesTL, Time, & 'Biharmonic Horizontal Viscosity at h Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T, & cmor_field_name='difmxybo', & cmor_long_name='Ocean lateral biharmonic viscosity', & cmor_standard_name='ocean_momentum_xy_biharmonic_diffusivity') - CS%id_Ah_q = register_diag_field('ocean_model', 'Ahq', diag%axesBL, Time, & 'Biharmonic Horizontal Viscosity at q Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T) endif - if (CS%Laplacian) then CS%id_Kh_h = register_diag_field('ocean_model', 'Khh', diag%axesTL, Time, & 'Laplacian Horizontal Viscosity at h Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T, & cmor_field_name='difmxylo', & cmor_long_name='Ocean lateral Laplacian viscosity', & cmor_standard_name='ocean_momentum_xy_laplacian_diffusivity') - CS%id_Kh_q = register_diag_field('ocean_model', 'Khq', diag%axesBL, Time, & 'Laplacian Horizontal Viscosity at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - if (CS%Leith_Kh) then CS%id_vort_xy_q = register_diag_field('ocean_model', 'vort_xy_q', diag%axesBL, Time, & 'Vertical vorticity at q Points', 's-1', conversion=US%s_to_T) - CS%id_div_xx_h = register_diag_field('ocean_model', 'div_xx_h', diag%axesTL, Time, & 'Horizontal divergence at h Points', 's-1', conversion=US%s_to_T) endif - endif - if (CS%use_GME) then CS%id_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, & 'GME coefficient at h Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_GME_coeff_q = register_diag_field('ocean_model', 'GME_coeff_q', diag%axesBL, Time, & 'GME coefficient at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_FrictWork_GME = register_diag_field('ocean_model','FrictWork_GME',diag%axesTL,Time,& 'Integral work done by lateral friction terms in GME (excluding diffusion of energy)', & 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2) endif - CS%id_FrictWork = register_diag_field('ocean_model','FrictWork',diag%axesTL,Time,& 'Integral work done by lateral friction terms', & 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2) - CS%id_FrictWorkIntz = register_diag_field('ocean_model','FrictWorkIntz',diag%axesT1,Time, & 'Depth integrated work done by lateral friction', & 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2, & cmor_field_name='dispkexyfo', & cmor_long_name='Depth integrated ocean kinetic energy dissipation due to lateral friction',& cmor_standard_name='ocean_kinetic_energy_dissipation_per_unit_area_due_to_xy_friction') - if (CS%Laplacian .or. get_all) then endif - end subroutine hor_visc_init - !> Calculates factors in the anisotropic orientation tensor to be align with the grid. !! With n1=1 and n2=0, this recovers the approach of Large et al, 2001. subroutine align_aniso_tensor_to_grid(CS, n1, n2) @@ -2082,18 +2024,14 @@ subroutine align_aniso_tensor_to_grid(CS, n1, n2) real, intent(in) :: n2 !< j-component of direction vector [nondim] ! Local variables real :: recip_n2_norm - ! For normalizing n=(n1,n2) in case arguments are not a unit vector recip_n2_norm = n1**2 + n2**2 if (recip_n2_norm > 0.) recip_n2_norm = 1./recip_n2_norm - CS%n1n2_h(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm CS%n1n2_q(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm CS%n1n1_m_n2n2_h(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm CS%n1n1_m_n2n2_q(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm - end subroutine align_aniso_tensor_to_grid - !> Apply a 1-1-4-1-1 Laplacian filter one time on GME diffusive flux to reduce any !! horizontal two-grid-point noise subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) @@ -2104,15 +2042,12 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) !! at h points real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: GME_flux_q!< GME diffusive flux !! at q points - ! local variables real, dimension(SZI_(G),SZJ_(G)) :: GME_flux_h_original real, dimension(SZIB_(G),SZJB_(G)) :: GME_flux_q_original real :: wc, ww, we, wn, ws ! averaging weights for smoothing integer :: i, j, k, s - do s=1,1 - ! Update halos if (present(GME_flux_h)) then call pass_var(GME_flux_h, G%Domain) @@ -2122,14 +2057,12 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) do i = G%isc, G%iec ! skip land points if (G%mask2dT(i,j)==0.) cycle - ! compute weights ww = 0.125 * G%mask2dT(i-1,j) we = 0.125 * G%mask2dT(i+1,j) ws = 0.125 * G%mask2dT(i,j-1) wn = 0.125 * G%mask2dT(i,j+1) wc = 1.0 - (ww+we+wn+ws) - GME_flux_h(i,j) = wc * GME_flux_h_original(i,j) & + ww * GME_flux_h_original(i-1,j) & + we * GME_flux_h_original(i+1,j) & @@ -2137,7 +2070,6 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) + wn * GME_flux_h_original(i,j+1) enddo; enddo endif - ! Update halos if (present(GME_flux_q)) then call pass_var(GME_flux_q, G%Domain, position=CORNER, complete=.true.) @@ -2147,14 +2079,12 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) do I = G%IscB, G%IecB ! skip land points if (G%mask2dBu(I,J)==0.) cycle - ! compute weights ww = 0.125 * G%mask2dBu(I-1,J) we = 0.125 * G%mask2dBu(I+1,J) ws = 0.125 * G%mask2dBu(I,J-1) wn = 0.125 * G%mask2dBu(I,J+1) wc = 1.0 - (ww+we+wn+ws) - GME_flux_q(I,J) = wc * GME_flux_q_original(I,J) & + ww * GME_flux_q_original(I-1,J) & + we * GME_flux_q_original(I+1,J) & @@ -2162,22 +2092,17 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) + wn * GME_flux_q_original(I,J+1) enddo; enddo endif - enddo ! s-loop - end subroutine smooth_GME - !> Deallocates any variables allocated in hor_visc_init. subroutine hor_visc_end(CS) type(hor_visc_CS), pointer :: CS !< The control structure returned by a !! previous call to hor_visc_init. - if (CS%Laplacian .or. CS%biharmonic) then DEALLOC_(CS%dx2h) ; DEALLOC_(CS%dx2q) ; DEALLOC_(CS%dy2h) ; DEALLOC_(CS%dy2q) DEALLOC_(CS%dx_dyT) ; DEALLOC_(CS%dy_dxT) ; DEALLOC_(CS%dx_dyBu) ; DEALLOC_(CS%dy_dxBu) DEALLOC_(CS%reduction_xx) ; DEALLOC_(CS%reduction_xy) endif - if (CS%Laplacian) then DEALLOC_(CS%Kh_bg_xx) ; DEALLOC_(CS%Kh_bg_xy) if (CS%bound_Kh) then @@ -2190,7 +2115,6 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%Laplac3_const_xx) ; DEALLOC_(CS%Laplac3_const_xy) endif endif - if (CS%biharmonic) then DEALLOC_(CS%Idx2dyCu) ; DEALLOC_(CS%Idx2dyCv) DEALLOC_(CS%Idxdy2u) ; DEALLOC_(CS%Idxdy2v) @@ -2207,6 +2131,9 @@ subroutine hor_visc_end(CS) if (CS%Leith_Ah) then DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) endif + if (CS%Re_Ah > 0.0) then + DEALLOC_(CS%Re_Ah_const_xx) ; DEALLOC_(CS%Re_Ah_const_xy) + endif endif if (CS%anisotropic) then DEALLOC_(CS%n1n2_h) @@ -2215,10 +2142,7 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%n1n1_m_n2n2_q) endif deallocate(CS) - end subroutine hor_visc_end - - !> \namespace mom_hor_visc !! !! This module contains the subroutine horizontal_viscosity() that calculates the @@ -2519,5 +2443,4 @@ end subroutine hor_visc_end !! Smith, R.D., and McWilliams, J.C., 2003: Anisotropic horizontal viscosity for !! ocean models. Ocean Modelling, 5(2), 129-156. !! https://doi.org/10.1016/S1463-5003(02)00016-1 - end module MOM_hor_visc From 65f36d76866904f53fb9f73a498365bcd2806e8f Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 16 Apr 2020 10:40:02 -0600 Subject: [PATCH 009/103] Add diags for Lapl. and Bihar grid Reynolds #s grid_Re_Kh = (U sqtr(dx2))/Kh grid_Re_Kh = (U dx3)/Ah where dx2 is the harmonic mean of the squares of the grid [L2], and dx3 is the harmonic mean of the squares of the grid^(3/2) [L3] --- .../lateral/MOM_hor_visc.F90 | 33 +++++++++++++++++-- 1 file changed, 30 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index f3c593819a..1458706316 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -117,8 +117,9 @@ module MOM_hor_visc Kh_Max_xx, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. Ah_Max_xx, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. n1n2_h, & !< Factor n1*n2 in the anisotropic direction tensor at h-points - n1n1_m_n2n2_h !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points - + n1n1_m_n2n2_h, & !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points + grid_sp_h2, & !< Harmonic mean of the squares of the grid [L2 ~> m2] + grid_sp_h3 !< Harmonic mean of the squares of the grid^(3/2) [L3 ~> m3] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Kh_bg_xy !< The background Laplacian viscosity at q points [L2 T-1 ~> m2 s-1]. !! The actual viscosity may be the larger of this @@ -180,6 +181,7 @@ module MOM_hor_visc !>@{ !! Diagnostic id + integer :: id_grid_Re_Ah = -1, id_grid_Re_Kh = -1 integer :: id_diffu = -1, id_diffv = -1 integer :: id_Ah_h = -1, id_Ah_q = -1 integer :: id_Kh_h = -1, id_Kh_q = -1 @@ -304,9 +306,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Kh_h, & ! Laplacian viscosity at thickness points [L2 T-1 ~> m2 s-1] max_diss_rate_h, & ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] FrictWork, & ! work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] - FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] + FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] div_xx_h ! horizontal divergence [T-1 ~> s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + grid_Re_Kh, & !< Grid Reynolds number for Laplacian horizontal viscosity at h points [nondim] + grid_Re_Ah, & !< Grid Reynolds number for Biharmonic horizontal viscosity at h points [nondim] GME_coeff_h !< GME coeff. at h-points [L2 T-1 ~> m2 s-1] real :: Ah ! biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Kh ! Laplacian viscosity [L2 T-1 ~> m2 s-1] @@ -842,6 +846,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if ((CS%id_Kh_h>0) .or. find_FrictWork .or. CS%debug) Kh_h(i,j,k) = Kh + + if (CS%id_grid_Re_Kh>0) then + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j)))/Kh + endif + if (CS%id_div_xx_h>0) div_xx_h(i,j,k) = div_xx(i,j) str_xx(i,j) = -Kh * sh_xx(i,j) @@ -890,6 +900,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if ((CS%id_Ah_h>0) .or. find_FrictWork .or. CS%debug) Ah_h(i,j,k) = Ah + if (CS%id_grid_Re_Ah>0) then + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j))/Ah + endif + str_xx(i,j) = str_xx(i,j) + Ah * & (CS%DY_dxT(i,j) * (G%IdyCu(I,j)*Del2u(I,j) - G%IdyCu(I-1,j)*Del2u(I-1,j)) - & CS%DX_dyT(i,j) * (G%IdxCv(i,J)*Del2v(i,J) - G%IdxCv(i,J-1)*Del2v(i,J-1))) @@ -1295,10 +1310,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_FrictWork>0) call post_data(CS%id_FrictWork, FrictWork, CS%diag) if (CS%id_FrictWork_GME>0) call post_data(CS%id_FrictWork_GME, FrictWork_GME, CS%diag) if (CS%id_Ah_h>0) call post_data(CS%id_Ah_h, Ah_h, CS%diag) + if (CS%id_grid_Re_Ah>0) call post_data(CS%id_grid_Re_Ah, grid_Re_Ah, CS%diag) if (CS%id_div_xx_h>0) call post_data(CS%id_div_xx_h, div_xx_h, CS%diag) if (CS%id_vort_xy_q>0) call post_data(CS%id_vort_xy_q, vort_xy_q, CS%diag) if (CS%id_Ah_q>0) call post_data(CS%id_Ah_q, Ah_q, CS%diag) if (CS%id_Kh_h>0) call post_data(CS%id_Kh_h, Kh_h, CS%diag) + if (CS%id_grid_Re_Kh>0) call post_data(CS%id_grid_Re_Kh, grid_Re_Kh, CS%diag) if (CS%id_Kh_q>0) call post_data(CS%id_Kh_q, Kh_q, CS%diag) if (CS%id_GME_coeff_h > 0) call post_data(CS%id_GME_coeff_h, GME_coeff_h, CS%diag) if (CS%id_GME_coeff_q > 0) call post_data(CS%id_GME_coeff_q, GME_coeff_q, CS%diag) @@ -1658,6 +1675,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) ALLOC_(CS%dx_dyBu(IsdB:IedB,JsdB:JedB)) ; CS%dx_dyBu(:,:) = 0.0 ALLOC_(CS%dy_dxBu(IsdB:IedB,JsdB:JedB)) ; CS%dy_dxBu(:,:) = 0.0 if (CS%Laplacian) then + ALLOC_(CS%grid_sp_h2(isd:ied,jsd:jed)) ; CS%grid_sp_h2(:,:) = 0.0 ALLOC_(CS%Kh_bg_xx(isd:ied,jsd:jed)) ; CS%Kh_bg_xx(:,:) = 0.0 ALLOC_(CS%Kh_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_bg_xy(:,:) = 0.0 if (CS%bound_Kh .or. CS%better_bound_Kh) then @@ -1710,6 +1728,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) ALLOC_(CS%Idxdy2v(isd:ied,JsdB:JedB)) ; CS%Idxdy2v(:,:) = 0.0 ALLOC_(CS%Ah_bg_xx(isd:ied,jsd:jed)) ; CS%Ah_bg_xx(:,:) = 0.0 ALLOC_(CS%Ah_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_bg_xy(:,:) = 0.0 + ALLOC_(CS%grid_sp_h3(IsdB:IedB,JsdB:JedB)); CS%grid_sp_h3(:,:) = 0.0 if (CS%bound_Ah .or. CS%better_bound_Ah) then ALLOC_(CS%Ah_Max_xx(isd:ied,jsd:jed)) ; CS%Ah_Max_xx(:,:) = 0.0 ALLOC_(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_Max_xy(:,:) = 0.0 @@ -1777,6 +1796,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ! Static factors in the Smagorinsky and Leith schemes grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j) + CS%dy2h(i,j)) + CS%grid_sp_h2(i,j) = grid_sp_h2 grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2) if (CS%Smagorinsky_Kh) CS%Laplac2_const_xx(i,j) = Smag_Lap_const * grid_sp_h2 if (CS%Leith_Kh) CS%Laplac3_const_xx(i,j) = Leith_Lap_const * grid_sp_h3 @@ -1837,6 +1857,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j)+CS%dy2h(i,j)) grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2) + CS%grid_sp_h3(i,j) = grid_sp_h3 if (CS%Smagorinsky_Ah) then CS%Biharm_const_xx(i,j) = Smag_bi_const * (grid_sp_h2 * grid_sp_h2) if (CS%bound_Coriolis) then @@ -1979,6 +2000,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) cmor_standard_name='ocean_momentum_xy_biharmonic_diffusivity') CS%id_Ah_q = register_diag_field('ocean_model', 'Ahq', diag%axesBL, Time, & 'Biharmonic Horizontal Viscosity at q Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T) + CS%id_grid_Re_Ah = register_diag_field('ocean_model', 'grid_Re_Ah', diag%axesTL, Time, & + 'Grid Reynolds number for the Biharmonic horizontal viscosity at h points', 'nondim') endif if (CS%Laplacian) then CS%id_Kh_h = register_diag_field('ocean_model', 'Khh', diag%axesTL, Time, & @@ -1988,6 +2011,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) cmor_standard_name='ocean_momentum_xy_laplacian_diffusivity') CS%id_Kh_q = register_diag_field('ocean_model', 'Khq', diag%axesBL, Time, & 'Laplacian Horizontal Viscosity at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_grid_Re_Kh = register_diag_field('ocean_model', 'grid_Re_Kh', diag%axesTL, Time, & + 'Grid Reynolds number for the Laplacian horizontal viscosity at h points', 'nondim') if (CS%Leith_Kh) then CS%id_vort_xy_q = register_diag_field('ocean_model', 'vort_xy_q', diag%axesBL, Time, & 'Vertical vorticity at q Points', 's-1', conversion=US%s_to_T) @@ -2105,6 +2130,7 @@ subroutine hor_visc_end(CS) endif if (CS%Laplacian) then DEALLOC_(CS%Kh_bg_xx) ; DEALLOC_(CS%Kh_bg_xy) + DEALLOC_(CS%grid_sp_h2) if (CS%bound_Kh) then DEALLOC_(CS%Kh_Max_xx) ; DEALLOC_(CS%Kh_Max_xy) endif @@ -2116,6 +2142,7 @@ subroutine hor_visc_end(CS) endif endif if (CS%biharmonic) then + DEALLOC_(CS%grid_sp_h3) DEALLOC_(CS%Idx2dyCu) ; DEALLOC_(CS%Idx2dyCv) DEALLOC_(CS%Idxdy2u) ; DEALLOC_(CS%Idxdy2v) DEALLOC_(CS%Ah_bg_xx) ; DEALLOC_(CS%Ah_bg_xy) From 49ab54ab5a6491728dd0b6b60ac58e6e87739e92 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Fri, 17 Apr 2020 08:21:24 -0600 Subject: [PATCH 010/103] move pass_var in KPP smoothing outside the do-loop --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 6056dd3eab..8151511bbf 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -225,6 +225,11 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'The number of times the 1-1-4-1-1 Laplacian filter is applied on '// & 'OBL depth.', & default=0) + if ((CS%n_smooth > G%domain%nihalo) then + call MOM_error(FATAL,'KPP smoothing number (N_SMOOTH) cannot be greater than NIHALO.') + elseif ((CS%n_smooth > G%domain%njhalo) then + call MOM_error(FATAL,'KPP smoothing number (N_SMOOTH) cannot be greater than NJHALO.') + endif if (CS%n_smooth > 0) then call get_param(paramFile, mdl, 'DEEPEN_ONLY_VIA_SMOOTHING', CS%deepen_only, & 'If true, apply OBLdepth smoothing at a cell only if the OBLdepth '// & @@ -1362,10 +1367,10 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real :: pref integer :: i, j, k, s - do s=1,CS%n_smooth + ! Update halos + call pass_var(CS%OBLdepth, G%Domain, halo=CS%n_smooth) - ! Update halos - call pass_var(CS%OBLdepth, G%Domain) + do s=1,CS%n_smooth OBLdepth_original = CS%OBLdepth if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = OBLdepth_original From b609dead273f162d47f4d80d4062d56e59fb4232 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 17 Apr 2020 16:41:09 -0600 Subject: [PATCH 011/103] Fix indices in KE calculation Hoping this will fix the floating point exception in symmetric mode. --- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 1458706316..e18b626c37 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1073,7 +1073,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%Re_Ah > 0.0) then - KE = 0.125*((u(I,j,k)+u(I,j+1,k))**2 + (v(i,J,k)+v(i+1,J,k))**2) + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) Ah = sqrt(KE) * CS%Re_Ah_const_xy(i,j) endif From 3fb86e3ed4f7bf1eae44a1c6bb2564ad65c8ad66 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 21 Apr 2020 12:18:34 -0600 Subject: [PATCH 012/103] Avoid division by zero This PR add two hard-coded parameters (AH_min and KH_min) to avoid dividing by zero when computing the Biharmonic and Laplacian grid Reynolds numbers, respectively. It also fixed the size of an array used in the Biharmonic Re calculation. --- src/parameterizations/lateral/MOM_hor_visc.F90 | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index e18b626c37..de00aa4a96 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -348,6 +348,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! calculation gives the same value as if f were 0 [nondim]. real :: H0_GME ! Depth used to scale down GME coefficient in shallow areas [Z ~> m] real :: KE ! Local kinetic energy [L2 T-2 ~> m2 s-2] + real, parameter :: KH_min = 1.E-30 ! This is the minimun horizontal Laplacian viscosity used to estimate the + ! grid Raynolds number [L2 T-1 ~> m2 s-1] + real, parameter :: AH_min = 1.E-30 ! This is the minimun horizontal Biharmonic viscosity used to estimate the + ! grid Raynolds number [L4 T-1 ~> m4 s-1] + logical :: rescale_Kh, legacy_bound logical :: find_FrictWork logical :: apply_OBC = .false. @@ -849,7 +854,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_grid_Re_Kh>0) then KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) - grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j)))/Kh + grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j)))/MAX(Kh,KH_min) endif if (CS%id_div_xx_h>0) div_xx_h(i,j,k) = div_xx(i,j) @@ -902,7 +907,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_grid_Re_Ah>0) then KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) - grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j))/Ah + grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j))/MAX(Ah,AH_min) endif str_xx(i,j) = str_xx(i,j) + Ah * & @@ -1728,7 +1733,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) ALLOC_(CS%Idxdy2v(isd:ied,JsdB:JedB)) ; CS%Idxdy2v(:,:) = 0.0 ALLOC_(CS%Ah_bg_xx(isd:ied,jsd:jed)) ; CS%Ah_bg_xx(:,:) = 0.0 ALLOC_(CS%Ah_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_bg_xy(:,:) = 0.0 - ALLOC_(CS%grid_sp_h3(IsdB:IedB,JsdB:JedB)); CS%grid_sp_h3(:,:) = 0.0 + ALLOC_(CS%grid_sp_h3(isd:ied,jsd:jed)) ; CS%grid_sp_h3(:,:) = 0.0 if (CS%bound_Ah .or. CS%better_bound_Ah) then ALLOC_(CS%Ah_Max_xx(isd:ied,jsd:jed)) ; CS%Ah_Max_xx(:,:) = 0.0 ALLOC_(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_Max_xy(:,:) = 0.0 From e955c6d9ad0f9f1b6cc6555b5443a0ce0a49c60a Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 21 Apr 2020 14:13:44 -0600 Subject: [PATCH 013/103] Fix openmp directives --- src/parameterizations/lateral/MOM_hor_visc.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index de00aa4a96..19e0586bfd 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -478,12 +478,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & !$OMP use_MEKE_Ku, use_MEKE_Au, boundary_mask_h, boundary_mask_q, & - !$OMP backscat_subround, GME_coeff_limiter, & + !$OMP backscat_subround, GME_coeff_limiter, KH_min, AH_min, & !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI5, H0_GME, & !$OMP diffu, diffv, max_diss_rate_h, max_diss_rate_q, & !$OMP Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, vort_xy_q, GME_coeff_h, GME_coeff_q, & - !$OMP TD, KH_u_GME, KH_v_GME & + !$OMP TD, KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, & !$OMP ) & !$OMP private( & !$OMP i, j, k, n, & @@ -497,7 +497,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP grad_vel_mag_bt_h, grad_vel_mag_bt_q, grad_d2vel_mag_h, & !$OMP meke_res_fn, Shear_mag, vert_vort_mag, hrat_min, visc_bound_rem, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & - !$OMP dDel2vdx, dDel2udy, & + !$OMP dDel2vdx, dDel2udy, KE, & !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & !$OMP ) do k=1,nz From e3cbcbbd0dd2a213c8bf15f6a0067591772034ae Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 21 Apr 2020 14:13:44 -0600 Subject: [PATCH 014/103] Fix openmp directives --- src/parameterizations/lateral/MOM_hor_visc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index de00aa4a96..7f5e63394f 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -483,7 +483,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP diffu, diffv, max_diss_rate_h, max_diss_rate_q, & !$OMP Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, vort_xy_q, GME_coeff_h, GME_coeff_q, & - !$OMP TD, KH_u_GME, KH_v_GME & + !$OMP TD, KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah & !$OMP ) & !$OMP private( & !$OMP i, j, k, n, & @@ -497,7 +497,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP grad_vel_mag_bt_h, grad_vel_mag_bt_q, grad_d2vel_mag_h, & !$OMP meke_res_fn, Shear_mag, vert_vort_mag, hrat_min, visc_bound_rem, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & - !$OMP dDel2vdx, dDel2udy, & + !$OMP dDel2vdx, dDel2udy, KE, & !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & !$OMP ) do k=1,nz From 1e7fa519b1004af16ab8cf417a0b4ef650899f74 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 21 Apr 2020 21:41:37 -0600 Subject: [PATCH 015/103] add KPP timing clocks and omp directives --- .../vertical/MOM_CVMix_KPP.F90 | 31 +++++++++++++++++-- 1 file changed, 29 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 8151511bbf..b17d91ff8d 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -16,6 +16,8 @@ module MOM_CVMix_KPP use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS, Get_Langmuir_Number use MOM_domains, only : pass_var +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE use CVMix_kpp, only : CVMix_init_kpp, CVMix_put_kpp, CVMix_get_kpp_real use CVMix_kpp, only : CVMix_coeffs_kpp @@ -168,6 +170,10 @@ module MOM_CVMix_KPP end type KPP_CS +!>@{ CPU time clocks +integer :: id_clock_KPP_calc, id_clock_KPP_compute_BLD, id_clock_KPP_smoothing +!!@} + #define __DO_SAFETY_CHECKS__ contains @@ -225,9 +231,9 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'The number of times the 1-1-4-1-1 Laplacian filter is applied on '// & 'OBL depth.', & default=0) - if ((CS%n_smooth > G%domain%nihalo) then + if (CS%n_smooth > G%domain%nihalo) then call MOM_error(FATAL,'KPP smoothing number (N_SMOOTH) cannot be greater than NIHALO.') - elseif ((CS%n_smooth > G%domain%njhalo) then + elseif (CS%n_smooth > G%domain%njhalo) then call MOM_error(FATAL,'KPP smoothing number (N_SMOOTH) cannot be greater than NJHALO.') endif if (CS%n_smooth > 0) then @@ -235,6 +241,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'If true, apply OBLdepth smoothing at a cell only if the OBLdepth '// & 'gets deeper via smoothing.', & default=.false.) + id_clock_KPP_smoothing = cpu_clock_id('Ocean KPP BLD smoothing)', grain=CLOCK_ROUTINE) endif call get_param(paramFile, mdl, 'RI_CRIT', CS%Ri_crit, & 'Critical bulk Richardson number used to define depth of the '// & @@ -582,6 +589,8 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) if (CS%id_EnhK > 0) allocate( CS%EnhK( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) if (CS%id_EnhK > 0) CS%EnhK(:,:,:) = 0. + id_clock_KPP_calc = cpu_clock_id('Ocean KPP calculate)', grain=CLOCK_MODULE) + id_clock_KPP_compute_BLD = cpu_clock_id('Ocean KPP comp BLD)', grain=CLOCK_ROUTINE) end function KPP_init @@ -643,6 +652,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & if (CS%id_Kd_in > 0) call post_data(CS%id_Kd_in, Kt, CS%diag) + call cpu_clock_begin(id_clock_KPP_calc) buoy_scale = US%L_to_m**2*US%s_to_T**3 !$OMP parallel do default(none) firstprivate(nonLocalTrans) & @@ -863,6 +873,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & enddo ! i enddo ! j + call cpu_clock_end(id_clock_KPP_calc) #ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then @@ -962,6 +973,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF endif #endif + !call cpu_clock_begin(id_clock_KPP_compute_BLD) + ! some constants GoRho = GV%mks_g_Earth / (US%R_to_kg_m3*GV%Rho0) buoy_scale = US%L_to_m**2*US%s_to_T**3 @@ -1327,6 +1340,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF enddo enddo + !call cpu_clock_end(id_clock_KPP_compute_BLD) + ! send diagnostics to post_data if (CS%id_BulkRi > 0) call post_data(CS%id_BulkRi, CS%BulkRi, CS%diag) if (CS%id_N > 0) call post_data(CS%id_N, CS%N, CS%diag) @@ -1367,15 +1382,20 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real :: pref integer :: i, j, k, s + !call cpu_clock_begin(id_clock_KPP_smoothing) + ! Update halos call pass_var(CS%OBLdepth, G%Domain, halo=CS%n_smooth) + do s=1,CS%n_smooth OBLdepth_original = CS%OBLdepth if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = OBLdepth_original ! apply smoothing on OBL depth + !$OMP parallel do default(none) shared(G, GV, CS, h, OBLdepth_original) & + !$OMP private(wc, ww, we, wn, ws, dh, hcorr, pref, cellHeight, iFaceHeight) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1420,6 +1440,8 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) enddo ! s-loop + !call cpu_clock_end(id_clock_KPP_smoothing) + end subroutine KPP_smooth_BLD @@ -1432,6 +1454,7 @@ subroutine KPP_get_BLD(CS, BLD, G) real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD!< bnd. layer depth [m] ! Local variables integer :: i,j + !$OMP parallel do default(none) shared(BLD, CS, G) do j = G%jsc, G%jec ; do i = G%isc, G%iec BLD(i,j) = CS%OBLdepth(i,j) enddo ; enddo @@ -1469,6 +1492,7 @@ subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & ! Update tracer due to non-local redistribution of surface flux if (CS%applyNonLocalTrans) then + !$OMP parallel do default(none) shared(dt, scalar, dtracer, G) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1483,6 +1507,7 @@ subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & if (CS%id_NLT_dTdt > 0) call post_data(CS%id_NLT_dTdt, dtracer, CS%diag) if (CS%id_NLT_temp_budget > 0) then dtracer(:,:,:) = 0.0 + !$OMP parallel do default(none) shared(dtracer, nonLocalTrans, surfFlux, C_p, G, GV) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1528,6 +1553,7 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, ! Update tracer due to non-local redistribution of surface flux if (CS%applyNonLocalTrans) then + !$OMP parallel do default(none) shared(G, dt, scalar, dtracer) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1542,6 +1568,7 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, if (CS%id_NLT_dSdt > 0) call post_data(CS%id_NLT_dSdt, dtracer, CS%diag) if (CS%id_NLT_saln_budget > 0) then dtracer(:,:,:) = 0.0 + !$OMP parallel do default(none) shared(G, GV, dtracer, nonLocalTrans, surfFlux) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec From e5fcc694d57cacd19229210a18960d28427f581b Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 22 Apr 2020 10:30:42 -0600 Subject: [PATCH 016/103] remove OMP enclosing get_BLD call --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 4 ++-- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 2 -- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index b17d91ff8d..c155bf56c7 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -241,7 +241,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'If true, apply OBLdepth smoothing at a cell only if the OBLdepth '// & 'gets deeper via smoothing.', & default=.false.) - id_clock_KPP_smoothing = cpu_clock_id('Ocean KPP BLD smoothing)', grain=CLOCK_ROUTINE) + id_clock_KPP_smoothing = cpu_clock_id('(Ocean KPP BLD smoothing)', grain=CLOCK_ROUTINE) endif call get_param(paramFile, mdl, 'RI_CRIT', CS%Ri_crit, & 'Critical bulk Richardson number used to define depth of the '// & @@ -590,7 +590,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) if (CS%id_EnhK > 0) CS%EnhK(:,:,:) = 0. id_clock_KPP_calc = cpu_clock_id('Ocean KPP calculate)', grain=CLOCK_MODULE) - id_clock_KPP_compute_BLD = cpu_clock_id('Ocean KPP comp BLD)', grain=CLOCK_ROUTINE) + id_clock_KPP_compute_BLD = cpu_clock_id('(Ocean KPP comp BLD)', grain=CLOCK_ROUTINE) end function KPP_init diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 38cecf0425..369852ce23 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -1448,9 +1448,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) if (associated(Hml)) then - !$OMP parallel default(shared) call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) - !$OMP end parallel call pass_var(Hml, G%domain, halo=1) ! If visc%MLD exists, copy KPP's BLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) From e47e8b712c8dde2abbeb89d58f2fe12bde29c303 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 22 Apr 2020 11:05:40 -0600 Subject: [PATCH 017/103] uncomment KPP clocks --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index c155bf56c7..bcf2037c12 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -973,7 +973,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF endif #endif - !call cpu_clock_begin(id_clock_KPP_compute_BLD) + call cpu_clock_begin(id_clock_KPP_compute_BLD) ! some constants GoRho = GV%mks_g_Earth / (US%R_to_kg_m3*GV%Rho0) @@ -1340,7 +1340,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF enddo enddo - !call cpu_clock_end(id_clock_KPP_compute_BLD) + call cpu_clock_end(id_clock_KPP_compute_BLD) ! send diagnostics to post_data if (CS%id_BulkRi > 0) call post_data(CS%id_BulkRi, CS%BulkRi, CS%diag) @@ -1382,7 +1382,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real :: pref integer :: i, j, k, s - !call cpu_clock_begin(id_clock_KPP_smoothing) + call cpu_clock_begin(id_clock_KPP_smoothing) ! Update halos call pass_var(CS%OBLdepth, G%Domain, halo=CS%n_smooth) @@ -1440,7 +1440,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) enddo ! s-loop - !call cpu_clock_end(id_clock_KPP_smoothing) + call cpu_clock_end(id_clock_KPP_smoothing) end subroutine KPP_smooth_BLD From 1165a61ba18b01967dc90f28cfc3428aa4e9bd7f Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 22 Apr 2020 15:11:17 -0600 Subject: [PATCH 018/103] further refactor smoothing subroutine --- .../vertical/MOM_CVMix_KPP.F90 | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index bcf2037c12..38a7bff4df 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1371,7 +1371,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] ! local - real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_original ! Original OBL depths computed by CVMix + real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_prev ! OBLdepth before s.th smoothing iteration real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface [m] ! (negative in the ocean) real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] @@ -1387,14 +1387,14 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) ! Update halos call pass_var(CS%OBLdepth, G%Domain, halo=CS%n_smooth) + if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = CS%OBLdepth do s=1,CS%n_smooth - OBLdepth_original = CS%OBLdepth - if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = OBLdepth_original + OBLdepth_prev = CS%OBLdepth ! apply smoothing on OBL depth - !$OMP parallel do default(none) shared(G, GV, CS, h, OBLdepth_original) & + !$OMP parallel do default(none) shared(G, GV, CS, h, OBLdepth_prev) & !$OMP private(wc, ww, we, wn, ws, dh, hcorr, pref, cellHeight, iFaceHeight) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1423,14 +1423,14 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) wn = 0.125 * G%mask2dT(i,j+1) wc = 1.0 - (ww+we+wn+ws) - CS%OBLdepth(i,j) = wc * OBLdepth_original(i,j) & - + ww * OBLdepth_original(i-1,j) & - + we * OBLdepth_original(i+1,j) & - + ws * OBLdepth_original(i,j-1) & - + wn * OBLdepth_original(i,j+1) + CS%OBLdepth(i,j) = wc * OBLdepth_prev(i,j) & + + ww * OBLdepth_prev(i-1,j) & + + we * OBLdepth_prev(i+1,j) & + + ws * OBLdepth_prev(i,j-1) & + + wn * OBLdepth_prev(i,j+1) ! Apply OBLdepth smoothing at a cell only if the OBLdepth gets deeper via smoothing. - if (CS%deepen_only) CS%OBLdepth(i,j) = max(CS%OBLdepth(i,j),CS%OBLdepth_original(i,j)) + if (CS%deepen_only) CS%OBLdepth(i,j) = max(CS%OBLdepth(i,j), OBLdepth_prev(i,j)) ! prevent OBL depths deeper than the bathymetric depth CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deeper than bottom From 98f5a8d97637d71c075a9f3f0b2ab1009f3836bd Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 22 Apr 2020 22:44:35 -0600 Subject: [PATCH 019/103] add omp directives to int_density_dz_generic_plm --- src/equation_of_state/MOM_EOS.F90 | 292 +++++++++++++++--------------- 1 file changed, 151 insertions(+), 141 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 5d3d33534b..c26317d3a9 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1270,6 +1270,8 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! ============================= ! 1. Compute vertical integrals ! ============================= + + !$OMP parallel do default(shared) private(jin,iin,dz,p5,S5,T5,r5,rho_anom) do j=Jsq,Jeq+1 jin = j+joff do i = Isq,Ieq+1 ; iin = i+ioff @@ -1300,163 +1302,171 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! ================================================== ! 2. Compute horizontal integrals in the x direction ! ================================================== - if (present(intx_dpa)) then ; do j=HIO%jsc,HIO%jec ; jin = j+joff - do I=Isq,Ieq ; iin = i+ioff - ! Corner values of T and S - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. - ! Note: To work in terrain following coordinates we could offset - ! this distance by the layer thickness to replicate other models. - hWght = massWeightToggle * & - max(0., -bathyT(iin,jin)-z_t(iin+1,jin), -bathyT(iin+1,jin)-z_t(iin,jin)) - if (hWght > 0.) then - hL = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff - hR = (z_t(iin+1,jin) - z_b(iin+1,jin)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(iin+1,jin) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom - Ttr = ( (hWght*hL)*T_t(iin,jin) + (hWght*hR + hR*hL)*T_t(iin+1,jin) ) * iDenom - Tbl = ( (hWght*hR)*T_b(iin+1,jin) + (hWght*hL + hR*hL)*T_b(iin,jin) ) * iDenom - Tbr = ( (hWght*hL)*T_b(iin,jin) + (hWght*hR + hR*hL)*T_b(iin+1,jin) ) * iDenom - Stl = ( (hWght*hR)*S_t(iin+1,jin) + (hWght*hL + hR*hL)*S_t(iin,jin) ) * iDenom - Str = ( (hWght*hL)*S_t(iin,jin) + (hWght*hR + hR*hL)*S_t(iin+1,jin) ) * iDenom - Sbl = ( (hWght*hR)*S_b(iin+1,jin) + (hWght*hL + hR*hL)*S_b(iin,jin) ) * iDenom - Sbr = ( (hWght*hL)*S_b(iin,jin) + (hWght*hR + hR*hL)*S_b(iin+1,jin) ) * iDenom - else - Ttl = T_t(iin,jin); Tbl = T_b(iin,jin); Ttr = T_t(iin+1,jin); Tbr = T_b(iin+1,jin) - Stl = S_t(iin,jin); Sbl = S_b(iin,jin); Str = S_t(iin+1,jin); Sbr = S_b(iin+1,jin) - endif - - do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz_x(m,i) = w_left*(z_t(iin,jin) - z_b(iin,jin)) + w_right*(z_t(iin+1,jin) - z_b(iin+1,jin)) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - pos = i*15+(m-2)*5 - T15(pos+1) = w_left*Ttl + w_right*Ttr - T15(pos+5) = w_left*Tbl + w_right*Tbr - - S15(pos+1) = w_left*Stl + w_right*Str - S15(pos+5) = w_left*Sbl + w_right*Sbr - - p15(pos+1) = -GxRho*(w_left*z_t(iin,jin) + w_right*z_t(iin+1,jin)) - - ! Pressure - do n=2,5 - p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) - enddo - - ! Salinity and temperature (linear interpolation in the vertical) - do n=2,4 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) - T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) + if (present(intx_dpa)) then + !$OMP parallel do default(shared) private(jin,iin,hWght,hL,hR,iDenom,Ttl,Ttr,Tbl,Tbr,Stl,Str,Sbl,Sbr, & + !$OMP w_left,w_right,dz_x,pos,T15,S15,p15,r15,weight_t,weight_b,intz) + do j=HIO%jsc,HIO%jec ; jin = j+joff + do I=Isq,Ieq ; iin = i+ioff + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(iin,jin)-z_t(iin+1,jin), -bathyT(iin+1,jin)-z_t(iin,jin)) + if (hWght > 0.) then + hL = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff + hR = (z_t(iin+1,jin) - z_b(iin+1,jin)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(iin+1,jin) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom + Ttr = ( (hWght*hL)*T_t(iin,jin) + (hWght*hR + hR*hL)*T_t(iin+1,jin) ) * iDenom + Tbl = ( (hWght*hR)*T_b(iin+1,jin) + (hWght*hL + hR*hL)*T_b(iin,jin) ) * iDenom + Tbr = ( (hWght*hL)*T_b(iin,jin) + (hWght*hR + hR*hL)*T_b(iin+1,jin) ) * iDenom + Stl = ( (hWght*hR)*S_t(iin+1,jin) + (hWght*hL + hR*hL)*S_t(iin,jin) ) * iDenom + Str = ( (hWght*hL)*S_t(iin,jin) + (hWght*hR + hR*hL)*S_t(iin+1,jin) ) * iDenom + Sbl = ( (hWght*hR)*S_b(iin+1,jin) + (hWght*hL + hR*hL)*S_b(iin,jin) ) * iDenom + Sbr = ( (hWght*hL)*S_b(iin,jin) + (hWght*hR + hR*hL)*S_b(iin+1,jin) ) * iDenom + else + Ttl = T_t(iin,jin); Tbl = T_b(iin,jin); Ttr = T_t(iin+1,jin); Tbr = T_b(iin+1,jin) + Stl = S_t(iin,jin); Sbl = S_b(iin,jin); Str = S_t(iin+1,jin); Sbr = S_b(iin+1,jin) + endif + + do m=2,4 + w_left = 0.25*real(5-m) ; w_right = 1.0-w_left + dz_x(m,i) = w_left*(z_t(iin,jin) - z_b(iin,jin)) + w_right*(z_t(iin+1,jin) - z_b(iin+1,jin)) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + pos = i*15+(m-2)*5 + T15(pos+1) = w_left*Ttl + w_right*Ttr + T15(pos+5) = w_left*Tbl + w_right*Tbr + + S15(pos+1) = w_left*Stl + w_right*Str + S15(pos+5) = w_left*Sbl + w_right*Sbr + + p15(pos+1) = -GxRho*(w_left*z_t(iin,jin) + w_right*z_t(iin+1,jin)) + + ! Pressure + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) + enddo + + ! Salinity and temperature (linear interpolation in the vertical) + do n=2,4 + weight_t = 0.25 * real(5-n) + weight_b = 1.0 - weight_t + S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) + T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) + enddo enddo enddo - enddo - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref) + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref) - do I=Isq,Ieq ; iin = i+ioff - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do I=Isq,Ieq ; iin = i+ioff + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - ! Use Bode's rule to estimate the pressure anomaly change. - do m = 2,4 - pos = i*15+(m-2)*5 - intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3))) + ! Use Bode's rule to estimate the pressure anomaly change. + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3))) + enddo + ! Use Bode's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) enddo - ! Use Bode's rule to integrate the bottom pressure anomaly values in x. - intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) enddo - enddo ; endif + endif ! ================================================== ! 3. Compute horizontal integrals in the y direction ! ================================================== - if (present(inty_dpa)) then ; do J=Jsq,Jeq ; jin = j+joff - do i=HIO%isc,HIO%iec ; iin = i+ioff - ! Corner values of T and S - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. - ! Note: To work in terrain following coordinates we could offset - ! this distance by the layer thickness to replicate other models. - hWght = massWeightToggle * & - max(0., -bathyT(i,j)-z_t(iin,jin+1), -bathyT(i,j+1)-z_t(iin,jin)) - if (hWght > 0.) then - hL = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff - hR = (z_t(iin,jin+1) - z_b(iin,jin+1)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(iin,jin+1) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom - Ttr = ( (hWght*hL)*T_t(iin,jin) + (hWght*hR + hR*hL)*T_t(iin,jin+1) ) * iDenom - Tbl = ( (hWght*hR)*T_b(iin,jin+1) + (hWght*hL + hR*hL)*T_b(iin,jin) ) * iDenom - Tbr = ( (hWght*hL)*T_b(iin,jin) + (hWght*hR + hR*hL)*T_b(iin,jin+1) ) * iDenom - Stl = ( (hWght*hR)*S_t(iin,jin+1) + (hWght*hL + hR*hL)*S_t(iin,jin) ) * iDenom - Str = ( (hWght*hL)*S_t(iin,jin) + (hWght*hR + hR*hL)*S_t(iin,jin+1) ) * iDenom - Sbl = ( (hWght*hR)*S_b(iin,jin+1) + (hWght*hL + hR*hL)*S_b(iin,jin) ) * iDenom - Sbr = ( (hWght*hL)*S_b(iin,jin) + (hWght*hR + hR*hL)*S_b(iin,jin+1) ) * iDenom - else - Ttl = T_t(iin,jin); Tbl = T_b(iin,jin); Ttr = T_t(iin,jin+1); Tbr = T_b(iin,jin+1) - Stl = S_t(iin,jin); Sbl = S_b(iin,jin); Str = S_t(iin,jin+1); Sbr = S_b(iin,jin+1) - endif - - do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz_y(m,i) = w_left*(z_t(iin,jin) - z_b(iin,jin)) + w_right*(z_t(iin,jin+1) - z_b(iin,jin+1)) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - pos = i*15+(m-2)*5 - T15(pos+1) = w_left*Ttl + w_right*Ttr - T15(pos+5) = w_left*Tbl + w_right*Tbr - - S15(pos+1) = w_left*Stl + w_right*Str - S15(pos+5) = w_left*Sbl + w_right*Sbr - - p15(pos+1) = -GxRho*(w_left*z_t(iin,jin) + w_right*z_t(iin,jin+1)) - - ! Pressure - do n=2,5 ; p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) ; enddo - - ! Salinity and temperature (linear interpolation in the vertical) - do n=2,4 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) - T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) + if (present(inty_dpa)) then + !$OMP parallel do default(shared) private(jin,iin,hWght,hL,hR,iDenom,Ttl,Ttr,Tbl,Tbr,Stl,Str,Sbl,Sbr, & + !$OMP w_left,w_right,dz_y,pos,T15,S15,p15,r15,weight_t,weight_b,intz) + do J=Jsq,Jeq ; jin = j+joff + do i=HIO%isc,HIO%iec ; iin = i+ioff + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-z_t(iin,jin+1), -bathyT(i,j+1)-z_t(iin,jin)) + if (hWght > 0.) then + hL = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff + hR = (z_t(iin,jin+1) - z_b(iin,jin+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(iin,jin+1) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom + Ttr = ( (hWght*hL)*T_t(iin,jin) + (hWght*hR + hR*hL)*T_t(iin,jin+1) ) * iDenom + Tbl = ( (hWght*hR)*T_b(iin,jin+1) + (hWght*hL + hR*hL)*T_b(iin,jin) ) * iDenom + Tbr = ( (hWght*hL)*T_b(iin,jin) + (hWght*hR + hR*hL)*T_b(iin,jin+1) ) * iDenom + Stl = ( (hWght*hR)*S_t(iin,jin+1) + (hWght*hL + hR*hL)*S_t(iin,jin) ) * iDenom + Str = ( (hWght*hL)*S_t(iin,jin) + (hWght*hR + hR*hL)*S_t(iin,jin+1) ) * iDenom + Sbl = ( (hWght*hR)*S_b(iin,jin+1) + (hWght*hL + hR*hL)*S_b(iin,jin) ) * iDenom + Sbr = ( (hWght*hL)*S_b(iin,jin) + (hWght*hR + hR*hL)*S_b(iin,jin+1) ) * iDenom + else + Ttl = T_t(iin,jin); Tbl = T_b(iin,jin); Ttr = T_t(iin,jin+1); Tbr = T_b(iin,jin+1) + Stl = S_t(iin,jin); Sbl = S_b(iin,jin); Str = S_t(iin,jin+1); Sbr = S_b(iin,jin+1) + endif + + do m=2,4 + w_left = 0.25*real(5-m) ; w_right = 1.0-w_left + dz_y(m,i) = w_left*(z_t(iin,jin) - z_b(iin,jin)) + w_right*(z_t(iin,jin+1) - z_b(iin,jin+1)) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + pos = i*15+(m-2)*5 + T15(pos+1) = w_left*Ttl + w_right*Ttr + T15(pos+5) = w_left*Tbl + w_right*Tbr + + S15(pos+1) = w_left*Stl + w_right*Str + S15(pos+5) = w_left*Sbl + w_right*Sbr + + p15(pos+1) = -GxRho*(w_left*z_t(iin,jin) + w_right*z_t(iin,jin+1)) + + ! Pressure + do n=2,5 ; p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) ; enddo + + ! Salinity and temperature (linear interpolation in the vertical) + do n=2,4 + weight_t = 0.25 * real(5-n) + weight_b = 1.0 - weight_t + S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) + T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) + enddo enddo enddo - enddo - call calculate_density_array(T15(15*HIO%isc+1:), S15(15*HIO%isc+1:), p15(15*HIO%isc+1:), & - r15(15*HIO%isc+1:), 1, 15*(HIO%iec-HIO%isc+1), EOS, rho_ref) - do i=HIO%isc,HIO%iec ; iin = i+ioff - intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) - - ! Use Bode's rule to estimate the pressure anomaly change. - do m = 2,4 - pos = i*15+(m-2)*5 - intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & - 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3))) + call calculate_density_array(T15(15*HIO%isc+1:), S15(15*HIO%isc+1:), p15(15*HIO%isc+1:), & + r15(15*HIO%isc+1:), 1, 15*(HIO%iec-HIO%isc+1), EOS, rho_ref) + do i=HIO%isc,HIO%iec ; iin = i+ioff + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + + ! Use Bode's rule to estimate the pressure anomaly change. + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3))) + enddo + ! Use Bode's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) enddo - ! Use Bode's rule to integrate the values. - inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) enddo - enddo ; endif + endif end subroutine int_density_dz_generic_plm ! ========================================================================== From 48310e3d61c2256f2b7f8686cbb0712a805f89a7 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 23 Apr 2020 00:40:36 -0600 Subject: [PATCH 020/103] eliminate omp parallel open/close in to int_density_dz_generic_plm --- src/equation_of_state/MOM_EOS.F90 | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index c26317d3a9..fcc5cc1352 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1271,7 +1271,11 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! 1. Compute vertical integrals ! ============================= - !$OMP parallel do default(shared) private(jin,iin,dz,p5,S5,T5,r5,rho_anom) + !$OMP parallel default(shared) private(jin,iin,dz,p5,S5,T5,r5,rho_anom,hWght,hL,hR,iDenom,Ttl,Ttr, & + !$OMP Tbl,Tbr,Stl,Str,Sbl,Sbr,w_left,w_right,dz_x,dz_y,pos,T15,S15, & + !$OMP p15,r15,weight_t,weight_b,intz) + + !$OMP do do j=Jsq,Jeq+1 jin = j+joff do i = Isq,Ieq+1 ; iin = i+ioff @@ -1303,8 +1307,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! 2. Compute horizontal integrals in the x direction ! ================================================== if (present(intx_dpa)) then - !$OMP parallel do default(shared) private(jin,iin,hWght,hL,hR,iDenom,Ttl,Ttr,Tbl,Tbr,Stl,Str,Sbl,Sbr, & - !$OMP w_left,w_right,dz_x,pos,T15,S15,p15,r15,weight_t,weight_b,intz) + !$OMP do do j=HIO%jsc,HIO%jec ; jin = j+joff do I=Isq,Ieq ; iin = i+ioff ! Corner values of T and S @@ -1388,8 +1391,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! 3. Compute horizontal integrals in the y direction ! ================================================== if (present(inty_dpa)) then - !$OMP parallel do default(shared) private(jin,iin,hWght,hL,hR,iDenom,Ttl,Ttr,Tbl,Tbr,Stl,Str,Sbl,Sbr, & - !$OMP w_left,w_right,dz_y,pos,T15,S15,p15,r15,weight_t,weight_b,intz) + !$OMP do do J=Jsq,Jeq ; jin = j+joff do i=HIO%isc,HIO%iec ; iin = i+ioff ! Corner values of T and S @@ -1467,6 +1469,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & enddo enddo endif + !$OMP end parallel end subroutine int_density_dz_generic_plm ! ========================================================================== From c53525eae1cbd37fece82be8b0093da2479bbdec Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 22 Apr 2020 17:14:25 -0600 Subject: [PATCH 021/103] Clean QG_Leith * Follow Bob's suggestion throughout the code: - remove unnecessary halo updates - change loop indices - make expressions rotationally symmetric - fix bugs in vort_xy_dy and grid_sp_v2 * clean the code by deleting commented lines --- .../lateral/MOM_lateral_mixing_coeffs.F90 | 82 +++++-------------- 1 file changed, 21 insertions(+), 61 deletions(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index d9543322c9..d616812b2f 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -93,9 +93,6 @@ module MOM_lateral_mixing_coeffs real, dimension(:,:,:), pointer :: & slope_x => NULL(), & !< Zonal isopycnal slope [nondim] slope_y => NULL(), & !< Meridional isopycnal slope [nondim] - !### These are posted as diagnostics but are never set. - N2_u => NULL(), & !< Brunt-Vaisala frequency at u-points [s-2] - N2_v => NULL(), & !< Brunt-Vaisala frequency at v-points [s-2] ebt_struct => NULL() !< Vertical structure function to scale diffusivities with [nondim] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & Laplac3_const_u !< Laplacian metric-dependent constants [L3 ~> m3] @@ -470,10 +467,6 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) if (CS%id_SN_v > 0) call post_data(CS%id_SN_v, CS%SN_v, CS%diag) if (CS%id_L2u > 0) call post_data(CS%id_L2u, CS%L2u, CS%diag) if (CS%id_L2v > 0) call post_data(CS%id_L2v, CS%L2v, CS%diag) - !### I do not believe that CS%N2_u and CS%N2_v are ever set, but because the contents - ! of CS are public, they might be set somewhere outside of this module. - if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, CS%N2_u, CS%diag) - if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, CS%N2_v, CS%diag) endif end subroutine calc_slope_functions @@ -752,8 +745,6 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type -! real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal flow [L T-1 ~> m s-1] -! real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional flow [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] integer, intent(in) :: k !< Layer for which to calculate vorticity magnitude real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: div_xx_dx !< x-derivative of horizontal divergence @@ -764,15 +755,6 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo !! (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: vort_xy_dy !< y-derivative of vertical vorticity !! (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] -! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Kh_h !< Leith Laplacian viscosity - !! at h-points [L2 T-1 ~> m2 s-1] -! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Kh_q !< Leith Laplacian viscosity - !! at q-points [L2 T-1 ~> m2 s-1] -! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Ah_h !< Leith bi-harmonic viscosity - !! at h-points [L4 T-1 ~> m4 s-1] -! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Ah_q !< Leith bi-harmonic viscosity - !! at q-points [L4 T-1 ~> m4 s-1] - ! Local variables real, dimension(SZI_(G),SZJB_(G)) :: & dslopey_dz, & ! z-derivative of y-slope at v-points [Z-1 ~> m-1] @@ -800,16 +782,9 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo inv_PI3 = 1.0/((4.0*atan(1.0))**3) - !### I believe this halo update to be unnecessary. -RWH - call pass_var(h, G%Domain) - if ((k > 1) .and. (k < nz)) then - ! Add in stretching term for the QG Leith vsicosity -! if (CS%use_QG_Leith) then - - !### do j=js-1,je+1 ; do I=is-2,Ieq+1 - do j=js-2,Jeq+2 ; do I=is-2,Ieq+1 + do j=js-1,je+1 ; do I=is-2,Ieq+1 h_at_slope_above = 2. * ( h(i,j,k-1) * h(i+1,j,k-1) ) * ( h(i,j,k) * h(i+1,j,k) ) / & ( ( h(i,j,k-1) * h(i+1,j,k-1) ) * ( h(i,j,k) + h(i+1,j,k) ) & + ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k-1) + h(i+1,j,k-1) ) + GV%H_subroundoff ) @@ -821,8 +796,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo h_at_u(I,j) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo - !### do J=js-2,Jeq+1 ; do i=is-1,ie+1 - do J=js-2,Jeq+1 ; do i=is-2,Ieq+2 + do J=js-2,Jeq+1 ; do i=is-1,ie+1 h_at_slope_above = 2. * ( h(i,j,k-1) * h(i,j+1,k-1) ) * ( h(i,j,k) * h(i,j+1,k) ) / & ( ( h(i,j,k-1) * h(i,j+1,k-1) ) * ( h(i,j,k) + h(i,j+1,k) ) & + ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k-1) + h(i,j+1,k-1) ) + GV%H_subroundoff ) @@ -834,8 +808,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo h_at_v(i,J) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo - !### do J=js-1,je ; do i=is-1,Ieq+1 - do J=js-2,Jeq+1 ; do i=is-1,Ieq+1 + do J=js-1,je ; do i=is-1,Ieq+1 f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J) ) vort_xy_dx(i,J) = vort_xy_dx(i,J) - f * US%L_to_Z * & ( ( h_at_u(I,j) * dslopex_dz(I,j) + h_at_u(I-1,j+1) * dslopex_dz(I-1,j+1) ) & @@ -843,33 +816,25 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo ( ( h_at_u(I,j) + h_at_u(I-1,j+1) ) + ( h_at_u(I-1,j) + h_at_u(I,j+1) ) + GV%H_subroundoff) enddo ; enddo - !### do j=js-1,Jeq+1 ; do I=is-1,ie - do j=js-1,Jeq+1 ; do I=is-2,Ieq+1 + do j=js-1,Jeq+1 ; do I=is-1,ie f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) - !### I think that this should be vort_xy_dy(I,j) = vort_xy_dy(I,j) - f * & - vort_xy_dy(I,j) = vort_xy_dx(I,j) - f * US%L_to_Z * & + vort_xy_dy(I,j) = vort_xy_dy(I,j) - f * US%L_to_Z * & ( ( h_at_v(i,J) * dslopey_dz(i,J) + h_at_v(i+1,J-1) * dslopey_dz(i+1,J-1) ) & + ( h_at_v(i,J-1) * dslopey_dz(i,J-1) + h_at_v(i+1,J) * dslopey_dz(i+1,J) ) ) / & ( ( h_at_v(i,J) + h_at_v(i+1,J-1) ) + ( h_at_v(i,J-1) + h_at_v(i+1,J) ) + GV%H_subroundoff) enddo ; enddo endif ! k > 1 - !### I believe this halo update to be unnecessary. -RWH - call pass_vector(vort_xy_dy,vort_xy_dx,G%Domain) - if (CS%use_QG_Leith_GM) then do j=js,je ; do I=is-1,Ieq - !### These expressions are not rotationally symmetric. Add parentheses and regroup, as in: - ! grad_vort_mag_u(I,j) = SQRT(vort_xy_dy(I,j)**2 + (0.25*((vort_xy_dx(i,J) + vort_xy_dx(i+1,J-1)) + - ! (vort_xy_dx(i+1,J) + vort_xy_dx(i,J-1))))**2 ) - grad_vort_mag_u(I,j) = SQRT(vort_xy_dy(I,j)**2 + (0.25*(vort_xy_dx(i,J) + vort_xy_dx(i+1,J) & - + vort_xy_dx(i,J-1) + vort_xy_dx(i+1,J-1)))**2) - grad_div_mag_u(I,j) = SQRT(div_xx_dx(I,j)**2 + (0.25*(div_xx_dy(i,J) + div_xx_dy(i+1,J) & - + div_xx_dy(i,J-1) + div_xx_dy(i+1,J-1)))**2) + grad_vort_mag_u(I,j) = SQRT(vort_xy_dy(I,j)**2 + (0.25*((vort_xy_dx(i,J) + vort_xy_dx(i+1,J-1)) & + + (vort_xy_dx(i+1,J) + vort_xy_dx(i,J-1))))**2) + grad_div_mag_u(I,j) = SQRT(div_xx_dx(I,j)**2 + (0.25*((div_xx_dy(i,J) + div_xx_dy(i+1,J-1)) & + + (div_xx_dy(i+1,J) + div_xx_dy(i,J-1))))**2) if (CS%use_beta_in_QG_Leith) then - beta_u(I,j) = sqrt( (0.5*(G%dF_dx(i,j)+G%dF_dx(i+1,j))**2) + & - (0.5*(G%dF_dy(i,j)+G%dF_dy(i+1,j))**2) ) + beta_u(I,j) = sqrt((0.5*(G%dF_dx(i,j)+G%dF_dx(i+1,j))**2) + & + (0.5*(G%dF_dy(i,j)+G%dF_dy(i+1,j))**2)) CS%KH_u_QG(I,j,k) = MIN(grad_vort_mag_u(I,j) + grad_div_mag_u(I,j), 3.0*beta_u(I,j)) * & CS%Laplac3_const_u(I,j) * inv_PI3 else @@ -879,14 +844,13 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo enddo ; enddo do J=js-1,Jeq ; do i=is,ie - !### These expressions are not rotationally symmetric. Add parentheses and regroup. - grad_vort_mag_v(i,J) = SQRT(vort_xy_dx(i,J)**2 + (0.25*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j) & - + vort_xy_dy(I,j+1) + vort_xy_dy(I-1,j+1)))**2) - grad_div_mag_v(i,J) = SQRT(div_xx_dy(i,J)**2 + (0.25*(div_xx_dx(I,j) + div_xx_dx(I-1,j) & - + div_xx_dx(I,j+1) + div_xx_dx(I-1,j+1)))**2) + grad_vort_mag_v(i,J) = SQRT(vort_xy_dx(i,J)**2 + (0.25*((vort_xy_dy(I,j) + vort_xy_dy(I-1,j+1)) & + + (vort_xy_dy(I,j+1) + vort_xy_dy(I-1,j))))**2) + grad_div_mag_v(i,J) = SQRT(div_xx_dy(i,J)**2 + (0.25*((div_xx_dx(I,j) + div_xx_dx(I-1,j+1)) & + + (div_xx_dx(I,j+1) + div_xx_dx(I-1,j))))**2) if (CS%use_beta_in_QG_Leith) then - beta_v(i,J) = sqrt( (0.5*(G%dF_dx(i,j)+G%dF_dx(i,j+1))**2) + & - (0.5*(G%dF_dy(i,j)+G%dF_dy(i,j+1))**2) ) + beta_v(i,J) = sqrt((0.5*(G%dF_dx(i,j)+G%dF_dx(i,j+1))**2) + & + (0.5*(G%dF_dy(i,j)+G%dF_dy(i,j+1))**2)) CS%KH_v_QG(i,J,k) = MIN(grad_vort_mag_v(i,J) + grad_div_mag_v(i,J), 3.0*beta_v(i,J)) * & CS%Laplac3_const_v(i,J) * inv_PI3 else @@ -1042,8 +1006,6 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) in_use = .true. allocate(CS%slope_x(IsdB:IedB,jsd:jed,G%ke+1)) ; CS%slope_x(:,:,:) = 0.0 allocate(CS%slope_y(isd:ied,JsdB:JedB,G%ke+1)) ; CS%slope_y(:,:,:) = 0.0 - allocate(CS%N2_u(IsdB:IedB,jsd:jed,G%ke+1)) ; CS%N2_u(:,:,:) = 0.0 - allocate(CS%N2_v(isd:ied,JsdB:JedB,G%ke+1)) ; CS%N2_v(:,:,:) = 0.0 call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & @@ -1096,11 +1058,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'Square of Brunt-Vaisala frequency, N^2, at u-points, as used in Visbeck et al.', 's-2') CS%id_N2_v = register_diag_field('ocean_model', 'N2_v', diag%axesCvi, Time, & 'Square of Brunt-Vaisala frequency, N^2, at v-points, as used in Visbeck et al.', 's-2') - !### The units of the next two diagnostics should be 'nondim'. CS%id_S2_u = register_diag_field('ocean_model', 'S2_u', diag%axesCu1, Time, & - 'Depth average square of slope magnitude, S^2, at u-points, as used in Visbeck et al.', 's-2') + 'Depth average square of slope magnitude, S^2, at u-points, as used in Visbeck et al.', 'nondim') CS%id_S2_v = register_diag_field('ocean_model', 'S2_v', diag%axesCv1, Time, & - 'Depth average square of slope magnitude, S^2, at v-points, as used in Visbeck et al.', 's-2') + 'Depth average square of slope magnitude, S^2, at v-points, as used in Visbeck et al.', 'nondim') endif oneOrTwo = 1.0 @@ -1272,13 +1233,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) do j=Jsq,Jeq+1 ; do I=is-1,Ieq ! Static factors in the Leith schemes grid_sp_u2 = G%dyCu(I,j)*G%dxCu(I,j) - grid_sp_u3 = sqrt(grid_sp_u2) + grid_sp_u3 = grid_sp_u2*sqrt(grid_sp_u2) CS%Laplac3_const_u(I,j) = Leith_Lap_const * grid_sp_u3 enddo ; enddo do j=js-1,Jeq ; do I=Isq,Ieq+1 ! Static factors in the Leith schemes - !### The second factor here is wrong. It should be G%dxCv(i,J). - grid_sp_v2 = G%dyCv(i,J)*G%dxCu(i,J) + grid_sp_v2 = G%dyCv(i,J)*G%dxCv(i,J) grid_sp_v3 = grid_sp_v2*sqrt(grid_sp_v2) CS%Laplac3_const_v(i,J) = Leith_Lap_const * grid_sp_v3 enddo ; enddo From b412fde96f2d48592cff2f35a255ef4f386efd2e Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 1 May 2020 16:40:13 -0600 Subject: [PATCH 022/103] Fix Leith_Ah There were a few mistakes in the Leith AH coefficient calculation that are now fixed. * Use inv_PI6 instead of inv_PI5 * Use Del2vort_q instead of vert_vort_mag --- .../lateral/MOM_hor_visc.F90 | 64 +++++++++---------- 1 file changed, 32 insertions(+), 32 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index c3ec878bc1..c95ddee281 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -103,11 +103,6 @@ module MOM_hor_visc !< The background biharmonic viscosity at h points [L4 T-1 ~> m4 s-1]. !! The actual viscosity may be the larger of this !! viscosity and the Smagorinsky and Leith viscosities. -! real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Biharm5_const2_xx - !< A constant relating the biharmonic viscosity to the - !! square of the velocity shear [L4 T ~> m4 s]. This value is - !! set to be the magnitude of the Coriolis terms once the - !! velocity differences reach a value of order 1/2 MAXVEL. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: reduction_xx !< The amount by which stresses through h points are reduced !! due to partial barriers [nondim]. @@ -125,11 +120,6 @@ module MOM_hor_visc !< The background biharmonic viscosity at q points [L4 T-1 ~> m4 s-1]. !! The actual viscosity may be the larger of this !! viscosity and the Smagorinsky and Leith viscosities. -! real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Biharm5_const2_xy - !< A constant relating the biharmonic viscosity to the - !! square of the velocity shear [L4 T ~> m4 s]. This value is - !! set to be the magnitude of the Coriolis terms once the - !! velocity differences reach a value of order 1/2 MAXVEL. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: reduction_xy !< The amount by which stresses through q points are reduced !! due to partial barriers [nondim]. @@ -160,14 +150,14 @@ module MOM_hor_visc ! parameters and metric terms. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & Laplac2_const_xx, & !< Laplacian metric-dependent constants [L2 ~> m2] - Biharm5_const_xx, & !< Biharmonic metric-dependent constants [L5 ~> m5] + Biharm6_const_xx, & !< Biharmonic metric-dependent constants [L6 ~> m6] Laplac3_const_xx, & !< Laplacian metric-dependent constants [L3 ~> m3] Biharm_const_xx, & !< Biharmonic metric-dependent constants [L4 ~> m4] Biharm_const2_xx !< Biharmonic metric-dependent constants [T L4 ~> s m4] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & Laplac2_const_xy, & !< Laplacian metric-dependent constants [L2 ~> m2] - Biharm5_const_xy, & !< Biharmonic metric-dependent constants [L5 ~> m5] + Biharm6_const_xy, & !< Biharmonic metric-dependent constants [L6 ~> m6] Laplac3_const_xy, & !< Laplacian metric-dependent constants [L3 ~> m3] Biharm_const_xy, & !< Biharmonic metric-dependent constants [L4 ~> m4] Biharm_const2_xy !< Biharmonic metric-dependent constants [T L4 ~> s m4] @@ -256,6 +246,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Leith_Ah_h, & ! Leith bi-harmonic viscosity at h-points [L4 T-1 ~> m4 s-1] grad_vort_mag_h, & ! Magnitude of vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] grad_vort_mag_h_2d, & ! Magnitude of 2d vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] + Del2vort_h, & ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [L-1 T-1 ~> m-1 s-1] dudx, dvdy, & ! components in the horizontal tension [T-1 ~> s-1] grad_vel_mag_h, & ! Magnitude of the velocity gradient tensor squared at h-points [T-2 ~> s-2] @@ -277,6 +268,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Leith_Ah_q, & ! Leith bi-harmonic viscosity at q-points [L4 T-1 ~> m4 s-1] grad_vort_mag_q, & ! Magnitude of vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] grad_vort_mag_q_2d, & ! Magnitude of 2d vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] + Del2vort_q, & ! Laplacian of vorticity at q-points [L-2 T-1 ~> m-2 s-1] grad_div_mag_q, & ! Magnitude of divergence gradient at q-points [L-1 T-1 ~> m-1 s-1] grad_vel_mag_q, & ! Magnitude of the velocity gradient tensor squared at q-points [T-2 ~> s-2] hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] @@ -335,6 +327,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: FWfrac ! Fraction of maximum theoretical energy transfer to use when scaling GME coefficient [nondim] real :: DY_dxBu ! Ratio of meridional over zonal grid spacing at vertices [nondim] real :: DX_dyBu ! Ratio of zonal over meridiononal grid spacing at vertices [nondim] + real :: DY_dxCv ! Ratio of meridional over zonal grid spacing at faces [nondim] + real :: DX_dyCu ! Ratio of zonal over meridional grid spacing at faces [nondim] real :: Sh_F_pow ! The ratio of shear over the absolute value of f raised to some power and rescaled [nondim] real :: backscat_subround ! The ratio of f over Shear_mag that is so small that the backscatter ! calculation gives the same value as if f were 0 [nondim]. @@ -346,7 +340,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, logical :: use_MEKE_Au integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n - real :: inv_PI3, inv_PI2, inv_PI5 + real :: inv_PI3, inv_PI2, inv_PI6 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -354,7 +348,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, h_neglect3 = h_neglect**3 inv_PI3 = 1.0/((4.0*atan(1.0))**3) inv_PI2 = 1.0/((4.0*atan(1.0))**2) - inv_PI5 = inv_PI3 * inv_PI2 + inv_PI6 = inv_PI3 * inv_PI3 Ah_h(:,:,:) = 0.0 Kh_h(:,:,:) = 0.0 @@ -465,7 +459,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & !$OMP use_MEKE_Ku, use_MEKE_Au, boundary_mask_h, boundary_mask_q, & !$OMP backscat_subround, GME_coeff_limiter, & - !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI5, H0_GME, & + !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI6, H0_GME, & !$OMP diffu, diffv, max_diss_rate_h, max_diss_rate_q, & !$OMP Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, vort_xy_q, GME_coeff_h, GME_coeff_q, & @@ -502,7 +496,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo ! Components for the shearing strain - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 dvdx(I,J) = CS%DY_dxBu(I,J)*(v(i+1,J,k)*G%IdyCv(i+1,J) - v(i,J,k)*G%IdyCv(i,J)) dudy(I,J) = CS%DX_dyBu(I,J)*(u(I,j+1,k)*G%IdxCu(I,j+1) - u(I,j,k)*G%IdxCu(I,j)) enddo ; enddo @@ -683,26 +677,37 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Vorticity if (CS%no_slip) then - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) enddo ; enddo else - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) enddo ; enddo endif ! Vorticity gradient - do J=js-2,Jeq+1 ; do i=is-1,Ieq+1 + do J=js-2,Jeq+2 ; do i=is-1,Ieq+2 DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) vort_xy_dx(i,J) = DY_dxBu * (vort_xy(I,J) * G%IdyCu(I,j) - vort_xy(I-1,J) * G%IdyCu(I-1,j)) enddo ; enddo - do j=js-1,Jeq+1 ; do I=is-2,Ieq+1 + do j=js-1,Jeq+2 ; do I=is-2,Ieq+2 DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) vort_xy_dy(I,j) = DX_dyBu * (vort_xy(I,J) * G%IdxCv(i,J) - vort_xy(I,J-1) * G%IdxCv(i,J-1)) enddo ; enddo + ! Laplacian of vorticity + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + DY_dxCv = G%dyCv(i,J) * G%IdxCv(i,J) + DX_dyCu = G%dyCu(I,j) * G%IdyCu(I,j) + Del2vort_q(I,J) = DY_dxCv * (vort_xy_dx(i+1,J) * G%IdyT(i+1,j) - vort_xy_dx(i,J) * G%IdyT(i,j)) + & + DX_dyCu * (vort_xy_dy(I,j+1) * G%IdyT(i,j+1) - vort_xy_dy(I,j) * G%IdyT(i,j)) + enddo ; enddo + do J=Jsq,Jeq+1 ; do I=Isq,Ieq+1 + Del2vort_h(i,j) = 0.25*(Del2vort_q(I,J) + Del2vort_q(I-1,J) + Del2vort_q(I,J-1) + Del2vort_q(I-1,J-1)) + enddo ; enddo + if (CS%modified_Leith) then ! Divergence do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 @@ -864,7 +869,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, AhSm = CS%Biharm_const_xx(i,j) * Shear_mag endif endif - if (CS%Leith_Ah) AhLth = CS%Biharm5_const_xx(i,j) * vert_vort_mag * inv_PI5 + if (CS%Leith_Ah) AhLth = CS%Biharm6_const_xx(i,j) * abs(Del2vort_h(i,j)) * inv_PI6 Ah = MAX(MAX(CS%Ah_bg_xx(i,j), AhSm), AhLth) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) & Ah = MIN(Ah, CS%Ah_Max_xx(i,j)) @@ -1034,7 +1039,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, AhSm = CS%Biharm_const_xy(I,J) * Shear_mag endif endif - if (CS%Leith_Ah) AhLth = CS%Biharm5_const_xy(I,J) * vert_vort_mag * inv_PI5 + if (CS%Leith_Ah) AhLth = CS%Biharm6_const_xy(I,J) * abs(Del2vort_q(I,J)) * inv_PI6 Ah = MAX(MAX(CS%Ah_bg_xy(I,J), AhSm), AhLth) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) & Ah = MIN(Ah, CS%Ah_Max_xy(I,J)) @@ -1745,8 +1750,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif endif if (CS%Leith_Ah) then - ALLOC_(CS%biharm5_const_xx(isd:ied,jsd:jed)) ; CS%biharm5_const_xx(:,:) = 0.0 - ALLOC_(CS%biharm5_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm5_const_xy(:,:) = 0.0 + ALLOC_(CS%biharm6_const_xx(isd:ied,jsd:jed)) ; CS%biharm6_const_xx(:,:) = 0.0 + ALLOC_(CS%biharm6_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm6_const_xy(:,:) = 0.0 endif endif @@ -1870,7 +1875,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j)+CS%dy2h(i,j)) grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2) - if (CS%Smagorinsky_Ah) then CS%Biharm_const_xx(i,j) = Smag_bi_const * (grid_sp_h2 * grid_sp_h2) if (CS%bound_Coriolis) then @@ -1881,7 +1885,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif endif if (CS%Leith_Ah) then - CS%biharm5_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h2) + CS%biharm6_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h3) endif CS%Ah_bg_xx(i,j) = MAX(Ah, Ah_vel_scale * grid_sp_h2 * sqrt(grid_sp_h2)) if (Ah_time_scale > 0.) CS%Ah_bg_xx(i,j) = & @@ -1903,7 +1907,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif endif if (CS%Leith_Ah) then - CS%biharm5_const_xy(i,j) = Leith_bi_const * (grid_sp_q3 * grid_sp_q2) + CS%biharm6_const_xy(i,j) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3) endif CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2)) @@ -2035,7 +2039,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%id_Kh_q = register_diag_field('ocean_model', 'Khq', diag%axesBL, Time, & 'Laplacian Horizontal Viscosity at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - if (CS%Leith_Kh) then CS%id_vort_xy_q = register_diag_field('ocean_model', 'vort_xy_q', diag%axesBL, Time, & 'Vertical vorticity at q Points', 's-1', conversion=US%s_to_T) @@ -2199,10 +2202,7 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%Ah_Max_xx) ; DEALLOC_(CS%Ah_Max_xy) endif if (CS%Smagorinsky_Ah) then - DEALLOC_(CS%Biharm5_const_xx) ; DEALLOC_(CS%Biharm5_const_xy) - ! if (CS%bound_Coriolis) then - ! DEALLOC_(CS%Biharm5_const2_xx) ; DEALLOC_(CS%Biharm5_const2_xy) - ! endif + DEALLOC_(CS%Biharm6_const_xx) ; DEALLOC_(CS%Biharm6_const_xy) endif if (CS%Leith_Ah) then DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) From 7d228f73a1b098da434a59e54dd9b9c2f5978292 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 4 May 2020 10:29:48 -0600 Subject: [PATCH 023/103] Add missing OMP directives --- src/parameterizations/lateral/MOM_hor_visc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index c95ddee281..11fd7b6644 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -477,8 +477,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP grad_vel_mag_bt_h, grad_vel_mag_bt_q, grad_d2vel_mag_h, & !$OMP meke_res_fn, Shear_mag, vert_vort_mag, hrat_min, visc_bound_rem, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & - !$OMP dDel2vdx, dDel2udy, & - !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & + !$OMP dDel2vdx, dDel2udy, DY_dxCv, DX_dyCu, Del2vort_q, Del2vort_h, & + !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff, KE & !$OMP ) do k=1,nz From 933b09abea4fbc2152ed497ba98a07f46d41dc10 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 4 May 2020 14:26:04 -0600 Subject: [PATCH 024/103] Remove OMP directive that came with cherry-picking --- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 11fd7b6644..3aac2c6b38 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -478,7 +478,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP meke_res_fn, Shear_mag, vert_vort_mag, hrat_min, visc_bound_rem, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & !$OMP dDel2vdx, dDel2udy, DY_dxCv, DX_dyCu, Del2vort_q, Del2vort_h, & - !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff, KE & + !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & !$OMP ) do k=1,nz From c06515f19878517e1de6477f69c609005067b045 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 6 May 2020 10:15:06 -0600 Subject: [PATCH 025/103] Add tidal diffusivities (Kd_tidal) into Kd_int --- .../vertical/MOM_tidal_mixing.F90 | 20 +++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 887cc6d067..14e72f97ea 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -681,7 +681,7 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, C real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, + optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, !! [Z2 T-1 ~> m2 s-1]. real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes, @@ -692,7 +692,7 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, C if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. CS%Lowmode_itidal_dissipation) then if (CS%use_CVMix_tidal) then - call calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) + call calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv) else call add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, & G, GV, US, CS, N2_lay, Kd_lay, Kd_int, Kd_max) @@ -703,7 +703,7 @@ end subroutine calculate_tidal_mixing !> Calls the CVMix routines to compute tidal dissipation and to add the effect of internal-tide-driven !! mixing to the interface diffusivities. -subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) +subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv) integer, intent(in) :: j !< The j-index to work on type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -715,6 +715,9 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: Kd_lay!< The diapycnal diffusivities in the layers [Z2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, + !! [Z2 T-1 ~> m2 s-1]. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [Z2 T-1 ~> m2 s-1]. ! Local variables @@ -794,7 +797,11 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) do k=1,G%ke Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo - + if (present(Kd_int)) then + do k=1,G%ke+1 + Kd_int(i,j,k) = Kd_int(i,j,k) + (US%m2_s_to_Z2_T * Kd_tidal(k)) + enddo + endif ! Update viscosity with the proper unit conversion. if (associated(Kv)) then do k=1,G%ke+1 @@ -896,6 +903,11 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) do k=1,G%ke Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo + if (present(Kd_int)) then + do k=1,G%ke+1 + Kd_int(i,j,k) = Kd_int(i,j,k) + (US%m2_s_to_Z2_T * Kd_tidal(k)) + enddo + endif ! Update viscosity if (associated(Kv)) then From fab21a74923ed373d158fde0fe80e003cb071baa Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 19 May 2020 13:54:17 +0000 Subject: [PATCH 026/103] Fixes an integer-kind mismatch in MOM_random, seed_from_time() - gcc/8.3.0 issued `Error: Integer too big for its kind` reported in feedback on PR #1111. The intent was to assume kind=4 in these calculations but apparently our compilers were promoting `mod(dy + 32*(mo + 13*yr), 2147483648)` to kind=8. There were two mistakes in the expression: - the use of `2147483648` in the `mod` is not representable with kind=4; - the `mod` produces negative values and should have been a `modulo`. - This commit reduces the range of the results by one number on the positive side and removes all the negatives. --- src/framework/MOM_random.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index c37893012e..14800df9aa 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -143,8 +143,9 @@ integer function seed_from_time(Time) call get_date(Time,yr,mo,dy,hr,mn,sc) s1 = sc + 61*(mn + 61*hr) + 379 ! Range 379 .. 89620 ! Fun fact: 2147483647 is the eighth Mersenne prime. - ! This is not the reason for using 2147483647+1 here. - s2 = mod(dy + 32*(mo + 13*yr), 2147483648) ! Range 0 .. 2147483647 + ! This is not the reason for using 2147483647 here. It is the + ! largest integer of kind=4. + s2 = modulo(dy + 32*(mo + 13*yr), 2147483647_4) ! Range 0 .. 2147483646 seed_from_time = ieor(s1*4111, s2) end function seed_from_time From 2f44ca7ce12410272a185556348547000d095790 Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Tue, 19 May 2020 13:03:35 -0600 Subject: [PATCH 027/103] correct conflict resolve in KPP --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 2a160a3021..a6b370f17e 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -992,7 +992,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & !$OMP BulkRi_1d, zBottomMinusOffset) & !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & - !$OMP Temp, Salt, waves, EOS, GoRho, u, v) + !$OMP Temp, Salt, waves, tv, EOS, GoRho, u, v) do j = G%jsc, G%jec do i = G%isc, G%iec From b34478800b61164622271590882f4218b1a15ee6 Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Tue, 19 May 2020 13:05:57 -0600 Subject: [PATCH 028/103] undo indent change from conflict resolve --- src/equation_of_state/MOM_EOS.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 25bd7580d9..6de99c5bef 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1757,15 +1757,15 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & do I=Isq,Ieq intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - ! Use Bode's rule to estimate the pressure anomaly change. - do m = 2,4 - pos = i*15+(m-2)*5 - intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3))) - enddo - ! Use Bode's rule to integrate the bottom pressure anomaly values in x. - intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) + ! Use Bode's rule to estimate the pressure anomaly change. + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3))) + enddo + ! Use Bode's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) enddo enddo endif From 532e65ad51a05dfe29cbc79e719cda765e5b25f8 Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Tue, 19 May 2020 14:39:38 -0600 Subject: [PATCH 029/103] undo OMP changes in MOM_EOS --- src/equation_of_state/MOM_EOS.F90 | 33 ++++++++++++++----------------- 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 6de99c5bef..c584b68c89 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1649,12 +1649,6 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! ============================= ! 1. Compute vertical integrals ! ============================= - - !$OMP parallel default(shared) private(jin,iin,dz,p5,S5,T5,r5,rho_anom,hWght,hL,hR,iDenom,Ttl,Ttr, & - !$OMP Tbl,Tbr,Stl,Str,Sbl,Sbr,w_left,w_right,dz_x,dz_y,pos,T15,S15, & - !$OMP p15,r15,weight_t,weight_b,intz) - - !$OMP do do j=Jsq,Jeq+1 do i = Isq,Ieq+1 dz(i) = z_t(i,j) - z_b(i,j) @@ -1747,6 +1741,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) enddo enddo + enddo if (rho_scale /= 1.0) then call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks, scale=rho_scale) @@ -1757,18 +1752,17 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & do I=Isq,Ieq intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - ! Use Bode's rule to estimate the pressure anomaly change. - do m = 2,4 - pos = i*15+(m-2)*5 - intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3))) - enddo - ! Use Bode's rule to integrate the bottom pressure anomaly values in x. - intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) + ! Use Bode's rule to estimate the pressure anomaly change. + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3))) enddo + ! Use Bode's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) enddo - endif + enddo ; endif ! ================================================== ! 3. Compute horizontal integrals in the y direction @@ -1830,6 +1824,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) enddo enddo + enddo if (rho_scale /= 1.0) then call calculate_density_array(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & @@ -1849,9 +1844,11 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & 32.0*(r15(pos+2)+r15(pos+4)) + & 12.0*r15(pos+3))) enddo + ! Use Bode's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) enddo - endif - !$OMP end parallel + enddo ; endif end subroutine int_density_dz_generic_plm ! ========================================================================== From 97547426a9942e4c1acb3a68e38b61d70fb77b61 Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Tue, 19 May 2020 16:24:15 -0600 Subject: [PATCH 030/103] Fix OMP directives broken by merge --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index a6b370f17e..01a39d394b 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -992,7 +992,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & !$OMP BulkRi_1d, zBottomMinusOffset) & !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & - !$OMP Temp, Salt, waves, tv, EOS, GoRho, u, v) + !$OMP Temp, Salt, waves, tv, GoRho, u, v) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1317,7 +1317,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) ! apply smoothing on OBL depth !$OMP parallel do default(none) shared(G, GV, CS, h, OBLdepth_prev) & - !$OMP private(wc, ww, we, wn, ws, dh, hcorr, pref, cellHeight, iFaceHeight) + !$OMP private(wc, ww, we, wn, ws, dh, hcorr, cellHeight, iFaceHeight) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1382,7 +1382,7 @@ subroutine KPP_get_BLD(CS, BLD, G, US, m_to_BLD_units) scale = US%m_to_Z ; if (present(m_to_BLD_units)) scale = m_to_BLD_units - !$OMP parallel do default(none) shared(BLD, CS, G) + !$OMP parallel do default(none) shared(BLD, CS, G, scale) do j = G%jsc, G%jec ; do i = G%isc, G%iec BLD(i,j) = scale * CS%OBLdepth(i,j) enddo ; enddo From 4041cc90b81ff51dc8ae1e981bb847bbdaa15f49 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 25 May 2020 12:12:52 -0600 Subject: [PATCH 031/103] Fix bug when applying ND only in the interior When using the option to apply neutral diffusion only below the surface boundary layer we were using (1.-zeta). This is wrong. It should be just (zeta). --- src/tracer/MOM_neutral_diffusion.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 30cdec3b37..890bae928c 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -461,7 +461,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & CS%Pint(i+1,j,:), CS%Tint(i+1,j,:), CS%Sint(i+1,j,:), CS%dRdT(i+1,j,:), CS%dRdS(i+1,j,:), & CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & - k_bot(I,j), k_bot(I+1,j), 1.-zeta_bot(I,j), 1.-zeta_bot(I+1,j)) + k_bot(I,j), k_bot(I+1,j), zeta_bot(I,j), zeta_bot(I+1,j)) else call find_neutral_surface_positions_discontinuous(CS, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & @@ -482,7 +482,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & CS%Pint(i,j+1,:), CS%Tint(i,j+1,:), CS%Sint(i,j+1,:), CS%dRdT(i,j+1,:), CS%dRdS(i,j+1,:), & CS%vPoL(i,J,:), CS%vPoR(i,J,:), CS%vKoL(i,J,:), CS%vKoR(i,J,:), CS%vhEff(i,J,:), & - k_bot(i,J), k_bot(i,J+1), 1.-zeta_bot(i,J), 1.-zeta_bot(i,J+1)) + k_bot(i,J), k_bot(i,J+1), zeta_bot(i,J), zeta_bot(i,J+1)) else call find_neutral_surface_positions_discontinuous(CS, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & From a69aea96164c73db20b3e1b204b7ff89e704799c Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 28 May 2020 16:23:40 -0600 Subject: [PATCH 032/103] Add new diagnostics Moved calculation of vorticity and divergence outside the Leith loop. Added diagnostics for shearing strain and horizontal tension. --- .../lateral/MOM_hor_visc.F90 | 56 +++++++++++-------- 1 file changed, 33 insertions(+), 23 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 0a126f10d8..a60d60bb9d 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -179,6 +179,7 @@ module MOM_hor_visc integer :: id_Kh_h = -1, id_Kh_q = -1 integer :: id_GME_coeff_h = -1, id_GME_coeff_q = -1 integer :: id_vort_xy_q = -1, id_div_xx_h = -1 + integer :: id_sh_xy_q = -1, id_sh_xx_h = -1 integer :: id_FrictWork = -1, id_FrictWorkIntz = -1 integer :: id_FrictWork_GME = -1 !>@} @@ -288,6 +289,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Ah_q, & ! biharmonic viscosity at corner points [L4 T-1 ~> m4 s-1] Kh_q, & ! Laplacian viscosity at corner points [L2 T-1 ~> m2 s-1] vort_xy_q, & ! vertical vorticity at corner points [T-1 ~> s-1] + sh_xy_q, & ! horizontal shearing strain at corner points [T-1 ~> s-1] GME_coeff_q, & !< GME coeff. at q-points [L2 T-1 ~> m2 s-1] max_diss_rate_q ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] @@ -301,7 +303,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, max_diss_rate_h, & ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] FrictWork, & ! work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] - div_xx_h ! horizontal divergence [T-1 ~> s-1] + div_xx_h, & ! horizontal divergence [T-1 ~> s-1] + sh_xx_h ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & grid_Re_Kh, & !< Grid Reynolds number for Laplacian horizontal viscosity at h points [nondim] grid_Re_Ah, & !< Grid Reynolds number for Biharmonic horizontal viscosity at h points [nondim] @@ -478,7 +481,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI6, H0_GME, & !$OMP diffu, diffv, max_diss_rate_h, max_diss_rate_q, & !$OMP Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & - !$OMP div_xx_h, vort_xy_q, GME_coeff_h, GME_coeff_q, & + !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, & !$OMP TD, KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah & !$OMP ) & !$OMP private( & @@ -689,18 +692,23 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif; endif endif - if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + ! Vorticity + if (CS%no_slip) then + do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 + vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) + enddo ; enddo + else + do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 + vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) + enddo ; enddo + endif - ! Vorticity - if (CS%no_slip) then - do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 - vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) - enddo ; enddo - else - do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 - vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) - enddo ; enddo - endif + ! Divergence + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + div_xx(i,j) = dudx(i,j) + dvdy(i,j) + enddo ; enddo + + if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then ! Vorticity gradient do J=js-2,Jeq+2 ; do i=is-1,Ieq+2 @@ -725,10 +733,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo if (CS%modified_Leith) then - ! Divergence - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - div_xx(i,j) = dudx(i,j) + dvdy(i,j) - enddo ; enddo ! Divergence gradient do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 @@ -865,6 +869,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%id_div_xx_h>0) div_xx_h(i,j,k) = div_xx(i,j) + if (CS%id_sh_xx_h>0) sh_xx_h(i,j,k) = sh_xx(i,j) str_xx(i,j) = -Kh * sh_xx(i,j) else ! not Laplacian @@ -1045,6 +1050,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_Kh_q>0 .or. CS%debug) Kh_q(I,J,k) = Kh if (CS%id_vort_xy_q>0) vort_xy_q(I,J,k) = vort_xy(I,J) + if (CS%id_sh_xy_q>0) sh_xy_q(I,J,k) = sh_xy(I,J) str_xy(I,J) = -Kh * sh_xy(I,J) else ! not Laplacian @@ -1325,6 +1331,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_grid_Re_Ah>0) call post_data(CS%id_grid_Re_Ah, grid_Re_Ah, CS%diag) if (CS%id_div_xx_h>0) call post_data(CS%id_div_xx_h, div_xx_h, CS%diag) if (CS%id_vort_xy_q>0) call post_data(CS%id_vort_xy_q, vort_xy_q, CS%diag) + if (CS%id_sh_xx_h>0) call post_data(CS%id_sh_xx_h, sh_xx_h, CS%diag) + if (CS%id_sh_xy_q>0) call post_data(CS%id_sh_xy_q, sh_xy_q, CS%diag) if (CS%id_Ah_q>0) call post_data(CS%id_Ah_q, Ah_q, CS%diag) if (CS%id_Kh_h>0) call post_data(CS%id_Kh_h, Kh_h, CS%diag) if (CS%id_grid_Re_Kh>0) call post_data(CS%id_grid_Re_Kh, grid_Re_Kh, CS%diag) @@ -2037,12 +2045,14 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 'Laplacian Horizontal Viscosity at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) CS%id_grid_Re_Kh = register_diag_field('ocean_model', 'grid_Re_Kh', diag%axesTL, Time, & 'Grid Reynolds number for the Laplacian horizontal viscosity at h points', 'nondim') - if (CS%Leith_Kh) then - CS%id_vort_xy_q = register_diag_field('ocean_model', 'vort_xy_q', diag%axesBL, Time, & - 'Vertical vorticity at q Points', 's-1', conversion=US%s_to_T) - CS%id_div_xx_h = register_diag_field('ocean_model', 'div_xx_h', diag%axesTL, Time, & - 'Horizontal divergence at h Points', 's-1', conversion=US%s_to_T) - endif + CS%id_vort_xy_q = register_diag_field('ocean_model', 'vort_xy_q', diag%axesBL, Time, & + 'Vertical vorticity at q Points', 's-1', conversion=US%s_to_T) + CS%id_div_xx_h = register_diag_field('ocean_model', 'div_xx_h', diag%axesTL, Time, & + 'Horizontal divergence at h Points', 's-1', conversion=US%s_to_T) + CS%id_sh_xy_q = register_diag_field('ocean_model', 'sh_xy_q', diag%axesBL, Time, & + 'Shearing strain at q Points', 's-1', conversion=US%s_to_T) + CS%id_sh_xx_h = register_diag_field('ocean_model', 'sh_xx_h', diag%axesTL, Time, & + 'Horizontal tension at h Points', 's-1', conversion=US%s_to_T) endif if (CS%use_GME) then CS%id_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, & From 473c3f47b70998e5a7a84e7e0ca0d08588049938 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 9 Jun 2020 13:24:38 -0600 Subject: [PATCH 033/103] Remove unused module --- config_src/nuopc_driver/mom_cap.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 219245e473..6b8d11141b 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -15,7 +15,6 @@ module MOM_cap_mod use mpp_mod, only: stdlog, stdout, mpp_root_pe, mpp_clock_id use mpp_mod, only: mpp_clock_begin, mpp_clock_end, MPP_CLOCK_SYNC use mpp_mod, only: MPP_CLOCK_DETAILED, CLOCK_COMPONENT, MAXPES -use time_interp_external_mod, only: time_interp_external_init use time_manager_mod, only: set_calendar_type, time_type, increment_date use time_manager_mod, only: set_time, set_date, get_time, get_date, month_name use time_manager_mod, only: GREGORIAN, JULIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR From abb10ed4cd3054dd2a0ba2d5c099ea0bd0620cc2 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 9 Jun 2020 14:00:20 -0600 Subject: [PATCH 034/103] Add calls to time_interp_external_init --- config_src/mct_driver/mom_ocean_model_mct.F90 | 103 +++++++++--------- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 3 + 2 files changed, 56 insertions(+), 50 deletions(-) diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index f8a4a19532..2f94c9b7f9 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -11,56 +11,57 @@ module MOM_ocean_model_mct ! This code is a stop-gap wrapper of the MOM6 code to enable it to be called ! in the same way as MOM4. -use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end -use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization -use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline -use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf -use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging -use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end -use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE -use MOM_domains, only : TO_ALL, Omit_Corners -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_error_handler, only : callTree_enter, callTree_leave -use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type -use MOM_forcing_type, only : allocate_forcing_type -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : forcing_accumulate, copy_common_forcing_fields -use MOM_forcing_type, only : copy_back_forcing_fields, set_net_mass_forcing -use MOM_forcing_type, only : set_derived_forcing_fields -use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags -use MOM_get_input, only : Get_MOM_Input, directories -use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, file_exists, read_data, write_version_number -use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart -use MOM_string_functions, only : uppercase -use MOM_surface_forcing_mct, only : surface_forcing_init, convert_IOB_to_fluxes -use MOM_surface_forcing_mct, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum -use MOM_surface_forcing_mct, only : ice_ocean_boundary_type, surface_forcing_CS -use MOM_surface_forcing_mct, only : forcing_save_restart -use MOM_time_manager, only : time_type, get_time, set_time, operator(>) -use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) -use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) -use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real -use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init -use MOM_tracer_flow_control, only : call_tracer_flux_init -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use MOM_verticalGrid, only : verticalGrid_type -use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS -use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type -use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data -use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data -use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain -use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain -use fms_mod, only : stdout -use mpp_mod, only : mpp_chksum -use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct -use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init -use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves +use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end +use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization +use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized +use MOM, only : get_ocean_stocks, step_offline +use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf +use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end +use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : TO_ALL, Omit_Corners +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave +use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type +use MOM_forcing_type, only : allocate_forcing_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing_accumulate, copy_common_forcing_fields +use MOM_forcing_type, only : copy_back_forcing_fields, set_net_mass_forcing +use MOM_forcing_type, only : set_derived_forcing_fields +use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags +use MOM_get_input, only : Get_MOM_Input, directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : close_file, file_exists, read_data, write_version_number +use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS +use MOM_restart, only : MOM_restart_CS, save_restart +use MOM_string_functions, only : uppercase +use MOM_surface_forcing_mct, only : surface_forcing_init, convert_IOB_to_fluxes +use MOM_surface_forcing_mct, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum +use MOM_surface_forcing_mct, only : ice_ocean_boundary_type, surface_forcing_CS +use MOM_surface_forcing_mct, only : forcing_save_restart +use MOM_time_manager, only : time_type, get_time, set_time, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) +use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real +use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init +use MOM_tracer_flow_control, only : call_tracer_flux_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type +use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS +use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart +use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type +use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums +use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data +use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data +use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain +use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain +use fms_mod, only : stdout +use mpp_mod, only : mpp_chksum +use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init +use MOM_wave_interface, only : MOM_wave_interface_init_lite, Update_Surface_Waves +use time_interp_external_mod, only : time_interp_external_init ! MCT specfic routines use MOM_domains, only : MOM_infra_end @@ -265,6 +266,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%is_ocean_pe = Ocean_sfc%is_ocean_pe if (.not.OS%is_ocean_pe) return + call time_interp_external_init + OS%Time = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 9946aec4f9..aabf456ca8 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -39,6 +39,7 @@ module MOM_ocean_model_nuopc use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real +use time_interp_external_mod,only : time_interp_external_init use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type @@ -267,6 +268,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%is_ocean_pe = Ocean_sfc%is_ocean_pe if (.not.OS%is_ocean_pe) return + call time_interp_external_init + OS%Time = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & From 7f478aa3e3734de8d0b88ad143e41f468e373d18 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 25 May 2020 12:13:34 -0600 Subject: [PATCH 035/103] Add option to apply linear decay at the base of hbl This patch adds the option to apply a linear decay of the fluxes at the base of hbl. This had been already implemented but since it breaks the unit tests, which were designed to work without this option, adding this option will avoid breaking the tests. Also adding minor improvements in the bulk method. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 271 +++++++++++------- 1 file changed, 175 insertions(+), 96 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index f244931376..a4b4bcb567 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -23,8 +23,7 @@ module MOM_lateral_boundary_diffusion use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member - -use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit implicit none ; private @@ -38,15 +37,18 @@ module MOM_lateral_boundary_diffusion !> Sets parameters for lateral boundary mixing module. type, public :: lateral_boundary_diffusion_CS ; private - integer :: method !< Determine which of the three methods calculate - !! and apply near boundary layer fluxes - !! 1. Bulk-layer approach - !! 2. Along layer - integer :: deg !< Degree of polynomial reconstruction - integer :: surface_boundary_scheme !< Which boundary layer scheme to use - !! 1. ePBL; 2. KPP - logical :: limiter !< Controls wether a flux limiter is applied. - !! Only valid when method = 1. + integer :: method !< Determine which of the three methods calculate + !! and apply near boundary layer fluxes + !! 1. Bulk-layer approach + !! 2. Along layer + integer :: deg !< Degree of polynomial reconstruction + integer :: surface_boundary_scheme !< Which boundary layer scheme to use + !! 1. ePBL; 2. KPP + logical :: limiter !< Controls wether a flux limiter is applied. + !! Only valid when method = 1. + logical :: linear !< If True, apply a linear transition at the base/top of the boundary. + !! The flux will be fully applied at k=k_min and zero at k=k_max. + type(remapping_CS) :: remap_CS !< Control structure to hold remapping configuration type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get BLD @@ -110,6 +112,9 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab "If True, apply a flux limiter in the LBD. This is only available \n"//& "when LATERAL_BOUNDARY_METHOD=1.", default=.false.) endif + call get_param(param_file, mdl, "LBD_LINEAR_TRANSITION", CS%linear, & + "If True, apply a linear transition at the base/top of the boundary. \n"//& + "The flux will be fully applied at k=k_min and zero at k=k_max.", default=.false.) call get_param(param_file, mdl, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & "Use boundary extrapolation in LBD code", & default=.false.) @@ -179,6 +184,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), tracer%t(i,j,:), ppoly0_coefs(i,j,:,:), & ppoly0_E(i,j,:,:), ppoly_S, remap_method, GV%H_subroundoff, GV%H_subroundoff) enddo ; enddo + ! Diffusive fluxes in the i-direction uFlx(:,:,:) = 0. vFlx(:,:,:) = 0. @@ -193,7 +199,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), & ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & - ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:), CS%limiter) + ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:), CS%limiter, & + CS%linear) endif enddo enddo @@ -203,7 +210,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), & ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & - ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:), CS%limiter) + ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:), CS%limiter, & + CS%linear) endif enddo enddo @@ -216,18 +224,20 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) do j=G%jsc,G%jec do i=G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & - G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & - ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx(I,j,:)) + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & + ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & + uFlx(I,j,:), CS%linear) endif enddo enddo do J=G%jsc-1,G%jec do i=G%isc,G%iec if (G%mask2dCv(i,J)>0.) then - call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & - ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx(i,J,:)) + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & + ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & + vFlx(i,J,:), CS%linear) endif enddo enddo @@ -298,26 +308,26 @@ end subroutine lateral_boundary_diffusion !< Calculate bulk layer value of a scalar quantity as the thickness weighted average real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, k_bot, & zeta_bot) - integer :: boundary !< SURFACE or BOTTOM [nondim] - integer :: nk !< Number of layers [nondim] - integer :: deg !< Degree of polynomial [nondim] - real, dimension(nk) :: h !< Layer thicknesses [H ~> m or kg m-2] - real :: hBLT !< Depth of the boundary layer [H ~> m or kg m-2] + integer :: boundary !< SURFACE or BOTTOM [nondim] + integer :: nk !< Number of layers [nondim] + integer :: deg !< Degree of polynomial [nondim] + real, dimension(nk) :: h !< Layer thicknesses [H ~> m or kg m-2] + real :: hBLT !< Depth of the boundary layer [H ~> m or kg m-2] real, dimension(nk) :: phi !< Scalar quantity - real, dimension(nk,2) :: ppoly0_E !< Edge value of polynomial - real, dimension(nk,deg+1) :: ppoly0_coefs !< Coefficients of polynomial - integer :: method !< Remapping scheme to use + real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial + real, dimension(nk,deg+1) :: ppoly0_coefs(:,:) !< Coefficients of polynomial + integer :: method !< Remapping scheme to use integer :: k_top !< Index of the first layer within the boundary real :: zeta_top !< Fraction of the layer encompassed by the bottom boundary layer !! (0 if none, 1. if all). For the surface, this is always 0. because - !! integration starts at the surface [nondim] + !! integration starts at the surface [nondim] integer :: k_bot !< Index of the last layer within the boundary real :: zeta_bot !< Fraction of the layer encompassed by the surface boundary layer !! (0 if none, 1. if all). For the bottom boundary layer, this is always 1. - !! because integration starts at the bottom [nondim] + !! because integration starts at the bottom [nondim] ! Local variables - real :: htot !< Running sum of the thicknesses (top to bottom) [H ~> m or kg m-2] + real :: htot !< Running sum of the thicknesses (top to bottom) integer :: k !< k indice @@ -428,43 +438,48 @@ end subroutine boundary_k_range !> Calculate the lateral boundary diffusive fluxes using the layer by layer method. !! See \ref section_method2 subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & - ppoly0_coefs_L, ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_coefs_L, ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, & + F_layer, linear_decay) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] - real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] real, intent(in ) :: hbl_L !< Thickness of the boundary boundary - !! layer (left) [H ~> m or kg m-2] + !! layer (left) [H ~> m or kg m-2] real, intent(in ) :: hbl_R !< Thickness of the boundary boundary - !! layer (right) [H ~> m or kg m-2] - real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] - real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] - real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] - real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] - integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] + !! layer (right) [H ~> m or kg m-2] + real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] + real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] + real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] + real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] + integer, intent(in ) :: method !< Method of polynomial integration [nondim] real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t !! at a velocity point [L2 ~> m2] real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point !! [H L2 conc ~> m3 conc] - + logical, optional, intent(in ) :: linear_decay !< If True, apply a linear transition at the base of + !! the boundary layer ! Local variables - real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [H ~> m or kg m-2] - real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] + real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [H ~> m or kg m-2] + real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] !! This is just to remind developers that khtr_avg should be !! computed once khtr is 3D. real :: heff !< Harmonic mean of layer thicknesses [H ~> m or kg m-2] real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses !! [H-1 ~> m-1 or m2 kg-1] real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) - !! [conc m^-3 ] + !! [conc m^-3 ] real :: htot !< Total column thickness [H ~> m or kg m-2] - integer :: k, k_bot_min, k_top_max !< k-indices, min and max for top and bottom, respectively + real :: heff_tot !< Total effective column thickness in the transition layer [m] + integer :: k, k_bot_min, k_top_max !< k-indices, min and max for bottom and top, respectively + integer :: k_bot_max, k_top_min !< k-indices, max and min for bottom and top, respectively + integer :: k_bot_diff, k_top_diff !< different between left and right k-indices for bottom and top, respectively integer :: k_top_L, k_bot_L !< k-indices left integer :: k_top_R, k_bot_R !< k-indices right real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary @@ -472,19 +487,30 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the boundary !!layer depth [nondim] real :: h_work_L, h_work_R !< dummy variables - real :: hbl_min !< minimum BLD (left and right) [m] + real :: hbl_min !< minimum BLD (left and right) [m] + real :: wgt !< weight to be used in the linear transition to the interior [nondim] + real :: a !< coefficient to be used in the linear transition to the interior [nondim] + logical :: linear !< True if apply a linear transition F_layer(:) = 0.0 if (hbl_L == 0. .or. hbl_R == 0.) then return endif + linear = .false. + if (PRESENT(linear_decay)) then + linear = linear_decay + endif + ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) if (boundary == SURFACE) then k_bot_min = MIN(k_bot_L, k_bot_R) + k_bot_max = MAX(k_bot_L, k_bot_R) + k_bot_diff = (k_bot_max - k_bot_min) + ! make sure left and right k indices span same range if (k_bot_min .ne. k_bot_L) then k_bot_L = k_bot_min @@ -503,15 +529,37 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L heff = harmonic_mean(h_work_L, h_work_R) ! tracer flux where the minimum BLD intersets layer ! GMM, khtr_avg should be computed once khtr is 3D - F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) + if ((linear) .and. (k_bot_diff .gt. 1)) then + ! apply linear decay at the base of hbl + do k = k_bot_min,1,-1 + heff = harmonic_mean(h_L(k), h_R(k)) + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) + enddo + ! heff_total + heff_tot = 0.0 + do k = k_bot_min+1,k_bot_max, 1 + heff_tot = heff_tot + harmonic_mean(h_L(k), h_R(k)) + enddo - do k = k_bot_min-1,1,-1 - heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) - enddo + a = -1.0/heff_tot + heff_tot = 0.0 + do k = k_bot_min+1,k_bot_max, 1 + heff = harmonic_mean(h_L(k), h_R(k)) + wgt = (a*(heff_tot + (heff * 0.5))) + 1.0 + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) * wgt + heff_tot = heff_tot + heff + enddo + else + F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) + do k = k_bot_min-1,1,-1 + heff = harmonic_mean(h_L(k), h_R(k)) + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) + enddo + endif endif if (boundary == BOTTOM) then + ! TODO: GMM add option to apply linear decay k_top_max = MAX(k_top_L, k_top_R) ! make sure left and right k indices span same range if (k_top_max .ne. k_top_L) then @@ -544,26 +592,27 @@ end subroutine fluxes_layer_method !> Apply the lateral boundary diffusive fluxes calculated from a 'bulk model' !! See \ref section_method1 subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, ppoly0_coefs_L, & - ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit) + ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit, & + linear_decay) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] - real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] real, intent(in ) :: hbl_L !< Thickness of the boundary boundary - !! layer (left) [H ~> m or kg m-2] + !! layer (left) [H ~> m or kg m-2] real, intent(in ) :: hbl_R !< Thickness of the boundary boundary - !! layer (left) [H ~> m or kg m-2] - real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] - real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] - real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] - real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] - integer, intent(in ) :: method !< Method of polynomial integration [nondim] + !! layer (left) [H ~> m or kg m-2] + real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] + real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] + real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] + real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] + integer, intent(in ) :: method !< Method of polynomial integration [nondim] real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t !! at a velocity point [L2 ~> m2] real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux @@ -571,6 +620,8 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point !! [H L2 conc ~> m3 conc] logical, optional, intent(in ) :: F_limit !< If True, apply a limiter + logical, optional, intent(in ) :: linear_decay !< If True, apply a linear transition at the base of + !! the boundary layer ! Local variables real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [H ~> m or kg m-2] @@ -578,12 +629,14 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, !! This is just to remind developers that khtr_avg should be !! computed once khtr is 3D. real :: heff !< Harmonic mean of layer thicknesses [H ~> m or kg m-2] + real :: heff_tot !< Total effective column thickness in the transition layer [m] real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses !! [H-1 ~> m-1 or m2 kg-1] real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) !! [conc m^-3 ] - real :: htot !< Total column thickness [H ~> m or kg m-2] + real :: htot ! Total column thickness [H ~> m or kg m-2] integer :: k, k_min, k_max !< k-indices, min and max for top and bottom, respectively + integer :: k_diff !< difference between k_max and k_min integer :: k_top_L, k_bot_L !< k-indices left integer :: k_top_R, k_bot_R !< k-indices right real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the @@ -594,12 +647,17 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real :: F_max !< The maximum amount of flux that can leave a !! cell [m^3 conc] logical :: limiter !< True if flux limiter should be applied + logical :: linear !< True if apply a linear transition real :: hfrac !< Layer fraction wrt sum of all layers [nondim] real :: dphi !< tracer gradient [conc m^-3] + real :: wgt !< weight to be used in the linear transition to the + !! interior [nondim] + real :: a !< coefficient to be used in the linear transition to the + !! interior [nondim] + F_bulk = 0. + F_layer(:) = 0. if (hbl_L == 0. .or. hbl_R == 0.) then - F_bulk = 0. - F_layer(:) = 0. return endif @@ -607,6 +665,10 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, if (PRESENT(F_limit)) then limiter = F_limit endif + linear = .false. + if (PRESENT(linear_decay)) then + linear = linear_decay + endif ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) @@ -617,7 +679,6 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, zeta_top_L, k_bot_L, zeta_bot_L) phi_R_avg = bulk_average(boundary, nk, deg, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, & zeta_top_R, k_bot_R, zeta_bot_R) - ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities ! GMM, khtr_avg should be computed once khtr is 3D heff = harmonic_mean(hbl_L, hbl_R) @@ -625,31 +686,53 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated ! above, but is used as a way to decompose the fluxes onto the individual layers h_means(:) = 0. - if (boundary == SURFACE) then k_min = MIN(k_bot_L, k_bot_R) + k_max = MAX(k_bot_L, k_bot_R) + k_diff = (k_max - k_min) + if ((linear) .and. (k_diff .gt. 1)) then + do k=1,k_min + h_means(k) = harmonic_mean(h_L(k),h_R(k)) + enddo + ! heff_total + heff_tot = 0.0 + do k = k_min+1,k_max, 1 + heff_tot = heff_tot + harmonic_mean(h_L(k), h_R(k)) + enddo - ! left hand side - if (k_bot_L == k_min) then - h_work_L = h_L(k_min) * zeta_bot_L + a = -1.0/heff_tot + heff_tot = 0.0 + ! fluxes will decay linearly at base of hbl + do k = k_min+1,k_max, 1 + heff = harmonic_mean(h_L(k), h_R(k)) + wgt = (a*(heff_tot + (heff * 0.5))) + 1.0 + h_means(k) = harmonic_mean(h_L(k), h_R(k)) * wgt + heff_tot = heff_tot + heff + enddo else - h_work_L = h_L(k_min) - endif + ! left hand side + if (k_bot_L == k_min) then + h_work_L = h_L(k_min) * zeta_bot_L + else + h_work_L = h_L(k_min) + endif - ! right hand side - if (k_bot_R == k_min) then - h_work_R = h_R(k_min) * zeta_bot_R - else - h_work_R = h_R(k_min) - endif + ! right hand side + if (k_bot_R == k_min) then + h_work_R = h_R(k_min) * zeta_bot_R + else + h_work_R = h_R(k_min) + endif - h_means(k_min) = harmonic_mean(h_work_L,h_work_R) + h_means(k_min) = harmonic_mean(h_work_L,h_work_R) - do k=1,k_min-1 - h_means(k) = harmonic_mean(h_L(k),h_R(k)) - enddo + do k=1,k_min-1 + h_means(k) = harmonic_mean(h_L(k),h_R(k)) + enddo + endif elseif (boundary == BOTTOM) then + !TODO, GMM linear decay is not implemented here k_max = MAX(k_top_L, k_top_R) ! left hand side if (k_top_L == k_max) then @@ -672,14 +755,14 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, enddo endif - if ( SUM(h_means) == 0. ) then + if ( SUM(h_means) == 0. .or. F_bulk == 0.) then return - ! Decompose the bulk flux onto the individual layers + ! Decompose the bulk flux onto the individual layers else ! Initialize remaining thickness inv_heff = 1./SUM(h_means) do k=1,nk - if (h_means(k) > 0.) then + if ((h_means(k) > 0.) .and. (phi_L(k) /= phi_R(k))) then hfrac = h_means(k)*inv_heff F_layer(k) = F_bulk * hfrac @@ -1035,10 +1118,6 @@ logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) test_layer_fluxes = .true. write(stdunit,*) "MOM_lateral_boundary_diffusion, UNIT TEST FAILED: ", test_name write(stdunit,10) k, F_calc(k), F_ans(k) - ! ### Once these unit tests are passing, and failures are caught properly, - ! we will post failure notifications to both stdout and stderr. - !write(stderr,*) "MOM_lateral_boundary_diffusion, UNIT TEST FAILED: ", test_name - !write(stderr,10) k, F_calc(k), F_ans(k) elseif (verbose) then write(stdunit,10) k, F_calc(k), F_ans(k) endif From 8fdcd904813686d9250ca48a3fb788339f9d49af Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 10 Jun 2020 11:12:24 -0600 Subject: [PATCH 036/103] Improve documentation and changed default method * the default LBD method (method # 1) has been changed to the layer by layer approach since this is the recommended scheme. * improve the documentation by adding description of the linear decay option in both methods. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 125 ++++++++++-------- 1 file changed, 69 insertions(+), 56 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index a4b4bcb567..dd2e015632 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -39,13 +39,13 @@ module MOM_lateral_boundary_diffusion type, public :: lateral_boundary_diffusion_CS ; private integer :: method !< Determine which of the three methods calculate !! and apply near boundary layer fluxes - !! 1. Bulk-layer approach - !! 2. Along layer + !! 1. Along layer + !! 2. Bulk-layer approach (not recommended) integer :: deg !< Degree of polynomial reconstruction integer :: surface_boundary_scheme !< Which boundary layer scheme to use !! 1. ePBL; 2. KPP logical :: limiter !< Controls wether a flux limiter is applied. - !! Only valid when method = 1. + !! Only valid when method = 2. logical :: linear !< If True, apply a linear transition at the base/top of the boundary. !! The flux will be fully applied at k=k_min and zero at k=k_max. @@ -105,12 +105,12 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "LATERAL_BOUNDARY_METHOD", CS%method, & "Determine how to apply boundary lateral diffusion of tracers: \n"//& - "1. Bulk layer approach \n"//& - "2. Along layer approach", default=1) - if (CS%method == 1) then + "1. Along layer approach \n"//& + "2. Bulk layer approach (this option is not recommended)", default=1) + if (CS%method == 2) then call get_param(param_file, mdl, "APPLY_LIMITER", CS%limiter, & "If True, apply a flux limiter in the LBD. This is only available \n"//& - "when LATERAL_BOUNDARY_METHOD=1.", default=.false.) + "when LATERAL_BOUNDARY_METHOD=2.", default=.false.) endif call get_param(param_file, mdl, "LBD_LINEAR_TRANSITION", CS%linear, & "If True, apply a linear transition at the base/top of the boundary. \n"//& @@ -191,56 +191,56 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) uFlx_bulk(:,:) = 0. vFlx_bulk(:,:) = 0. - ! Method #1 - if ( CS%method == 1 ) then + ! Method #1 (layer by layer) + if (CS%method == 1) then do j=G%jsc,G%jec do i=G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & - G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), & - ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & - ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:), CS%limiter, & - CS%linear) + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & + ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & + uFlx(I,j,:), CS%linear) endif enddo enddo do J=G%jsc-1,G%jec do i=G%isc,G%iec if (G%mask2dCv(i,J)>0.) then - call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), & - ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & - ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:), CS%limiter, & - CS%linear) + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & + ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & + vFlx(i,J,:), CS%linear) endif enddo enddo - ! Post tracer bulk diags - if (tracer%id_lbd_bulk_dfx>0) call post_data(tracer%id_lbd_bulk_dfx, uFlx_bulk*Idt, CS%diag) - if (tracer%id_lbd_bulk_dfy>0) call post_data(tracer%id_lbd_bulk_dfy, vFlx_bulk*Idt, CS%diag) - ! Method #2 + ! Method #2 (bulk approach) elseif (CS%method == 2) then do j=G%jsc,G%jec do i=G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & - G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & - ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & - uFlx(I,j,:), CS%linear) + call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), & + ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & + ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:), CS%limiter, & + CS%linear) endif enddo enddo do J=G%jsc-1,G%jec do i=G%isc,G%iec if (G%mask2dCv(i,J)>0.) then - call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & - ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & - vFlx(i,J,:), CS%linear) + call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), & + ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & + ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:), CS%limiter, & + CS%linear) endif enddo enddo + ! Post tracer bulk diags + if (tracer%id_lbd_bulk_dfx>0) call post_data(tracer%id_lbd_bulk_dfx, uFlx_bulk*Idt, CS%diag) + if (tracer%id_lbd_bulk_dfy>0) call post_data(tracer%id_lbd_bulk_dfy, vFlx_bulk*Idt, CS%diag) endif ! Update the tracer fluxes @@ -436,7 +436,7 @@ end subroutine boundary_k_range !> Calculate the lateral boundary diffusive fluxes using the layer by layer method. -!! See \ref section_method2 +!! See \ref section_method1 subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & ppoly0_coefs_L, ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, & F_layer, linear_decay) @@ -590,7 +590,7 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L end subroutine fluxes_layer_method !> Apply the lateral boundary diffusive fluxes calculated from a 'bulk model' -!! See \ref section_method1 +!! See \ref section_method2 subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, ppoly0_coefs_L, & ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit, & linear_decay) @@ -1175,12 +1175,37 @@ end function test_boundary_k_range !! !! Boundary lateral diffusion can be applied using one of the three methods: !! -!! * [Method #1: Bulk layer](@ref section_method1) (default); -!! * [Method #2: Along layer](@ref section_method2); +!! * [Method #1: Along layer](@ref section_method2) (default); +!! * [Method #2: Bulk layer](@ref section_method1); !! !! A brief summary of these methods is provided below. !! -!! \subsection section_method1 Bulk layer approach (Method #1) +!! \subsection section_method1 Along layer approach (Method #1) +!! +!! This is the recommended and more straight forward method where diffusion is +!! applied layer by layer using only information from neighboring cells. +!! +!! Step #1: compute vertical indices containing boundary layer (boundary_k_range). +!! For the TOP boundary layer, these are: +!! +!! k_top, k_bot, zeta_top, zeta_bot +!! +!! Step #2: calculate the diffusive flux at each layer: +!! +!! \f[ F_{k} = -KHTR \times h_{eff}(k) \times (\phi_R(k) - \phi_L(k)), \f] +!! where h_eff is the [harmonic mean](@ref section_harmonic_mean) of the layer thickness +!! in the left and right columns. This method does not require a limiter since KHTR +!! is already limted based on a diffusive CFL condition prior to the call of this +!! module. +!! +!! Step #3: option to linearly decay the flux from k_bot_min to k_bot_max: +!! +!! If LBD_LINEAR_TRANSITION = True and k_bot_diff > 1, the diffusive flux will decay +!! linearly between the top interface of the layer containing the minimum boundary +!! layer depth (k_bot_min) and the lower interface of the layer containing the +!! maximum layer depth (k_bot_max). +!! +!! \subsection section_method2 Bulk layer approach (Method #2) !! !! Apply the lateral boundary diffusive fluxes calculated from a 'bulk model'.This !! is a lower order representation (Kraus-Turner like approach) which assumes that @@ -1210,7 +1235,14 @@ end function test_boundary_k_range !! h_u is the [harmonic mean](@ref section_harmonic_mean) of thicknesses at each layer. !! Special care (layer reconstruction) must be taken at k_min = min(k_botL, k_bot_R). !! -!! Step #4: limit the tracer flux so that 1) only down-gradient fluxes are applied, +!! Step #4: option to linearly decay the flux from k_bot_min to k_bot_max: +!! +!! If LBD_LINEAR_TRANSITION = True and k_bot_diff > 1, the diffusive flux will decay +!! linearly between the top interface of the layer containing the minimum boundary +!! layer depth (k_bot_min) and the lower interface of the layer containing the +!! maximum layer depth (k_bot_max). +!! +!! Step #5: limit the tracer flux so that 1) only down-gradient fluxes are applied, !! and 2) the flux cannot be larger than F_max, which is defined using the tracer !! gradient: !! @@ -1221,25 +1253,6 @@ end function test_boundary_k_range !! 0 1 0 .2.2.2 !! 0 .2 !! -!! \subsection section_method2 Along layer approach (Method #2) -!! -!! This is a more straight forward method where diffusion is applied layer by layer using -!! only information from neighboring cells. -!! -!! Step #1: compute vertical indices containing boundary layer (boundary_k_range). -!! For the TOP boundary layer, these are: -!! -!! k_top, k_bot, zeta_top, zeta_bot -!! -!! Step #2: calculate the diffusive flux at each layer: -!! -!! \f[ F_{k} = -KHTR \times h_{eff}(k) \times (\phi_R(k) - \phi_L(k)), \f] -!! where h_eff is the [harmonic mean](@ref section_harmonic_mean) of the layer thickness -!! in the left and right columns. Special care (layer reconstruction) must be taken at -!! k_min = min(k_botL, k_bot_R). This method does not require a limiter since KHTR -!! is already limted based on a diffusive CFL condition prior to the call of this -!! module. -!! !! \subsection section_harmonic_mean Harmonic Mean !! !! The harmonic mean (HM) betwen h1 and h2 is defined as: From ca86bad5109e9c77d5512d758ec5013f8d0b4fb5 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 10 Jun 2020 14:23:27 -0600 Subject: [PATCH 037/103] Remove trailing space --- config_src/nuopc_driver/mom_cap.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 232a97ad41..55722a3ad9 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -72,7 +72,7 @@ module MOM_cap_mod use ESMF, only: ESMF_ArrayCreate use ESMF, only: ESMF_RC_FILE_OPEN, ESMF_RC_FILE_READ, ESMF_RC_FILE_WRITE use ESMF, only: ESMF_VMBroadcast -use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag +use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag use ESMF, only: ESMF_AlarmGet, ESMF_AlarmIsCreated, ESMF_ALARMLIST_ALL, ESMF_AlarmIsEnabled use ESMF, only: ESMF_STATEITEM_NOTFOUND, ESMF_FieldWrite use ESMF, only: operator(==), operator(/=), operator(+), operator(-) @@ -2063,7 +2063,7 @@ subroutine ModelSetRunClock(gcomp, rc) call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) return - + call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO, rc=rc) From 388b100c8b04e501e0685952cb9e4c3b7aa7299d Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 17 Jun 2020 16:06:14 -0600 Subject: [PATCH 038/103] Fix default zeta_bot values --- src/tracer/MOM_neutral_diffusion.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 890bae928c..d60aade72b 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -312,7 +312,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) pa_to_H = 1. / (GV%H_to_RZ * GV%g_Earth) k_top(:,:) = 1 ; k_bot(:,:) = 1 - zeta_top(:,:) = 0. ; zeta_bot(:,:) = 1. + zeta_top(:,:) = 0. ; zeta_bot(:,:) = 0. ! Check if hbl needs to be extracted if (CS%interior_only) then From 1daad4469b4bc63763546789b7cd8a57ef73e58e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 31 Jul 2020 14:48:52 -0400 Subject: [PATCH 039/103] (*)Improve make_frazil Improve the handling of very thin layers in make_frazil. This does not change answers for typical values of ANGSTROM, but can avoid problems that can arise when ANGSTROM=0. All answers in the existing MOM6-examples test cases are bitwise identical. --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 91085047c9..ee9a7bacff 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -195,14 +195,14 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) endif hc = (tv%C_p*GV%H_to_RZ) * h(i,j,k) - if (h(i,j,k) <= 10.0*GV%Angstrom_H) then + if (h(i,j,k) <= 10.0*(GV%Angstrom_H + GV%H_subroundoff)) then ! Very thin layers should not be cooled by the frazil flux. if (tv%T(i,j,k) < T_freeze(i)) then fraz_col(i) = fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) tv%T(i,j,k) = T_freeze(i) endif - else - if (fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) <= 0.0) then + elseif ((fraz_col(i) > 0.0) .or. (tv%T(i,j,k) < T_freeze(i))) then + if (fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) < 0.0) then tv%T(i,j,k) = tv%T(i,j,k) - fraz_col(i) / hc fraz_col(i) = 0.0 else From 948e2926f5c3288283266faf6bc5ca8d6bd25c3d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 31 Jul 2020 14:50:03 -0400 Subject: [PATCH 040/103] (*)Improve advective CFL calculation with tiny h Improved handling of massless layers in the calculation of the advective CFL numbers used in PPM tracer advection by using an Adcroft reciprocal instead of adding a small value in the denominator. Although all answers are bitwise identical in the existing MOM6-examples test cases, this can avoid problems with tracer advection when ANGSTROM is 0 or very small like those that were recently found in analogous SIS2 code. --- src/tracer/MOM_tracer_advect.F90 | 104 ++++++++++++------------------- 1 file changed, 40 insertions(+), 64 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 6a362d4fd5..e9c8fb0e7b 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -140,16 +140,15 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & !$OMP hprev,domore_k,js,je,is,ie,uhtr,vhtr,G,GV,h_end,& !$OMP uh_neglect,vh_neglect,ntr,Tr,h_prev_opt) -! This initializes the halos of uhr and vhr because pass_vector might do -! calculations on them, even though they are never used. -!$OMP do - + ! This initializes the halos of uhr and vhr because pass_vector might do + ! calculations on them, even though they are never used. + !$OMP do do k=1,nz do j=jsd,jed ; do I=IsdB,IedB ; uhr(I,j,k) = 0.0 ; enddo ; enddo do J=jsdB,jedB ; do i=Isd,Ied ; vhr(i,J,k) = 0.0 ; enddo ; enddo do j=jsd,jed ; do i=Isd,Ied ; hprev(i,j,k) = 0.0 ; enddo ; enddo domore_k(k)=1 -! Put the remaining (total) thickness fluxes into uhr and vhr. + ! Put the remaining (total) thickness fluxes into uhr and vhr. do j=js,je ; do I=is-1,ie ; uhr(I,j,k) = uhtr(I,j,k) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; vhr(i,J,k) = vhtr(i,J,k) ; enddo ; enddo if (.not. present(h_prev_opt)) then @@ -173,17 +172,17 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & enddo -!$OMP do + !$OMP do do j=jsd,jed ; do I=isd,ied-1 - uh_neglect(I,j) = GV%H_subroundoff*MIN(G%areaT(i,j),G%areaT(i+1,j)) + uh_neglect(I,j) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i+1,j)) enddo ; enddo -!$OMP do + !$OMP do do J=jsd,jed-1 ; do i=isd,ied - vh_neglect(i,J) = GV%H_subroundoff*MIN(G%areaT(i,j),G%areaT(i,j+1)) + vh_neglect(i,J) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i,j+1)) enddo ; enddo -!$OMP do ! initialize diagnostic fluxes and tendencies + !$OMP do do m=1,ntr if (associated(Tr(m)%ad_x)) then do k=1,nz ; do j=jsd,jed ; do i=isd,ied @@ -207,7 +206,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & do J=jsd,jed ; do i=isd,ied ; Tr(m)%ad2d_y(i,J) = 0.0 ; enddo ; enddo endif enddo -!$OMP end parallel + !$OMP end parallel isv = is ; iev = ie ; jsv = js ; jev = je @@ -222,8 +221,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! Reevaluate domore_u & domore_v unless the valid range is the same size as ! before. Also, do this if there is Strang splitting. if ((nsten_halo > 1) .or. (itt==1)) then -!$OMP parallel do default(none) shared(nz,domore_k,jsv,jev,domore_u,isv,iev,stencil, & -!$OMP uhr,domore_v,vhr) + !$OMP parallel do default(shared) do k=1,nz ; if (domore_k(k) > 0) then do j=jsv,jev ; if (.not.domore_u(j,k)) then do i=isv+stencil-1,iev-stencil; if (uhr(I,j,k) /= 0.0) then @@ -256,9 +254,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! for all the transport to happen. The sum over domore_k keeps the processors ! synchronized. This may not be very efficient, but it should be reliable. -!$OMP parallel default(private) shared(nz,domore_k,x_first,Tr,hprev,uhr,uh_neglect, & -!$OMP OBC,domore_u,ntr,Idt,isv,iev,jsv,jev,stencil, & -!$OMP G,GV,CS,vhr,vh_neglect,domore_v,US) + !$OMP parallel default(shared) if (x_first) then @@ -305,7 +301,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & endif ! x_first -!$OMP end parallel + !$OMP end parallel ! If the advection just isn't finishing after max_iter, move on. if (itt >= max_iter) then @@ -385,6 +381,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertable thickness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. @@ -406,16 +403,15 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if (usePPM .and. .not. useHuynh) stencil = 2 min_h = 0.1*GV%Angstrom_H + tiny_h = tiny(min_h) h_neglect = GV%H_subroundoff -! do I=is-1,ie ; ts2(I) = 0.0 ; enddo do I=is-1,ie ; CFL(I) = 0.0 ; enddo do j=js,je ; if (domore_u(j,k)) then domore_u(j,k) = .false. - ! Calculate the i-direction profiles (slopes) of each tracer that - ! is being advected. + ! Calculate the i-direction profiles (slopes) of each tracer that is being advected. if (usePLMslope) then do m=1,ntr ; do i=is-stencil,ie+stencil !if (ABS(Tr(m)%t(i+1,j,k)-Tr(m)%t(i,j,k)) < & @@ -490,33 +486,33 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! in the cell plus whatever part of its half of the mass flux that ! the flux through the other side does not require. do I=is-1,ie - if (uhr(I,j,k) == 0.0) then + if ((uhr(I,j,k) == 0.0) .or. & + ((uhr(I,j,k) < 0.0) .and. (hprev(i+1,j,k) <= tiny_h)) .or. & + ((uhr(I,j,k) > 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then uhh(I) = 0.0 CFL(I) = 0.0 elseif (uhr(I,j,k) < 0.0) then hup = hprev(i+1,j,k) - G%areaT(i+1,j)*min_h - hlos = MAX(0.0,uhr(I+1,j,k)) + hlos = MAX(0.0, uhr(I+1,j,k)) if ((((hup - hlos) + uhr(I,j,k)) < 0.0) .and. & ((0.5*hup + uhr(I,j,k)) < 0.0)) then - uhh(I) = MIN(-0.5*hup,-hup+hlos,0.0) + uhh(I) = MIN(-0.5*hup, -hup+hlos, 0.0) domore_u(j,k) = .true. else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 + uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j))) - CFL(I) = - uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j)) ! CFL is positive + CFL(I) = - uhh(I) / (hprev(i+1,j,k)) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h - hlos = MAX(0.0,-uhr(I-1,j,k)) + hlos = MAX(0.0, -uhr(I-1,j,k)) if ((((hup - hlos) - uhr(I,j,k)) < 0.0) .and. & ((0.5*hup - uhr(I,j,k)) < 0.0)) then - uhh(I) = MAX(0.5*hup,hup-hlos,0.0) + uhh(I) = MAX(0.5*hup, hup-hlos, 0.0) domore_u(j,k) = .true. else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 - uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) - CFL(I) = uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive + CFL(I) = uhh(I) / (hprev(i,j,k)) ! CFL is positive endif enddo @@ -545,11 +541,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & dA = aR - aL ; mA = 0.5*( aR + aL ) if (G%mask2dCu(I_up,j)*G%mask2dCu(I_up-1,j)*(Tp-Tc)*(Tc-Tm) <= 0.) then - aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells + aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then - aL = 3.*Tc - 2.*aR + aL = 3.*Tc - 2.*aR elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then - aR = 3.*Tc - 2.*aL + aR = 3.*Tc - 2.*aL endif a6 = 6.*Tc - 3. * (aR + aL) ! Curvature @@ -570,28 +566,17 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * (aR-aL) * CFL(I) ) ! Alternative implementation of PLM - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) - !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * slope_x(i,m) * CFL(I) ) - ! Alternative implementation of PLM Tc = T_tmp(i,m) flux_x(I,j,m) = uhh(I)*( Tc + 0.5 * slope_x(i,m) * ( 1. - CFL(I) ) ) - ! Original implementation of PLM - !flux_x(I,j,m) = uhh(I)*(Tr(m)%t(i,j,k) + slope_x(i,m)*ts2(I)) else ! Indirect implementation of PLM !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) !aR = Tr(m)%t(i+1,j,k) + 0.5 * slope_x(i+1,m) !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * (aR-aL) * CFL(I) ) ! Alternative implementation of PLM - !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) - !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * slope_x(i+1,m) * CFL(I) ) - ! Alternative implementation of PLM Tc = T_tmp(i+1,m) flux_x(I,j,m) = uhh(I)*( Tc - 0.5 * slope_x(i+1,m) * ( 1. - CFL(I) ) ) - ! Original implementation of PLM - !flux_x(I,j,m) = uhh(I)*(Tr(m)%t(i+1,j,k) - slope_x(i+1,m)*ts2(I)) endif - !ts2(I) = 0.5*(1.0 - uhh(I)/(hprev(i,j,k)+h_neglect*G%areaT(i,j))) enddo ; enddo endif ! usePPM @@ -760,6 +745,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertable thickness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. @@ -777,8 +763,8 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if (usePPM .and. .not. useHuynh) stencil = 2 min_h = 0.1*GV%Angstrom_H + tiny_h = tiny(min_h) h_neglect = GV%H_subroundoff - !do i=is,ie ; ts2(i) = 0.0 ; enddo ! We conditionally perform work on tracer points: calculating the PLM slope, ! and updating tracer concentration within a cell @@ -822,7 +808,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! make a copy of the tracers in case values need to be overridden for OBCs - do j=G%jsd,G%jed; do m=1,ntr; do i=G%isd,G%ied + do j=G%jsd,G%jed ; do m=1,ntr ; do i=G%isd,G%ied T_tmp(i,m,j) = Tr(m)%t(i,j,k) enddo ; enddo ; enddo @@ -873,33 +859,33 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & domore_v(J,k) = .false. do i=is,ie - if (vhr(i,J,k) == 0.0) then + if ((vhr(i,J,k) == 0.0) .or. & + ((vhr(i,J,k) < 0.0) .and. (hprev(i,j+1,k) <= tiny_h)) .or. & + ((vhr(i,J,k) > 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then vhh(i,J) = 0.0 CFL(i) = 0.0 elseif (vhr(i,J,k) < 0.0) then hup = hprev(i,j+1,k) - G%areaT(i,j+1)*min_h - hlos = MAX(0.0,vhr(i,J+1,k)) + hlos = MAX(0.0, vhr(i,J+1,k)) if ((((hup - hlos) + vhr(i,J,k)) < 0.0) .and. & ((0.5*hup + vhr(i,J,k)) < 0.0)) then - vhh(i,J) = MIN(-0.5*hup,-hup+hlos,0.0) + vhh(i,J) = MIN(-0.5*hup, -hup+hlos, 0.0) domore_v(J,k) = .true. else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 + vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) - CFL(i) = - vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) ! CFL is positive + CFL(i) = - vhh(i,J) / hprev(i,j+1,k) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h - hlos = MAX(0.0,-vhr(i,J-1,k)) + hlos = MAX(0.0, -vhr(i,J-1,k)) if ((((hup - hlos) - vhr(i,J,k)) < 0.0) .and. & ((0.5*hup - vhr(i,J,k)) < 0.0)) then - vhh(i,J) = MAX(0.5*hup,hup-hlos,0.0) + vhh(i,J) = MAX(0.5*hup, hup-hlos, 0.0) domore_v(J,k) = .true. else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 - vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) - CFL(i) = vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive + CFL(i) = vhh(i,J) / hprev(i,j,k) ! CFL is positive endif enddo @@ -952,26 +938,16 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) !flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * (aR-aL) * CFL(i) ) ! Alternative implementation of PLM - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) - !flux_y(i,m,J) = vhh(i,J)*(aR - 0.5 * slope_y(i,m,j)*CFL(i)) - ! Alternative implementation of PLM Tc = T_tmp(i,m,j) flux_y(i,m,J) = vhh(i,J)*( Tc + 0.5 * slope_y(i,m,j) * ( 1. - CFL(i) ) ) - ! Original implementation of PLM - !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j,k) + slope_y(i,m,j)*ts2(i)) else ! Indirect implementation of PLM !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) !aR = Tr(m)%t(i,j+1,k) + 0.5 * slope_y(i,m,j+1) !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * (aR-aL) * CFL(i) ) ! Alternative implementation of PLM - !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) - !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * slope_y(i,m,j+1)*CFL(i) ) - ! Alternative implementation of PLM Tc = T_tmp(i,m,j+1) flux_y(i,m,J) = vhh(i,J)*( Tc - 0.5 * slope_y(i,m,j+1) * ( 1. - CFL(i) ) ) - ! Original implementation of PLM - !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j+1,k) - slope_y(i,m,j+1)*ts2(i)) endif enddo ; enddo endif ! usePPM From cbbf84847384f2860bf8de765b5c1cb34687cb75 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 31 Jul 2020 15:02:28 -0400 Subject: [PATCH 041/103] Infrastructure calls via framework directory Revised module use statements and some infrastructure calls to go via the MOM6 framework directory rather than directly calling FMS infrastructure routines. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 4 +-- src/ice_shelf/MOM_ice_shelf.F90 | 1 - src/ice_shelf/MOM_ice_shelf_state.F90 | 1 - .../MOM_state_initialization.F90 | 20 ++++-------- src/tracer/MOM_generic_tracer.F90 | 32 +++++++++---------- src/tracer/MOM_offline_aux.F90 | 3 +- src/tracer/MOM_offline_main.F90 | 3 +- src/tracer/RGC_tracer.F90 | 5 ++- 8 files changed, 26 insertions(+), 43 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index a04ee426e6..7075fb7c10 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -9,10 +9,8 @@ module MOM_surface_forcing_gfdl use MOM_constants, only : hlv, hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT -use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_mediator, only : safe_alloc_ptr, time_type +use MOM_diag_mediator, only : diag_ctrl, safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 6b68cb3deb..66fd873f67 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -51,7 +51,6 @@ module MOM_ice_shelf use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init -use time_manager_mod, only : print_time implicit none ; private #include diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index b3e88697f2..a3784b5a34 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -12,7 +12,6 @@ module MOM_ice_shelf_state use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type use MOM_get_input, only : directories, Get_MOM_input -use mpp_mod, only : mpp_sum, mpp_max, mpp_min, mpp_pe, mpp_npes, mpp_sync use MOM_coms, only : reproducing_sum use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index e451966364..a201e4a85f 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -18,23 +18,17 @@ module MOM_state_initialization use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type, isPointInCell use MOM_interface_heights, only : find_eta -use MOM_io, only : file_exists -use MOM_io, only : MOM_read_data, MOM_read_vector -use MOM_io, only : slasher -use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init +use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher +use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init, set_tracer_data use MOM_open_boundary, only : OBC_NONE, OBC_SIMPLE -use MOM_open_boundary, only : open_boundary_query -use MOM_open_boundary, only : set_tracer_data -use MOM_open_boundary, only : open_boundary_test_extern_h -use MOM_open_boundary, only : fill_temp_salt_segments -use MOM_open_boundary, only : update_OBC_segment_data +use MOM_open_boundary, only : open_boundary_query, open_boundary_test_extern_h +use MOM_open_boundary, only : fill_temp_salt_segments, update_OBC_segment_data !use MOM_open_boundary, only : set_3D_OBC_data use MOM_grid_initialize, only : initialize_masks, set_grid_metrics use MOM_restart, only : restore_state, determine_is_new_run, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, set_up_sponge_ML_density use MOM_sponge, only : initialize_sponge, sponge_CS -use MOM_ALE_sponge, only : set_up_ALE_sponge_field, initialize_ALE_sponge -use MOM_ALE_sponge, only : ALE_sponge_CS +use MOM_ALE_sponge, only : set_up_ALE_sponge_field, initialize_ALE_sponge, ALE_sponge_CS use MOM_string_functions, only : uppercase, lowercase use MOM_time_manager, only : time_type use MOM_tracer_registry, only : tracer_registry_type @@ -44,8 +38,7 @@ module MOM_state_initialization use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type, EOS_domain use MOM_EOS, only : convert_temp_salt_for_TEOS10 use user_initialization, only : user_initialize_thickness, user_initialize_velocity -use user_initialization, only : user_init_temperature_salinity -use user_initialization, only : user_set_OBC_data +use user_initialization, only : user_init_temperature_salinity, user_set_OBC_data use user_initialization, only : user_initialize_sponges use DOME_initialization, only : DOME_initialize_thickness use DOME_initialization, only : DOME_set_OBC_data @@ -97,7 +90,6 @@ module MOM_state_initialization use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_remapping, only : remapping_core_h use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer -use fms_io_mod, only : field_size implicit none ; private diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 7d2310b42f..66c0e33bac 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -13,10 +13,8 @@ module MOM_generic_tracer #define _ALLOCATED allocated #endif - ! ### These imports should not reach into FMS directly ### - use mpp_mod, only: stdout, mpp_error, FATAL,WARNING,NOTE - use field_manager_mod, only: fm_get_index,fm_string_len + use field_manager_mod, only: fm_string_len use generic_tracer, only: generic_tracer_register, generic_tracer_get_diag_list use generic_tracer, only: generic_tracer_init, generic_tracer_source, generic_tracer_register_diag @@ -108,7 +106,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Local variables logical :: register_MOM_generic_tracer - character(len=fm_string_len), parameter :: sub_name = 'register_MOM_generic_tracer' + character(len=128), parameter :: sub_name = 'register_MOM_generic_tracer' character(len=200) :: inputdir ! The directory where NetCDF input files are. ! These can be overridden later in via the field manager? @@ -122,7 +120,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) register_MOM_generic_tracer = .false. if (associated(CS)) then - call mpp_error(WARNING, "register_MOM_generic_tracer called with an "// & + call MOM_error(WARNING, "register_MOM_generic_tracer called with an "// & "associated control structure.") return endif @@ -185,7 +183,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !Get the tracer list call generic_tracer_get_list(CS%g_tracer_list) - if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& ": No tracer in the list.") ! For each tracer name get its T_prog index and get its fields @@ -247,7 +245,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< Pointer to the control structure for the !! ALE sponges. - character(len=fm_string_len), parameter :: sub_name = 'initialize_MOM_generic_tracer' + character(len=128), parameter :: sub_name = 'initialize_MOM_generic_tracer' logical :: OK integer :: i, j, k, isc, iec, jsc, jec, nk type(g_tracer_type), pointer :: g_tracer,g_tracer_next @@ -265,7 +263,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, CS%diag=>diag !Get the tracer list - if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& ": No tracer in the list.") !For each tracer name get its fields g_tracer=>CS%g_tracer_list @@ -426,7 +424,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_column_physics' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_column_physics' type(g_tracer_type), pointer :: g_tracer, g_tracer_next character(len=fm_string_len) :: g_tracer_name @@ -443,7 +441,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = G%ke !Get the tracer list - if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL,& + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL,& trim(sub_name)//": No tracer in the list.") #ifdef _USE_MOM6_DIAG @@ -587,7 +585,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_stock' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_stock' integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -660,7 +658,7 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_min_max' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_min_max' real, dimension(:,:,:),pointer :: grid_tmask integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau @@ -728,7 +726,7 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, CS) ! Local variables real :: sosga - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_surface_state' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_surface_state' real, dimension(G%isd:G%ied,G%jsd:G%jed,1:G%ke,1) :: rho0 real, dimension(G%isd:G%ied,G%jsd:G%jed,1:G%ke) :: dzt type(g_tracer_type), pointer :: g_tracer @@ -750,7 +748,7 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, CS) tau=1,sosga=sosga,model_time=get_diag_time_end(CS%diag)) !Output diagnostics via diag_manager for all tracers in this module -! if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& +! if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& ! "No tracer in the list.") ! call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) !Niki: The problem with calling diagnostic outputs here is that this subroutine is called every dt_cpld @@ -767,7 +765,7 @@ subroutine MOM_generic_flux_init(verbosity) integer :: ind character(len=fm_string_len) :: g_tracer_name,longname, package,units,old_package,file_in,file_out real :: const_init_value - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_flux_init' + character(len=128), parameter :: sub_name = 'MOM_generic_flux_init' type(g_tracer_type), pointer :: g_tracer_list,g_tracer,g_tracer_next if (.not. g_registered) then @@ -777,7 +775,7 @@ subroutine MOM_generic_flux_init(verbosity) call generic_tracer_get_list(g_tracer_list) if (.NOT. associated(g_tracer_list)) then - call mpp_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") + call MOM_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") return endif @@ -812,7 +810,7 @@ subroutine MOM_generic_tracer_get(name,member,array, CS) type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. real, dimension(:,:,:), pointer :: array_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_get' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_get' call g_tracer_get_pointer(CS%g_tracer_list,name,member,array_ptr) array(:,:,:) = array_ptr(:,:,:) diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 21db2cfff4..119ad555da 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -4,7 +4,6 @@ module MOM_offline_aux ! This file is part of MOM6. See LICENSE.md for the license. -use mpp_domains_mod, only : CENTER, CORNER, NORTH, EAST use data_override_mod, only : data_override_init, data_override use MOM_time_manager, only : time_type, operator(-) use MOM_debugging, only : check_column_integrals @@ -12,7 +11,7 @@ module MOM_offline_aux use MOM_diag_vkernels, only : reintegrate_column use MOM_error_handler, only : callTree_enter, callTree_leave, MOM_error, FATAL, WARNING, is_root_pe use MOM_grid, only : ocean_grid_type -use MOM_io, only : MOM_read_data, MOM_read_vector +use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_verticalGrid, only : verticalGrid_type use MOM_file_parser, only : get_param, log_version, param_file_type use astronomy_mod, only : orbital_time, diurnal_solar, daily_mean_solar diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index b7af9849b3..3895e8a116 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -4,7 +4,6 @@ module MOM_offline_main ! This file is part of MOM6. See LICENSE.md for the license. -use mpp_domains_mod, only : CENTER, CORNER, NORTH, EAST use MOM_ALE, only : ALE_CS, ALE_main_offline, ALE_offline_inputs use MOM_checksums, only : hchksum, uvchksum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end @@ -20,7 +19,7 @@ module MOM_offline_main use MOM_file_parser, only : read_param, get_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type -use MOM_io, only : MOM_read_data, MOM_read_vector +use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_offline_aux, only : update_offline_from_arrays, update_offline_from_files use MOM_offline_aux, only : next_modulo_time, offline_add_diurnal_sw use MOM_offline_aux, only : update_h_horizontal_flux, update_h_vertical_flux, limit_mass_flux_3d diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 028718f379..44c6c2e5a1 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -19,7 +19,7 @@ module RGC_tracer use MOM_forcing_type, only : forcing use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_restart, only : MOM_restart_CS use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS, get_ALE_sponge_nz_data use MOM_sponge, only : set_up_sponge_field, sponge_CS @@ -207,8 +207,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & CS%tracer_IC_file) do m=1,NTR call query_vardesc(CS%tr_desc(m), name, caller="initialize_RGC_tracer") - call read_data(CS%tracer_IC_file, trim(name), & - CS%tr(:,:,:,m), domain=G%Domain%mpp_domain) + call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) enddo else do m=1,NTR From bba60af8efe150e65accdb2b2621614b707f8316 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 4 Aug 2020 12:06:41 -0400 Subject: [PATCH 042/103] Move call to initialize_segment_data to MOM_state_initialization --- src/core/MOM_open_boundary.F90 | 96 +++++++++++-------- .../MOM_state_initialization.F90 | 4 +- 2 files changed, 58 insertions(+), 42 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 9b650f8598..f94060fc39 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -62,6 +62,7 @@ module MOM_open_boundary public update_OBC_ramp public rotate_OBC_config public rotate_OBC_init +public initialize_segment_data integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary integer, parameter, public :: OBC_SIMPLE = 1 !< Indicates the use of a simple inflow open boundary @@ -268,7 +269,7 @@ module MOM_open_boundary real :: rx_max !< The maximum magnitude of the baroclinic radiation velocity (or speed of !! characteristics) in units of grid points per timestep [nondim]. logical :: OBC_pe !< Is there an open boundary on this tile? - type(remapping_CS), pointer :: remap_CS !< ALE remapping control structure for segments only + type(remapping_CS), pointer :: remap_CS=> NULL() !< ALE remapping control structure for segments only type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries real, pointer, dimension(:,:,:) :: & rx_normal => NULL(), & !< Array storage for normal phase speed for EW radiation OBCs in units of @@ -341,6 +342,11 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=100) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] + character(len=128) :: inputdir + logical :: answers_2018, default_2018_answers + logical :: check_reconstruction, check_remapping, force_bounds_in_subcell + character(len=32) :: remappingScheme + allocate(OBC) call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & @@ -497,7 +503,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) enddo ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) & - call initialize_segment_data(G, OBC, param_file) + ! call initialize_segment_data(G, OBC, param_file) if (open_boundary_query(OBC, apply_open_OBC=.true.)) then call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & @@ -540,6 +546,46 @@ subroutine open_boundary_config(G, US, param_file, OBC) if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out enddo + ! There is a problem with the order of the OBC initialization + ! with respect to ALE_init. Currently handling this by copying the + ! param file so that I can use it later in step_MOM in order to finish + ! initializing segments on the first step. + + ! Is the above comment still relevant ? + + call get_param(param_file, mdl, "REMAPPING_SCHEME", remappingScheme, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: \n"//& + trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) + call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & + "If true, cell-by-cell reconstructions are checked for "//& + "consistency and if non-monotonicity or an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & + "If true, the results of remapping are checked for "//& + "conservation and new extrema and if an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & + "If true, read external OBC data on the supergrid.", & + default=.false.) + call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & + "If true, the values on the intermediate grid used for remapping "//& + "are forced to be bounded, which might not be the case due to "//& + "round off.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.false.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) + + allocate(OBC%remap_CS) + call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & + check_reconstruction=check_reconstruction, check_remapping=check_remapping, & + force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) + endif ! OBC%number_of_segments > 0 ! Safety check @@ -564,7 +610,7 @@ end subroutine open_boundary_config subroutine initialize_segment_data(G, OBC, PF) use mpp_mod, only : mpp_pe, mpp_set_current_pelist, mpp_get_current_pelist,mpp_npes - type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure type(param_file_type), intent(in) :: PF !< Parameter file handle @@ -576,10 +622,7 @@ subroutine initialize_segment_data(G, OBC, PF) character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names character(len=128) :: inputdir type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - character(len=32) :: remappingScheme character(len=256) :: mesg ! Message for error messages. - logical :: check_reconstruction, check_remapping, force_bounds_in_subcell - logical :: answers_2018, default_2018_answers integer, dimension(4) :: siz,siz2 integer :: is, ie, js, je integer :: isd, ied, jsd, jed @@ -599,39 +642,6 @@ subroutine initialize_segment_data(G, OBC, PF) call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - call get_param(PF, mdl, "REMAPPING_SCHEME", remappingScheme, & - "This sets the reconstruction scheme used "//& - "for vertical remapping for all variables. "//& - "It can be one of the following schemes: \n"//& - trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) - call get_param(PF, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & - "If true, cell-by-cell reconstructions are checked for "//& - "consistency and if non-monotonicity or an inconsistency is "//& - "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) - call get_param(PF, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & - "If true, the results of remapping are checked for "//& - "conservation and new extrema and if an inconsistency is "//& - "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) - call get_param(PF, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & - "If true, the values on the intermediate grid used for remapping "//& - "are forced to be bounded, which might not be the case due to "//& - "round off.", default=.false.,do_not_log=.true.) - call get_param(PF, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & - "If true, read external OBC data on the supergrid.", & - default=.false.) - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - - allocate(OBC%remap_CS) - call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & - check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) - if (OBC%user_BCs_set_globally) return ! Try this here just for the documentation. It is repeated below. @@ -4966,6 +4976,8 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) integer :: l + if (OBC_in%number_of_segments==0) return + ! Scalar and logical transfer OBC%number_of_segments = OBC_in%number_of_segments OBC%ke = OBC_in%ke @@ -5023,8 +5035,10 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%OBC_pe = OBC_in%OBC_pe ! remap_CS is set up by initialize_segment_data, so we copy the fields here. - allocate(OBC%remap_CS) - OBC%remap_CS = OBC_in%remap_CS + if (ASSOCIATED(OBC_in%remap_CS)) then + allocate(OBC%remap_CS) + OBC%remap_CS = OBC_in%remap_CS + endif ! TODO: The OBC registry seems to be a list of "registered" OBC types. ! It does not appear to be used, so for now we skip this record. diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index e451966364..f53ff89a1e 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -24,7 +24,7 @@ module MOM_state_initialization use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init use MOM_open_boundary, only : OBC_NONE, OBC_SIMPLE use MOM_open_boundary, only : open_boundary_query -use MOM_open_boundary, only : set_tracer_data +use MOM_open_boundary, only : set_tracer_data, initialize_segment_data use MOM_open_boundary, only : open_boundary_test_extern_h use MOM_open_boundary, only : fill_temp_salt_segments use MOM_open_boundary, only : update_OBC_segment_data @@ -563,6 +563,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! This controls user code for setting open boundary data if (associated(OBC)) then + call initialize_segment_data(G, OBC, PF) ! call initialize_segment_data(G, OBC, param_file) +! call open_boundary_config(G, US, PF, OBC) ! Call this once to fill boundary arrays from fixed values if (.not. OBC%needs_IO_for_data) & call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) From 2fe90f2fe60779f2036d6c921c6ef37cc58d49df Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 4 Aug 2020 15:09:59 -0600 Subject: [PATCH 043/103] retrieve num_rest_files from save_restart --- src/framework/MOM_restart.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index c918f3a9ee..20056c15ad 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -849,7 +849,7 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_4d_name !> save_restart saves all registered variables to restart files. -subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) +subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_rest_files) character(len=*), intent(in) :: directory !< The directory where the restart files !! are to be written type(time_type), intent(in) :: time !< The current model time @@ -860,6 +860,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) !! to the restart file names. character(len=*), optional, intent(in) :: filename !< A filename that overrides the name in CS%restartfile. type(verticalGrid_type), optional, intent(in) :: GV !< The ocean's vertical grid structure + integer, optional, intent(out) :: num_rest_files !< number of restart files written ! Local variables type(vardesc) :: vars(CS%max_fields) ! Descriptions of the fields that @@ -1056,6 +1057,9 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) num_files = num_files+1 enddo + + if (present(num_rest_files)) num_rest_files = num_files + end subroutine save_restart !> restore_state reads the model state from previously generated files. All From ff27ad56068ad121ba803db80cf8d4abdbd850a0 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 4 Aug 2020 15:11:09 -0600 Subject: [PATCH 044/103] add num_rest_files to ocean_model_restart --- config_src/nuopc_driver/mom_ocean_model_nuopc.F90 | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index aabf456ca8..cbbb2261d0 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -671,7 +671,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & end subroutine update_ocean_model !> This subroutine writes out the ocean model restart file. -subroutine ocean_model_restart(OS, timestamp, restartname) +subroutine ocean_model_restart(OS, timestamp, restartname, num_rest_files) type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the !! internal ocean state being saved to a restart file character(len=*), optional, intent(in) :: timestamp !< An optional timestamp string that should be @@ -679,6 +679,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) character(len=*), optional, intent(in) :: restartname !< Name of restart file to use !! This option distinguishes the cesm interface from the !! non-cesm interface + integer, optional, intent(out) :: num_rest_files !< number of restart files written if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & call MOM_error(WARNING, "End of MOM_main reached with inconsistent "//& @@ -689,8 +690,13 @@ subroutine ocean_model_restart(OS, timestamp, restartname) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname) + if (present(num_rest_files)) then + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) + else + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, GV=OS%GV, filename=restartname) + endif call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then From 4c609001073b7ae9624d9afc8f6a5ddf528ef8c1 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 4 Aug 2020 15:15:02 -0600 Subject: [PATCH 045/103] read/write multiple restart filenames from/to rpointer files --- config_src/nuopc_driver/mom_cap.F90 | 67 +++++++++++++++++++++-------- 1 file changed, 49 insertions(+), 18 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 6ea8620621..ebb4c7f277 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -464,6 +464,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) integer :: iostat integer :: readunit character(len=512) :: restartfile ! Path/Name of restart file + character(len=512) :: restartfiles ! Path/Name of restart files + ! (same as restartfile if single restart file) character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar !-------------------------------- @@ -653,10 +655,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) return endif - restartfile = "" + restartfile = ""; restartfiles = "" if (runtype == "initial") then - restartfile = "n" + restartfiles = "n" else if (runtype == "continue") then ! hybrid or branch or continuos runs @@ -675,16 +677,23 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) line=__LINE__, file=u_FILE_u, rcToReturn=rc) return endif - read(readunit,'(a)', iostat=iostat) restartfile - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & - line=__LINE__, file=u_FILE_u, rcToReturn=rc) - return - endif + do + read(readunit,'(a)', iostat=iostat) restartfile + if (iostat /= 0) then + if (len(trim(restartfiles))>1 .and. iostat<0) then + exit ! done reading restart files list. + else + call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + endif + restartfiles = trim(restartfiles) // " " // trim(restartfile) + enddo close(readunit) endif ! broadcast attribute set on master task to all tasks - call ESMF_VMBroadcast(vm, restartfile, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) + call ESMF_VMBroadcast(vm, restartfiles, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return else call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) @@ -693,7 +702,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) endif ocean_public%is_ocean_pe = .true. - call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(restartfile)) + call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(restartfiles)) call ocean_model_init_sfc(ocean_state, ocean_public) @@ -1611,10 +1620,12 @@ subroutine ModelAdvance(gcomp, rc) integer :: writeunit integer :: localPet type(ESMF_VM) :: vm - integer :: n + integer :: n, i character(240) :: import_timestr, export_timestr character(len=128) :: fldname character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' + character(len=8) :: suffix + integer :: num_rest_files rc = ESMF_SUCCESS if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") @@ -1832,6 +1843,12 @@ subroutine ModelAdvance(gcomp, rc) write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') & trim(casename), year, month, day, seconds + + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) + + ! write restart file(s) + call ocean_model_restart(ocean_state, restartname=restartname, num_rest_files=num_rest_files) + if (localPet == 0) then ! Write name of restart file in the rpointer file - this is currently hard-coded for the ocean open(newunit=writeunit, file='rpointer.ocn', form='formatted', status='unknown', iostat=iostat) @@ -1841,6 +1858,19 @@ subroutine ModelAdvance(gcomp, rc) return endif write(writeunit,'(a)') trim(restartname)//'.nc' + + if (num_rest_files > 1) then + ! append i.th restart file name to rpointer + do i=2, num_rest_files + if (num_rest_files < 10) then + write(suffix,'("_",I1)') i + else + write(suffix,'("_",I2)') i + endif + write(writeunit,'(a)') trim(restartname) // trim(suffix) // '.nc' + enddo + endif + close(writeunit) endif else @@ -1851,16 +1881,17 @@ subroutine ModelAdvance(gcomp, rc) write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & "MOM.res.", year, month, day, hour, minute, seconds endif - end if - call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - ! write restart file(s) - call ocean_model_restart(ocean_state, restartname=restartname) + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - if (is_root_pe()) then - write(logunit,*) subname//' writing restart file ',trim(restartname) - endif + ! write restart file(s) + call ocean_model_restart(ocean_state, restartname=restartname) + end if + + if (is_root_pe()) then + write(logunit,*) subname//' writing restart file ',trim(restartname) endif + endif !--------------- ! Write diagnostics From 7a2256c50e6b70517993952061a79498bf9cfde0 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 4 Aug 2020 18:14:57 -0600 Subject: [PATCH 046/103] correct restart file suffix index --- config_src/nuopc_driver/mom_cap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index ebb4c7f277..4455ce7fdc 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -1861,7 +1861,7 @@ subroutine ModelAdvance(gcomp, rc) if (num_rest_files > 1) then ! append i.th restart file name to rpointer - do i=2, num_rest_files + do i=1, num_rest_files-1 if (num_rest_files < 10) then write(suffix,'("_",I1)') i else From 4c91ae3ac2fbf2d1a1c914b919bfb1baa8d6b6e2 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 5 Aug 2020 14:32:27 -0600 Subject: [PATCH 047/103] add filename length check --- config_src/nuopc_driver/mom_cap.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 4455ce7fdc..312d2397e7 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -688,6 +688,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) return endif endif + ! check if the length of restartfiles variable is sufficient: + if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then + call MOM_error(FATAL, "Restart file name(s) too long.") + endif restartfiles = trim(restartfiles) // " " // trim(restartfile) enddo close(readunit) @@ -1862,7 +1866,7 @@ subroutine ModelAdvance(gcomp, rc) if (num_rest_files > 1) then ! append i.th restart file name to rpointer do i=1, num_rest_files-1 - if (num_rest_files < 10) then + if (i < 10) then write(suffix,'("_",I1)') i else write(suffix,'("_",I2)') i From 0a5515b3dbe647b13e28801ed70b71aa66ca0149 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 5 Aug 2020 16:54:29 -0600 Subject: [PATCH 048/103] increase restart filename lengths --- src/framework/MOM_get_input.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90 index ad48086543..b6b5b89be9 100644 --- a/src/framework/MOM_get_input.F90 +++ b/src/framework/MOM_get_input.F90 @@ -21,7 +21,8 @@ module MOM_get_input character(len=240) :: & restart_input_dir = ' ',& !< The directory to read restart and input files. restart_output_dir = ' ',&!< The directory into which to write restart files. - output_directory = ' ', & !< The directory to use to write the model output. + output_directory = ' ' !< The directory to use to write the model output. + character(len=2048) :: & input_filename = ' ' !< A string that indicates the input files or how !! the run segment should be started. end type directories @@ -46,7 +47,8 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, parameter_filename(npf), & ! List of files containing parameters. output_directory, & ! Directory to use to write the model output. restart_input_dir, & ! Directory for reading restart and input files. - restart_output_dir, & ! Directory into which to write restart files. + restart_output_dir ! Directory into which to write restart files. + character(len=2048) :: & input_filename ! A string that indicates the input files or how ! the run segment should be started. character(len=240) :: output_dir From bba3e91b51108b19a0fd826b044faefdf0cc4466 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 5 Aug 2020 16:55:23 -0600 Subject: [PATCH 049/103] increase nuopc cap restart filename length --- config_src/nuopc_driver/mom_cap.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 312d2397e7..c2a2e98838 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -464,7 +464,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) integer :: iostat integer :: readunit character(len=512) :: restartfile ! Path/Name of restart file - character(len=512) :: restartfiles ! Path/Name of restart files + character(len=2048) :: restartfiles ! Path/Name of restart files ! (same as restartfile if single restart file) character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar @@ -697,7 +697,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) close(readunit) endif ! broadcast attribute set on master task to all tasks - call ESMF_VMBroadcast(vm, restartfiles, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) + call ESMF_VMBroadcast(vm, restartfiles, count=len(restartfiles), rootPet=0, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return else call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) From 829aadea92f5abecfe6ce647583b2d20e636cb77 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 5 Aug 2020 17:13:06 -0600 Subject: [PATCH 050/103] make mct cap be able to write multiple restart files to rpointer --- config_src/mct_driver/ocn_comp_mct.F90 | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index b1ce9a60c0..9466159948 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -434,6 +434,9 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) integer :: ocn_cpl_dt !< one ocn coupling interval in seconds. (to be received from cesm) real (kind=8) :: mom_cpl_dt !< one ocn coupling interval in seconds. (internal) integer :: ncouple_per_day !< number of ocean coupled call in one day (non-dim) + integer :: num_rest_files !< number of restart files written + integer :: i + character(len=8) :: suffix ! reset shr logging to ocn log file: if (is_root_pe()) then @@ -534,7 +537,8 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') trim(runid), year, month, day, seconds call save_restart(glb%ocn_state%dirs%restart_output_dir, glb%ocn_state%Time, glb%grid, & - glb%ocn_state%restart_CSp, .false., filename=restartname, GV=glb%ocn_state%GV) + glb%ocn_state%restart_CSp, .false., filename=restartname, GV=glb%ocn_state%GV, & + num_rest_files=num_rest_files) ! write name of restart file in the rpointer file nu = shr_file_getUnit() @@ -542,6 +546,19 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) restart_pointer_file = trim(glb%pointer_filename) open(nu, file=restart_pointer_file, form='formatted', status='unknown') write(nu,'(a)') trim(restartname) //'.nc' + + if (num_rest_files > 1) then + ! append i.th restart file name to rpointer + do i=1, num_rest_files-1 + if (i < 10) then + write(suffix,'("_",I1)') i + else + write(suffix,'("_",I2)') i + endif + write(nu,'(a)') trim(restartname) // trim(suffix) // '.nc' + enddo + endif + close(nu) write(glb%stdout,*) 'ocn restart pointer file written: ',trim(restartname) endif From 648bb1ce86f19aa3577d21865c393b0537cf5b77 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 5 Aug 2020 17:35:55 -0600 Subject: [PATCH 051/103] make mct cap be able to read multiple restart files from rpointer --- config_src/mct_driver/ocn_comp_mct.F90 | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index 9466159948..741ce832e8 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -119,7 +119,9 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) integer :: year, month, day, hour, minute, seconds, seconds_n, seconds_d, rc character(len=240) :: runid !< Run ID character(len=32) :: runtype !< Run type - character(len=240) :: restartfile !< Path/Name of restart file + character(len=512) :: restartfile !< Path/Name of restart file + character(len=2048) :: restartfiles !< Path/Name of restart files. + !! (same as restartfile if a single restart file is to be read in) integer :: nu !< i/o unit to read pointer file character(len=240) :: restart_pointer_file !< File name for restart pointer file character(len=240) :: restartpath !< Path of the restart file @@ -164,6 +166,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) !logical :: lsend_precip_fact !< If T,send precip_fact to cpl for use in fw balance !! (partially-coupled option) character(len=128) :: err_msg !< Error message + integer :: iostat ! set the cdata pointers: call seq_cdata_setptrs(cdata_o, id=MOM_MCT_ID, mpicom=mpicom_ocn, & @@ -296,15 +299,27 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) nu = shr_file_getUnit() restart_pointer_file = trim(glb%pointer_filename) if (is_root_pe()) write(glb%stdout,*) 'Reading ocn pointer file: ',restart_pointer_file + restartfile = ""; restartfiles = ""; open(nu, file=restart_pointer_file, form='formatted', status='unknown') - read(nu,'(a)') restartfile + do + read(nu,'(a)', iostat=iostat) restartfile + if (len(trim(restartfiles))>1 .and. iostat<0) then + exit ! done reading restart files list. + else if (iostat/=0) then + call MOM_error(FATAL, 'Error reading rpointer.ocn') + endif + ! check if the length of restartfiles variable is sufficient: + if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then + call MOM_error(FATAL, "Restart file name(s) too long.") + endif + restartfiles = trim(restartfiles) // " " // trim(restartfile) + enddo close(nu) - !restartfile = trim(restartpath) // trim(restartfile) if (is_root_pe()) then - write(glb%stdout,*) 'Reading restart file: ',trim(restartfile) + write(glb%stdout,*) 'Reading restart file(s): ',trim(restartfiles) end if call shr_file_freeUnit(nu) - call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time_start, input_restart_file=trim(restartfile)) + call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time_start, input_restart_file=trim(restartfiles)) endif if (is_root_pe()) then write(glb%stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' From 7be08832127b4669db8644cfc261ba82163d3a5d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Aug 2020 08:13:03 -0400 Subject: [PATCH 052/103] (*)Set dSV_dT and dSV_dS with unassociated fluxes Set dSV_dT and dSV_dS if present in applyBoundaryFluxesInOut, even if boundary fluxes are not associated. With this change, setting BUOY_CONFIG='NONE' and BUOY_CONFIG='zero' both work and give similar (but not identical) answers in some test cases with an ePBL boundary layer parameterization, whereas before answers were tainted with uninitialized values when BUOY_CONFIG='NONE'. All answers in the existing MOM6-examples test suite are bitwise identical, but answers can change in other cases. --- .../vertical/MOM_diabatic_aux.F90 | 15 +++++++++------ .../vertical/MOM_vert_friction.F90 | 2 +- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 91085047c9..bf2e86cb80 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -822,19 +822,18 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - ! Only apply forcing if fluxes%sw is associated. - if (.not.associated(fluxes%sw)) return - -#define _OLD_ALG_ Idt = 1.0 / dt calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) if (calculate_buoyancy) SkinBuoyFlux(:,:) = 0.0 + if (present(cTKE)) cTKE(:,:,:) = 0.0 g_Hconv2 = (US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ) * GV%H_to_RZ EOSdom(:) = EOS_domain(G%HI) - if (present(cTKE)) cTKE(:,:,:) = 0.0 + ! Only apply forcing if fluxes%sw is associated. + if (.not.associated(fluxes%sw) .and. .not.calculate_energetics) return + if (calculate_buoyancy) then SurfPressure(:) = 0.0 GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 @@ -874,7 +873,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t h2d(i,k) = h(i,j,k) T2d(i,k) = tv%T(i,j,k) enddo ; enddo - if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=(1.0/GV%m_to_H)) if (calculate_energetics) then ! The partial derivatives of specific volume with temperature and @@ -898,6 +896,11 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t pen_TKE_2d(:,:) = 0.0 endif + ! Nothing more is done on this j-slice if there is no buoyancy forcing. + if (.not.associated(fluxes%sw)) cycle + + if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=(1.0/GV%m_to_H)) + ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: ! netMassInOut = surface water fluxes [H ~> m or kg m-2] over time step diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index c6a6f37b39..1a4fb58e02 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1143,12 +1143,12 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: z2 ! A copy of z_i [nondim] + real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] real :: topfn ! A function that is 1 at the top and small far from it [nondim] real :: kv_top ! A viscosity associated with the top boundary layer [Z2 T-1 ~> m2 s-1] logical :: do_shelf, do_OBCs integer :: i, k, is, ie, max_nk integer :: nz - real :: botfn a_cpl(:,:) = 0.0 Kv_tot(:,:) = 0.0 From feed9ba82b9ebe6805ce691e77190b2f5ba4f7ee Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Aug 2020 08:13:40 -0400 Subject: [PATCH 053/103] (*)Fix an indexing bug in int_density_dz_linear Corrected a horizontal indexing bug in int_density_dz_linear that caused the ISOMIP/layer test case to fail. This bug was first introduced with PR#732 on March 8, 2018. This bug fix will change answers with a linear equation of state and the finite volume pressure gradient force, however it does not change any of the verified answers in the MOM6-examples regression suite. --- src/equation_of_state/MOM_EOS_linear.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index e3a5443840..47a2bf21b0 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -473,7 +473,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) do m=2,4 wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR From 3c10ae18a72b3096ea69b81dc3906931eefa9a6f Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 10 Aug 2020 10:46:31 -0400 Subject: [PATCH 054/103] Remove outdated comments --- src/core/MOM_open_boundary.F90 | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index f94060fc39..37ebeda1fa 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -546,13 +546,6 @@ subroutine open_boundary_config(G, US, param_file, OBC) if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out enddo - ! There is a problem with the order of the OBC initialization - ! with respect to ALE_init. Currently handling this by copying the - ! param file so that I can use it later in step_MOM in order to finish - ! initializing segments on the first step. - - ! Is the above comment still relevant ? - call get_param(param_file, mdl, "REMAPPING_SCHEME", remappingScheme, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& From 6331da1029854141e9fe88e6730f48652ee928c9 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 13 Aug 2020 09:28:16 -0600 Subject: [PATCH 055/103] Remove (:,:) after 2-d variable declariation --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index dd2e015632..73e4669734 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -314,9 +314,9 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe real, dimension(nk) :: h !< Layer thicknesses [H ~> m or kg m-2] real :: hBLT !< Depth of the boundary layer [H ~> m or kg m-2] real, dimension(nk) :: phi !< Scalar quantity - real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial - real, dimension(nk,deg+1) :: ppoly0_coefs(:,:) !< Coefficients of polynomial - integer :: method !< Remapping scheme to use + real, dimension(nk,2) :: ppoly0_E !< Edge value of polynomial + real, dimension(nk,deg+1) :: ppoly0_coefs!< Coefficients of polynomial + integer :: method !< Remapping scheme to use integer :: k_top !< Index of the first layer within the boundary real :: zeta_top !< Fraction of the layer encompassed by the bottom boundary layer From 287281cf6496ff328e208e69fc01e68cf2713c27 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 13 Aug 2020 09:33:06 -0600 Subject: [PATCH 056/103] Remove unnecessary present(num_rest_files) condition --- config_src/nuopc_driver/mom_ocean_model_nuopc.F90 | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index cbbb2261d0..1ba3484ef9 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -690,13 +690,8 @@ subroutine ocean_model_restart(OS, timestamp, restartname, num_rest_files) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - if (present(num_rest_files)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) - else - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname) - endif + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then From ab9386c662dbe096c34b29bd55c184b3fafa20bc Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 13 Aug 2020 09:41:12 -0600 Subject: [PATCH 057/103] In do-loops, use uppercase K index for variables discretized on interfaces --- .../vertical/MOM_tidal_mixing.F90 | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 951170c039..708d6a7f46 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -783,8 +783,8 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable - do k=1,G%ke+1 - N2_int_i(k) = US%s_to_T**2 * N2_int(i,k) + do K=1,G%ke+1 + N2_int_i(K) = US%s_to_T**2 * N2_int(i,K) enddo call CVMix_coeffs_tidal( Mdiff_out = Kv_tidal, & @@ -803,14 +803,14 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo if (present(Kd_int)) then - do k=1,G%ke+1 - Kd_int(i,j,k) = Kd_int(i,j,k) + (US%m2_s_to_Z2_T * Kd_tidal(k)) + do K=1,G%ke+1 + Kd_int(i,j,K) = Kd_int(i,j,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) enddo endif ! Update viscosity with the proper unit conversion. if (associated(Kv)) then - do k=1,G%ke+1 - Kv(i,j,k) = Kv(i,j,k) + US%m2_s_to_Z2_T * Kv_tidal(k) ! Rescale from m2 s-1 to Z2 T-1. + do K=1,G%ke+1 + Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * Kv_tidal(K) ! Rescale from m2 s-1 to Z2 T-1. enddo endif @@ -903,15 +903,15 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo if (present(Kd_int)) then - do k=1,G%ke+1 - Kd_int(i,j,k) = Kd_int(i,j,k) + (US%m2_s_to_Z2_T * Kd_tidal(k)) + do K=1,G%ke+1 + Kd_int(i,j,K) = Kd_int(i,j,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) enddo endif ! Update viscosity if (associated(Kv)) then - do k=1,G%ke+1 - Kv(i,j,k) = Kv(i,j,k) + US%m2_s_to_Z2_T * Kv_tidal(k) ! Rescale from m2 s-1 to Z2 T-1. + do K=1,G%ke+1 + Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * Kv_tidal(K) ! Rescale from m2 s-1 to Z2 T-1. enddo endif From f4281ed2f8d61698d1884f9bfaa6550c9f1423cd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 13 Aug 2020 13:06:08 -0400 Subject: [PATCH 058/103] +Move find_interfaces to MOM_state_initialization Simplified and cleaned up find_interfaces and moved it from MOM_tracer_Z_init to MOM_state_initialization, reflecting the fact that it is only used from within MOM_state_initialization and that it has very little to do with tracer initialization. The subroutine fast_bisect was inlined into find_interfaces and the stand-alone version was deleted. One minor bug that could change answers was noted but not corrected. All answers are bitwise identical, but the previously publicly visible interface to find_interfaces was made private to the MOM_state_initialization module. --- .../MOM_state_initialization.F90 | 110 ++++++++++- src/tracer/MOM_tracer_Z_init.F90 | 179 +----------------- 2 files changed, 110 insertions(+), 179 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index b613648c7c..9f505325bf 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -84,7 +84,7 @@ module MOM_state_initialization use dense_water_initialization, only : dense_water_initialize_TS use dense_water_initialization, only : dense_water_initialize_sponges use dumbbell_initialization, only : dumbbell_initialize_sponges -use MOM_tracer_Z_init, only : find_interfaces, tracer_Z_init_array, determine_temperature +use MOM_tracer_Z_init, only : tracer_Z_init_array, determine_temperature use MOM_ALE, only : ALE_initRegridding, ALE_CS, ALE_initThicknessToCoord use MOM_ALE, only : ALE_remap_scalar, ALE_build_grid, ALE_regrid_accelerated use MOM_ALE, only : TS_PLM_edge_values @@ -2422,6 +2422,114 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param end subroutine MOM_temp_salt_initialize_from_Z + +!> Find interface positions corresponding to interpolated depths in a density profile +subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, US, nlevs, nkml, hml, & + eps_z, eps_rho) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + integer, intent(in) :: nk_data !< The number of levels in the input data + real, dimension(SZI_(G),SZJ_(G),nk_data), & + intent(in) :: rho !< Potential density in z-space [R ~> kg m-3] + real, dimension(nk_data), intent(in) :: zin !< Input data levels [Z ~> m]. + real, dimension(SZK_(G)+1), intent(in) :: Rb !< target interface densities [R ~> kg m-3] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth !< ocean depth [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + intent(out) :: zi !< The returned interface heights [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: nlevs !< number of valid points in each column + integer, intent(in) :: nkml !< number of mixed layer pieces to distribute over + !! a depth of hml. + real, intent(in) :: hml !< mixed layer depth [Z ~> m]. + real, intent(in) :: eps_z !< A negligibly small layer thickness [Z ~> m]. + real, intent(in) :: eps_rho !< A negligibly small density difference [R ~> kg m-3]. + + ! Local variables + real, dimension(nk_data) :: rho_ ! A column of densities [R ~> kg m-3] + real, dimension(SZK_(G)+1) :: zi_ ! A column interface heights (negative downward) [Z ~> m]. + real :: slope ! The rate of change of height with density [Z R-1 ~> m4 kg-1] + real :: drhodz ! A local vertical density gradient [R Z-1 ~> kg m-4] + real, parameter :: zoff=0.999 + logical :: unstable ! True if the column is statically unstable anywhere. + integer :: nlevs_data ! The number of data values in a column. + logical :: work_down ! This indicates whether this pass goes up or down the water column. + integer :: k_int, lo_int, hi_int, mid + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + + zi(:,:,:) = 0.0 + + do j=js,je ; do i=is,ie + nlevs_data = nlevs(i,j) + do k=1,nlevs_data ; rho_(k) = rho(i,j,k) ; enddo + + unstable=.true. + work_down = .true. + do while (unstable) + ! Modifiy the input profile until it no longer has densities that decrease with depth. + unstable=.false. + if (work_down) then + do k=2,nlevs_data-1 ; if (rho_(k) - rho_(k-1) < 0.0 ) then + if (k == 2) then + rho_(k-1) = rho_(k) - eps_rho + else + drhodz = (rho_(k+1)-rho_(k-1)) / (zin(k+1)-zin(k-1)) + if (drhodz < 0.0) unstable=.true. + rho_(k) = rho_(k-1) + drhodz*zoff*(zin(k)-zin(k-1)) + endif + endif ; enddo + work_down = .false. + else + do k=nlevs_data-1,2,-1 ; if (rho_(k+1) - rho_(k) < 0.0) then + if (k == nlevs_data-1) then + rho_(k+1) = rho_(k-1) + eps_rho !### This should be rho_(k) + eps_rho + else + drhodz = (rho_(k+1)-rho_(k-1)) / (zin(k+1)-zin(k-1)) + if (drhodz < 0.0) unstable=.true. + rho_(k) = rho_(k+1) - drhodz*(zin(k+1)-zin(k)) + endif + endif ; enddo + work_down = .true. + endif + enddo + + ! Find and store the interface depths. + zi_(1) = 0.0 + do K=2,nz + ! Find the value of k_int in the list of rho_ where rho_(k_int) <= Rb(K) < rho_(k_int+1). + ! This might be made a little faster by exploiting the fact that Rb is + ! monotonically increasing and not resetting lo_int back to 1 inside the K loop. + lo_int = 1 ; hi_int = nlevs_data + do while (lo_int < hi_int) + mid = (lo_int+hi_int) / 2 + if (Rb(K) < rho_(mid)) then ; hi_int = mid + else ; lo_int = mid+1 ; endif + enddo + k_int = max(1, lo_int-1) + + ! Linearly interpolate to find the depth, zi_, where Rb would be found. + slope = (zin(k_int+1) - zin(k_int)) / max(rho_(k_int+1) - rho_(k_int), eps_rho) + zi_(K) = -1.0*(zin(k_int) + slope*(Rb(K)-rho_(k_int))) + zi_(K) = min(max(zi_(K), -depth(i,j)), -1.0*hml) + enddo + zi_(nz+1) = -depth(i,j) + if (nkml > 0) then ; do K=2,nkml+1 + zi_(K) = max(hml*((1.0-real(K))/real(nkml)), -depth(i,j)) + enddo ; endif + do K=nz,max(nkml+2,2),-1 + if (zi_(K) < zi_(K+1) + eps_Z) zi_(K) = zi_(K+1) + eps_Z + if (zi_(K) > -1.0*hml) zi_(K) = max(-1.0*hml, -depth(i,j)) + enddo + + do K=1,nz+1 + zi(i,j,K) = zi_(K) + enddo + enddo ; enddo ! i- and j- loops + +end subroutine find_interfaces + !> Run simple unit tests subroutine MOM_state_init_tests(G, GV, US, tv) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 401bf82a2b..ac6242785e 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -16,7 +16,7 @@ module MOM_tracer_Z_init #include -public tracer_Z_init, tracer_Z_init_array, find_interfaces, determine_temperature +public tracer_Z_init, tracer_Z_init_array, determine_temperature ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -608,135 +608,6 @@ function find_limited_slope(val, e, k) result(slope) end function find_limited_slope -!> Find interface positions corresponding to density profile -subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, US, nlevs, nkml, hml, debug, & - eps_z, eps_rho) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - integer, intent(in) :: nk_data !< The number of levels in the input data - real, dimension(SZI_(G),SZJ_(G),nk_data), & - intent(in) :: rho !< Potential density in z-space [R ~> kg m-3] - real, dimension(nk_data), intent(in) :: zin !< Input data levels [Z ~> m]. - real, dimension(SZK_(G)+1), intent(in) :: Rb !< target interface densities [R ~> kg m-3] - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: depth !< ocean depth [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - intent(out) :: zi !< The returned interface heights [Z ~> m] - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - integer, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: nlevs !< number of valid points in each column - logical, optional, intent(in) :: debug !< optional debug flag - integer, optional, intent(in) :: nkml !< number of mixed layer pieces to distribute over - !! a depth of hml. - real, optional, intent(in) :: hml !< mixed layer depth [Z ~> m]. - real, optional, intent(in) :: eps_z !< A negligibly small layer thickness [Z ~> m]. - real, optional, intent(in) :: eps_rho !< A negligibly small density difference [R ~> kg m-3]. - - ! Local variables - real, dimension(SZI_(G),nk_data) :: rho_ ! A slice of densities [R ~> kg m-3] - logical :: unstable - integer :: dir - integer, dimension(SZI_(G),SZK_(G)+1) :: ki_ - real, dimension(SZI_(G),SZK_(G)+1) :: zi_ ! A slice of interface heights (negative downward) [Z ~> m]. - integer, dimension(SZI_(G),SZJ_(G)) :: nlevs_data - integer, dimension(SZI_(G)) :: lo, hi - real :: slope ! The rate of change of height with density [Z R-1 ~> m4 kg-1] - real :: drhodz ! A local vertical density gradient [R Z-1 ~> kg m-4] - real :: hml_ ! The depth of the mixed layer to use for the topmost nkml_ layers [Z ~> m]. - real :: epsln_Z ! A negligibly thin layer thickness [m or Z ~> m]. - real :: epsln_rho ! A negligibly small density change [R ~> kg m-3]. - real, parameter :: zoff=0.999 - integer :: nkml_ - logical :: debug_ = .false. - integer :: i, j, k, m, n, is, ie, js, je, nz - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - - zi(:,:,:) = 0.0 - - if (PRESENT(debug)) debug_=debug - - nlevs_data(:,:) = nz - - nkml_ = 0 ; if (PRESENT(nkml)) nkml_ = max(0, nkml) - hml_ = 0.0 ; if (PRESENT(hml)) hml_ = hml - epsln_Z = 1.0e-10*US%m_to_Z ; if (PRESENT(eps_z)) epsln_Z = eps_z - epsln_rho = 1.0e-10*US%kg_m3_to_R ; if (PRESENT(eps_rho)) epsln_rho = eps_rho - - if (PRESENT(nlevs)) then - nlevs_data(:,:) = nlevs(:,:) - endif - - do j=js,je - rho_(:,:) = rho(:,j,:) - i_loop: do i=is,ie - if (debug_) then - print *,'looking for interfaces, i,j,nlevs= ',i,j,nlevs_data(i,j) - print *,'initial density profile= ', rho_(i,:) - endif - unstable=.true. - dir=1 - do while (unstable) - unstable=.false. - if (dir == 1) then - do k=2,nlevs_data(i,j)-1 - if (rho_(i,k) - rho_(i,k-1) < 0.0 ) then - if (k == 2) then - rho_(i,k-1) = rho_(i,k)-epsln_rho - else - drhodz = (rho_(i,k+1)-rho_(i,k-1)) / (zin(k+1)-zin(k-1)) - if (drhodz < 0.0) unstable=.true. - rho_(i,k) = rho_(i,k-1) + drhodz*zoff*(zin(k)-zin(k-1)) - endif - endif - enddo - dir = -1*dir - else - do k=nlevs_data(i,j)-1,2,-1 - if (rho_(i,k+1) - rho_(i,k) < 0.0) then - if (k == nlevs_data(i,j)-1) then - rho_(i,k+1) = rho_(i,k-1)+epsln_rho - else - drhodz = (rho_(i,k+1)-rho_(i,k-1))/(zin(k+1)-zin(k-1)) - if (drhodz < 0.0) unstable=.true. - rho_(i,k) = rho_(i,k+1)-drhodz*(zin(k+1)-zin(k)) - endif - endif - enddo - dir = -1*dir - endif - enddo - if (debug_) then - print *,'final density profile= ', rho_(i,:) - endif - enddo i_loop - - ki_(:,:) = 0 - zi_(:,:) = 0.0 - lo(:) = 1 - hi(:) = nlevs_data(:,j) - ki_ = bisect_fast(rho_, Rb, lo, hi) - ki_(:,:) = max(1, ki_(:,:)-1) - do i=is,ie - do m=2,nz - slope = (zin(ki_(i,m)+1) - zin(ki_(i,m))) / max(rho_(i,ki_(i,m)+1) - rho_(i,ki_(i,m)),epsln_rho) - zi_(i,m) = -1.0*(zin(ki_(i,m)) + slope*(Rb(m)-rho_(i,ki_(i,m)))) - zi_(i,m) = max(zi_(i,m), -depth(i,j)) - zi_(i,m) = min(zi_(i,m), -1.0*hml_) - enddo - zi_(i,nz+1) = -depth(i,j) - do m=2,nkml_+1 - zi_(i,m) = max(hml_*((1.0-real(m))/real(nkml_)), -depth(i,j)) - enddo - do m=nz,nkml_+2,-1 - if (zi_(i,m) < zi_(i,m+1) + epsln_Z) zi_(i,m) = zi_(i,m+1) + epsln_Z - if (zi_(i,m) > -1.0*hml_) zi_(i,m) = max(-1.0*hml_, -depth(i,j)) - enddo - enddo - zi(:,j,:) = zi_(:,:) - enddo - -end subroutine find_interfaces - !> This subroutine determines the potential temperature and salinity that !! is consistent with the target density using provided initial guess subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, k_start, G, US, eos, h_massless) @@ -855,52 +726,4 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, end subroutine determine_temperature -!> Return the index where to insert item x in list a, assuming a is sorted. -!! The return values [i] is such that all e in a[:i-1] have e <= x, and all e in -!! a[i:] have e > x. So if x already appears in the list, will -!! insert just after the rightmost x already there. -!! Optional args lo (default 1) and hi (default len(a)) bound the -!! slice of a to be searched. -function bisect_fast(a, x, lo, hi) result(bi_r) - real, dimension(:,:), intent(in) :: a !< Sorted list - real, dimension(:), intent(in) :: x !< Item to be inserted - integer, dimension(size(a,1)), optional, intent(in) :: lo !< Lower bracket of optional range to search - integer, dimension(size(a,1)), optional, intent(in) :: hi !< Upper bracket of optional range to search - integer, dimension(size(a,1),size(x,1)) :: bi_r - - integer :: mid,num_x,num_a,i - integer, dimension(size(a,1)) :: lo_,hi_,lo0,hi0 - integer :: nprofs,j - - lo_=1;hi_=size(a,2);num_x=size(x,1);bi_r=-1;nprofs=size(a,1) - - if (PRESENT(lo)) then - where (lo>0) lo_=lo - endif - if (PRESENT(hi)) then - where (hi>0) hi_=hi - endif - - lo0=lo_;hi0=hi_ - - do j=1,nprofs - do i=1,num_x - lo_=lo0;hi_=hi0 - do while (lo_(j) < hi_(j)) - mid = (lo_(j)+hi_(j))/2 - if (x(i) < a(j,mid)) then - hi_(j) = mid - else - lo_(j) = mid+1 - endif - enddo - bi_r(j,i)=lo_(j) - enddo - enddo - - - return - -end function bisect_fast - end module MOM_tracer_Z_init From f147071032e8255a8d8c243f26ce07054c092ee3 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 14 Aug 2020 15:37:22 -0400 Subject: [PATCH 059/103] New option to use a grid index convention for spatially-varying diagnostics. --- src/framework/MOM_diag_mediator.F90 | 80 ++++++++++++++++++++++++----- 1 file changed, 66 insertions(+), 14 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 2a71e7cda5..28c4c867d7 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -243,7 +243,7 @@ module MOM_diag_mediator integer :: chksum_iounit = -1 !< The unit number of a diagnostic documentation file. !! This file is open if available_diag_doc_unit is > 0. logical :: diag_as_chksum !< If true, log chksums in a text file instead of posting diagnostics - + logical :: grid_space_axes !< If true, diagnostic horizontal coordinates axes are in grid space. ! The following fields are used for the output of the data. integer :: is !< The start i-index of cell centers within the computational domain integer :: ie !< The end i-index of cell centers within the computational domain @@ -359,25 +359,71 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) integer :: i, j, k, nz real :: zlev(GV%ke), zinter(GV%ke+1) logical :: set_vert + real, allocatable, dimension(:) :: IaxB,iax + real, allocatable, dimension(:) :: JaxB,jax + set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical + + if (diag_cs%grid_space_axes) then + allocate(IaxB(G%IsgB:G%IegB)) + do i=G%IsgB, G%IegB + Iaxb(i)=real(i) + enddo + allocate(iax(G%isg:G%ieg)) + do i=G%isg, G%ieg + iax(i)=real(i)-0.5 + enddo + allocate(JaxB(G%JsgB:G%JegB)) + do j=G%JsgB, G%JegB + JaxB(j)=real(j) + enddo + allocate(jax(G%jsg:G%jeg)) + do j=G%jsg, G%jeg + jax(j)=real(j)-0.5 + enddo + endif + ! Horizontal axes for the native grids if (G%symmetric) then - id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) - id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + if (diag_cs%grid_space_axes) then + id_xq = diag_axis_init('iq', IaxB(G%isgB:G%iegB), 'none', 'x', & + 'q point grid-space longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('jq', JaxB(G%jsgB:G%jegB), 'none', 'y', & + 'q point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + else + id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + endif else - id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) - id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + if (diag_cs%grid_space_axes) then + id_xq = diag_axis_init('Iq', IaxB(G%isg:G%ieg), 'none', 'x', & + 'q point grid-space longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('Jq', JaxB(G%jsg:G%jeg), 'none', 'y', & + 'q point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + else + id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + endif + endif + + + if (diag_cs%grid_space_axes) then + id_xh = diag_axis_init('ih', iax(G%isg:G%ieg), 'none', 'x', & + 'h point grid-space longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yh = diag_axis_init('jh', jax(G%jsg:G%jeg), 'none', 'y', & + 'h point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + else + id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & + 'h point nominal longitude', Domain2=G%Domain%mpp_domain) + id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'h point nominal latitude', Domain2=G%Domain%mpp_domain) endif - id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & - 'h point nominal longitude', Domain2=G%Domain%mpp_domain) - id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'h point nominal latitude', Domain2=G%Domain%mpp_domain) if (set_vert) then nz = GV%ke @@ -531,6 +577,9 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) endif enddo + if (diag_cs%grid_space_axes) then + deallocate(IaxB,iax,JaxB,jax) + endif !Define the downsampled axes call set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) @@ -3037,6 +3086,10 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) + call get_param(param_file, mdl, 'USE_GRID_SPACE_DIAGNOSTIC_AXES', diag_cs%grid_space_axes, & + 'If true, use a grid index coordinate convention for diagnostic axes. ',& + default=.false.) + if (diag_cs%num_diag_coords>0) then allocate(diag_coords(diag_cs%num_diag_coords)) if (diag_cs%num_diag_coords==1) then ! The default is to provide just one instance of Z* @@ -4264,4 +4317,3 @@ subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_ end subroutine downsample_mask_3d end module MOM_diag_mediator - From fefa30e7fc04fd00fa40a8fc03ac69597d4354f3 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 17 Aug 2020 12:03:28 -0400 Subject: [PATCH 060/103] Tests tc0 diagnostic axes in grid space. --- .testing/tc0/MOM_input | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.testing/tc0/MOM_input b/.testing/tc0/MOM_input index be1cae0908..ff64c55803 100644 --- a/.testing/tc0/MOM_input +++ b/.testing/tc0/MOM_input @@ -138,6 +138,9 @@ THICKNESS_CONFIG = "uniform" ! ! === module MOM_diag_mediator === +USE_GRID_SPACE_DIAG_COORDINATE_AXES = True ! [Boolean] default = False + ! If true, use a grid index coordinate convention for diagnostic axes. + ! === module MOM_MEKE === ! === module MOM_lateral_mixing_coeffs === From 13d74a4f6b424a47cd23eeac43bd3bd67a7f29f0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 17 Aug 2020 17:47:34 -0400 Subject: [PATCH 061/103] (*)Revised the routine wave_speeds Revised wave_speeds to agree with the calculation of the first mode wave speed in wave_speed, and to also avoid returning speeds that report back uninitialized values that do not reproduce across processor layouts and are not dimensionally consistent. With these revisions, the diagnosed speeds of the modes reproduce other solutions, reproduce across layouts, are of sensible magnitude and are demonstrably dimensionally consistent. This includes a complete rewrite of tridiag_det, which previously was just wrong. Also revised the calls to register_diag_field for the cn1 and cn_mode# diagnostics to include conversion factors. All existing MOM6-examples solutions are bitwise identical, although there would be answer changes in cases where the wave speeds are used in active parameterizations. --- src/diagnostics/MOM_wave_speed.F90 | 172 ++++++++---------- .../vertical/MOM_diabatic_driver.F90 | 5 +- 2 files changed, 77 insertions(+), 100 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index b3321cdace..00a5c1f4a8 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -686,6 +686,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee !! below which 0 is returned [L T-1 ~> m s-1]. real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the !! wave speeds [nondim] + ! Local variables real, dimension(SZK_(G)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] @@ -696,23 +697,22 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee H_top, & ! The distance of each filtered interface from the ocean surface [Z ~> m] H_bot, & ! The distance of each filtered interface from the bottom [Z ~> m] gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. - real, dimension(SZK_(G)) :: & - Igl, Igu ! The inverse of the reduced gravity across an interface times - ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. - real, dimension(SZK_(G)-1) :: & - a_diag, b_diag, c_diag - ! diagonals of tridiagonal matrix; one value for each - ! interface (excluding surface and bottom) [T2 L-2 ~> s2 m-2] real, dimension(SZK_(G),SZI_(G)) :: & Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [degC] Sf, & ! Layer salinities after very thin layers are combined [ppt] Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] real, dimension(SZK_(G)) :: & + Igl, Igu, & ! The inverse of the reduced gravity across an interface times + ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. Hc, & ! A column of layer thicknesses after convective istabilities are removed [Z ~> m] Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] Rc ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] + real, dimension(SZK_(G)-1) :: & + a_diag, b_diag, c_diag + ! diagonals of tridiagonal matrix; one value for each + ! interface (excluding surface and bottom) [T2 L-2 ~> s2 m-2] real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] real :: c1_thresh ! if c1 is below this value, don't bother calculating ! cn values for higher modes [L T-1 ~> m s-1] @@ -722,7 +722,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee real :: det, ddet ! determinant & its derivative of eigen system real :: lam_1 ! approximate mode-1 eigenvalue [T2 L-2 ~> s2 m-2] real :: lam_n ! approximate mode-n eigenvalue [T2 L-2 ~> s2 m-2] - real :: dlam ! increment in lam for Newton's method [T2 L-2 ~> s2 m-2] + real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s m-1] real :: lamMin ! minimum lam value for root searching range [T2 L-2 ~> s2 m-2] real :: lamMax ! maximum lam value for root searching range [T2 L-2 ~> s2 m-2] real :: lamInc ! width of moving window for root searching [T2 L-2 ~> s2 m-2] @@ -735,7 +735,6 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee xbl,xbr ! lam guesses bracketing a zero-crossing (root) [T2 L-2 ~> s2 m-2] integer :: numint ! number of widows (intervals) in root searching range integer :: nrootsfound ! number of extra roots found (not including 1st root) - real :: min_h_frac real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] real, dimension(SZI_(G)) :: & htot, hmin, & ! Thicknesses [Z ~> m] @@ -747,13 +746,14 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee real :: speed2_min ! minimum mode speed (squared) to consider in root searching [L2 T-2 ~> m2 s-2] real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] real, parameter :: reduct_factor = 0.5 - ! factor used in setting speed2_min [nondim] + ! A factor used in setting speed2_min [nondim] real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. real :: tol_Hfrac ! Layers that together are smaller than this fraction of ! the total water column can be merged for efficiency. + real :: min_h_frac ! tol_Hfrac divided by the total number of layers [nondim]. real :: tol_solve ! The fractional tolerance with which to solve for the wave speeds [nondim]. real :: tol_merge ! The fractional change in estimated wave speed that is allowed ! when deciding to merge layers in the calculation [nondim] @@ -762,8 +762,6 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee logical :: use_EOS ! If true, density is calculated from T & S using the equation of state. logical :: better_est ! If true, use an improved estimate of the first mode internal wave speed. logical :: merge ! If true, merge the current layer with the one above. - real, dimension(SZK_(G)+1) :: z_int - ! real, dimension(SZK_(G)+1) :: N2 ! The local squared buoyancy frequency [T-2 ~> s-2] integer :: nsub ! number of subintervals used for root finding integer, parameter :: sub_it_max = 4 ! maximum number of times to subdivide interval @@ -786,9 +784,9 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee S => tv%S ; T => tv%T g_Rho0 = GV%g_Earth / GV%Rho0 - use_EOS = associated(tv%eqn_of_state) ! Simplifying the following could change answers at roundoff. Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) + use_EOS = associated(tv%eqn_of_state) c1_thresh = 0.01*US%m_s_to_L_T c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. @@ -799,11 +797,15 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee if (present(wave_speed_tol)) tol_solve = wave_speed_tol tol_Hfrac = 0.1*tol_solve ; tol_merge = tol_solve / real(nz) else - tol_Hfrac = 0.0001 ; tol_solve = 0.001 ; tol_merge = 0.001 + tol_solve = 0.001 ; tol_Hfrac = 0.0001 ; tol_merge = 0.001 endif cg1_min2 = 0.0 ; if (present(CS)) cg1_min2 = CS%min_speed2 if (present(min_speed)) cg1_min2 = min_speed**2 + ! Zero out all wave speeds. Values over land or for columns that are too weakly stratified + ! are not changed from this zero value. + cn(:,:,:) = 0.0 + min_h_frac = tol_Hfrac / real(nz) !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S, & !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2,better_est, & @@ -922,9 +924,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! Find gprime across each internal interface, taking care of convective ! instabilities by merging layers. - if (g_Rho0 * drxh_sum <= cg1_min2) then - cn(i,j,:) = 0.0 - else + if (g_Rho0 * drxh_sum > cg1_min2) then ! Merge layers to eliminate convective instabilities or exceedingly ! small reduced gravities. Merging layers reduces the estimated wave speed by ! (rho(2)-rho(1))*h(1)*h(2) / H_tot. @@ -995,7 +995,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! far back we go. do k2=kc,2,-1 if (better_est) then - merge = ((Rc(k2)-Rc(k2-1)) * ((Hc(kc) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + merge = ((Rc(k2)-Rc(k2-1)) * ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) else merge = ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol_merge*drxh_sum) endif @@ -1019,12 +1019,11 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee endif ! use_EOS !-----------------NOW FIND WAVE SPEEDS--------------------------------------- - ig = i + G%idg_offset ; jg = j + G%jdg_offset + ! ig = i + G%idg_offset ; jg = j + G%jdg_offset ! Sum the contributions from all of the interfaces to give an over-estimate - ! of the first-mode wave speed. + ! of the first-mode wave speed. Also populate Igl and Igu which are the + ! non-leading diagonals of the tridiagonal matrix. if (kc >= 2) then - ! Set depth at surface - z_int(1) = 0.0 ! initialize speed2_tot speed2_tot = 0.0 if (better_est) then @@ -1038,41 +1037,25 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! [excludes surface (K=1) and bottom (K=kc+1)] do K=2,kc Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) - z_int(K) = z_int(K-1) + Hc(k-1) - ! N2(K) = US%L_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) if (better_est) then speed2_tot = speed2_tot + gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) else speed2_tot = speed2_tot + gprime(K)*(Hc(k-1)+Hc(k)) endif enddo - ! Set stratification for surface and bottom (setting equal to nearest interface for now) - ! N2(1) = N2(2) ; N2(kc+1) = N2(kc) - ! Calculate depth at bottom - z_int(kc+1) = z_int(kc)+Hc(kc) - ! check that thicknesses sum to total depth - if (abs(z_int(kc+1)-htot(i)) > 1.e-12*htot(i)) then - call MOM_error(FATAL, "wave_structure: mismatch in total depths") - endif - ! Define the diagonals of the tridiagonal matrix - ! First, populate interior rows - do K=3,kc-1 - row = K-1 ! indexing for TD matrix rows - a_diag(row) = -Igu(K) - b_diag(row) = Igu(K)+Igl(K) - c_diag(row) = -Igl(K) + ! Define the diagonals of the tridiagonal matrix for use by tridiag_det + a_diag(1) = 0.0 + b_diag(1) = Igu(2)+Igl(2) + c_diag(1) = -Igl(2) + do k=2,kc-2 + a_diag(k) = -Igu(k+1) + b_diag(k) = Igu(k+1)+Igl(k+1) + c_diag(k) = -Igl(k+1) enddo - ! Populate top row of tridiagonal matrix - K=2 ; row = K-1 - a_diag(row) = 0.0 - b_diag(row) = Igu(K)+Igl(K) - c_diag(row) = -Igl(K) - ! Populate bottom row of tridiagonal matrix - K=kc ; row = K-1 - a_diag(row) = -Igu(K) - b_diag(row) = Igu(K)+Igl(K) - c_diag(row) = 0.0 + a_diag(kc-1) = -Igu(kc) + b_diag(kc-1) = Igu(kc)+Igl(kc) + c_diag(kc-1) = 0.0 ! Total number of rows in the matrix = number of interior interfaces nrows = kc-1 @@ -1082,26 +1065,26 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! Find the first eigen value do itt=1,max_itt ! calculate the determinant of (A-lam_1*I) - call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lam_1,det,ddet, row_scale=c2_scale) - ! Use Newton's method iteration to find a new estimate of lam_1 + call tridiag_det(a_diag(1:nrows), b_diag(1:nrows), c_diag(1:nrows), & + nrows, lam_1, det, ddet, row_scale=c2_scale) + + ! If possible, use Newton's method iteration to find a new estimate of lam_1 !det = det_it(itt) ; ddet = ddet_it(itt) if ((ddet >= 0.0) .or. (-det > -0.5*lam_1*ddet)) then ! lam_1 was not an under-estimate, as intended, so Newton's method - ! may not be reliable; lam_1 must be reduced, but not by more - ! than half. + ! may not be reliable; lam_1 must be reduced, but not by more than half. lam_1 = 0.5 * lam_1 + dlam = -lam_1 else ! Newton's method is OK. dlam = - det / ddet lam_1 = lam_1 + dlam - if (abs(dlam) < tol_solve*lam_1) then - ! calculate 1st mode speed - if (lam_1 > 0.0) cn(i,j,1) = 1.0 / sqrt(lam_1) - exit - endif endif + + if (abs(dlam) < tol_solve*lam_1) exit enddo + if (lam_1 > 0.0) cn(i,j,1) = 1.0 / sqrt(lam_1) + ! Find other eigen values if c1 is of significant magnitude, > cn_thresh nrootsfound = 0 ! number of extra roots found (not including 1st root) if (nmodes>1 .and. kc>=nmodes+1 .and. cn(i,j,1)>c1_thresh) then @@ -1177,7 +1160,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee elseif (iint == numint) then ! oops, lamMax not large enough - could add code to increase (BDM) ! set unfound modes to zero for now (BDM) - cn(i,j,nrootsfound+2:nmodes) = 0.0 + ! cn(i,j,nrootsfound+2:nmodes) = 0.0 else ! else shift interval and keep looking until nmodes or numint is reached det_l = det_r @@ -1195,22 +1178,14 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! Use Newton's method to find a new estimate of lam_n dlam = - det / ddet lam_n = lam_n + dlam - if (abs(dlam) < tol_solve*lam_1) then - ! calculate nth mode speed - if (lam_n > 0.0) cn(i,j,m+1) = 1.0 / sqrt(lam_n) - exit - endif ! within tol + if (abs(dlam) < tol_solve*lam_1) exit enddo ! itt-loop + ! calculate nth mode speed + if (lam_n > 0.0) cn(i,j,m+1) = 1.0 / sqrt(lam_n) enddo ! n-loop - else - cn(i,j,2:nmodes) = 0.0 ! else too small to worry about endif ! if nmodes>1 .and. kc>nmodes .and. c1>c1_thresh - else - cn(i,j,:) = 0.0 endif ! if more than 2 layers endif ! if drxh_sum < 0 - else - cn(i,j,:) = 0.0 ! This is a land point. endif ! if not land enddo ! i-loop enddo ! j-loop @@ -1221,47 +1196,50 @@ end subroutine wave_speeds !! with lam, where lam is constant across rows. Only the ratio of det to its derivative and their !! signs are typically used, so internal rescaling by consistent factors are used to avoid !! over- or underflow. -subroutine tridiag_det(a, b, c, nrows, lam, det_out, ddet_out, row_scale) - real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry = 0) - real, dimension(:), intent(in) :: b !< Leading diagonal of matrix (excluding lam) - real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry = 0) +subroutine tridiag_det(a, b, c, nrows, lam, det, ddet, row_scale) + real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry unused) + real, dimension(:), intent(in) :: b !< Leading diagonal of matrix (excluding lam) + real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry unused) integer, intent(in) :: nrows !< Size of matrix - real, intent(in) :: lam !< Value subtracted from b - real, intent(out):: det_out !< Determinant - real, intent(out):: ddet_out !< Derivative of determinant w.r.t. lam + real, intent(in) :: lam !< Value subtracted from b + real, intent(out):: det !< Determinant + real, intent(out):: ddet !< Derivative of determinant with lam real, optional, intent(in) :: row_scale !< A scaling factor of the rows of the !! matrix to limit the growth of the determinant ! Local variables - real, dimension(nrows) :: det ! value of recursion function - real, dimension(nrows) :: ddet ! value of recursion function for derivative + real :: detKm1, detKm2 ! Cumulative value of the determinant for the previous two layers. + real :: ddetKm1, ddetKm2 ! Derivative of the cumulative determinant with lam for the previous two layers. real, parameter :: rescale = 1024.0**4 ! max value of determinant allowed before rescaling - real :: rscl + real :: rscl ! A rescaling factor that is applied succesively to each row. real :: I_rescale ! inverse of rescale - integer :: n ! row (layer interface) index + integer :: k ! row (layer interface) index if (size(b) /= nrows) call MOM_error(WARNING, "Diagonal b must be same length as nrows.") if (size(a) /= nrows) call MOM_error(WARNING, "Diagonal a must be same length as nrows.") if (size(c) /= nrows) call MOM_error(WARNING, "Diagonal c must be same length as nrows.") - I_rescale = 1.0/rescale + I_rescale = 1.0 / rescale rscl = 1.0 ; if (present(row_scale)) rscl = row_scale - det(1) = 1.0 ; ddet(1) = 0.0 - if (nrows > 1) then ; det(2) = b(2)-lam ; ddet(2) = -1.0 ; endif - do n=3,nrows - det(n) = rscl*(b(n)-lam)*det(n-1) - rscl*(a(n)*c(n-1))*det(n-2) - ddet(n) = rscl*(b(n)-lam)*ddet(n-1) - rscl*(a(n)*c(n-1))*ddet(n-2) - det(n-1) - ! Rescale det & ddet if det is getting too large or too small to avoid overflow or underflow. - if (abs(det(n)) > rescale) then - det(n) = I_rescale*det(n) ; det(n-1) = I_rescale*det(n-1) - ddet(n) = I_rescale*ddet(n) ; ddet(n-1) = I_rescale*ddet(n-1) - elseif (abs(det(n)) < I_rescale) then - det(n) = rescale*det(n) ; det(n-1) = rescale*det(n-1) - ddet(n) = rescale*ddet(n) ; ddet(n-1) = rescale*ddet(n-1) + detKm1 = 1.0 ; ddetKm1 = 0.0 + det = (b(1) - lam) ; ddet = -1.0 + do k=2,nrows + ! Shift variables and rescale rows to avoid over- or underflow. + detKm2 = row_scale*detKm1 ; ddetKm2 = row_scale*ddetKm1 + detKm1 = row_scale*det ; ddetKm1 = row_scale*ddet + + det = (b(k)-lam)*detKm1 - (a(k)*c(k-1))*detKm2 + ddet = (b(k)-lam)*ddetKm1 - (a(k)*c(k-1))*ddetKm2 - detKm1 + + ! Rescale det & ddet if det is getting too large or too small. + if (abs(det) > rescale) then + det = I_rescale*det ; detKm1 = I_rescale*detKm1 + ddet = I_rescale*ddet ; ddetKm1 = I_rescale*ddetKm1 + elseif (abs(det) < I_rescale) then + det = rescale*det ; detKm1 = rescale*detKm1 + ddet = rescale*ddet ; ddetKm1 = rescale*ddetKm1 endif enddo - det_out = det(nrows) - ddet_out = ddet(nrows) / rscl end subroutine tridiag_det diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 7c24b774b3..8f3aef32c9 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -352,7 +352,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif ! associated(tv%T) .AND. associated(tv%frazil) if (CS%debugConservation) call MOM_state_stats('1st make_frazil', u, v, h, tv%T, tv%S, G, GV, US) - if (CS%use_int_tides) then ! This block provides an interface for the unresolved low-mode internal tide module (BDM). call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, US, & @@ -3379,13 +3378,13 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (CS%use_int_tides) then CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & - Time, 'First baroclinic mode (eigen) speed', 'm s-1') + Time, 'First baroclinic mode (eigen) speed', 'm s-1', conversion=US%L_T_to_m_s) allocate(CS%id_cn(CS%nMode)) ; CS%id_cn(:) = -1 do m=1,CS%nMode write(var_name, '("cn_mode",i1)') m write(var_descript, '("Baroclinic (eigen) speed of mode ",i1)') m CS%id_cn(m) = register_diag_field('ocean_model',var_name, diag%axesT1, & - Time, var_descript, 'm s-1') + Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) enddo endif From 74614b5887cd984a760a5fd916775d66e47942d2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 18 Aug 2020 12:08:07 -0400 Subject: [PATCH 062/103] Use similar routines in wave_speed and wave_speeds Revised both wave_speed and wave_speeds to use the same tridiag_det routine to estimate the determinant and its derivative for their Newton's method solver, making it more obvious where these two functions are using the same techniques. In turn, tridiag_deg was modified to take arguments that exploit the fact that only the upper and lower diagonals plus the candidate eigenvalue are needed in the specific case used here, avoiding the need for extra arrays and array copies. The internal routine tdma6 was also modified to expand similar expressions relating the center, upper and lower diagonals, and switching the sign convention in the diagonal arguments to avoid extra copies. All answers are bitwise identical. --- src/diagnostics/MOM_wave_speed.F90 | 152 +++++++++-------------------- 1 file changed, 47 insertions(+), 105 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 00a5c1f4a8..8b50fe1acb 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -94,9 +94,8 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ H_bot, & ! The distance of each filtered interface from the bottom [Z ~> m] gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. real, dimension(SZK_(G)) :: & - Igl, Igu, Igd ! The inverse of the reduced gravity across an interface times - ! the thickness of the layer below (Igl) or above (Igu) it. - ! Their sum, Igd, is provided for the tridiagonal solver. [T2 L-2 ~> s2 m-2] + Igl, Igu ! The inverse of the reduced gravity across an interface times + ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. real, dimension(SZK_(G),SZI_(G)) :: & Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [degC] @@ -211,7 +210,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ !$OMP private(htot,hmin,kf,H_here,HxT_here,HxS_here,HxR_here, & !$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT,drho_dS, & !$OMP drxh_sum,kc,Hc,Hc_H,tC,sc,I_Hnew,gprime,& -!$OMP Rc,speed2_tot,Igl,Igu,Igd,lam0,lam,lam_it,dlam, & +!$OMP Rc,speed2_tot,Igl,Igu,lam0,lam,lam_it,dlam, & !$OMP mode_struct,sum_hc,N2min,gp,hw, & !$OMP ms_min,ms_max,ms_sq,H_top,H_bot,I_Htot,merge, & !$OMP det,ddet,detKm1,ddetKm1,detKm2,ddetKm2,det_it,ddet_it) @@ -493,57 +492,27 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ do itt=1,max_itt lam_it(itt) = lam if (l_use_ebt_mode) then - ! This initialization of det,ddet imply Neumann boundary conditions so that first 3 rows - ! of the matrix are + ! This initialization of det,ddet imply Neumann boundary conditions for horizontal + ! velocity or pressure modes, so that first 3 rows of the matrix are ! / b(1)-lam igl(1) 0 0 0 ... \ ! | igu(2) b(2)-lam igl(2) 0 0 ... | ! | 0 igu(3) b(3)-lam igl(3) 0 ... | - ! which is consistent if the eigenvalue problem is for horizontal velocity or pressure modes. - !detKm1 = c2_scale*(Igl(1)-lam) ; ddetKm1 = -1.0*c2_scale - !det = (Igu(2)+Igl(2)-lam)*detKm1 - (Igu(2)*Igl(1)) ; ddet = (Igu(2)+Igl(2)-lam)*ddetKm1 - detKm1 - detKm1 = 1.0 ; ddetKm1 = 0.0 - det = (Igl(1)-lam) ; ddet = -1.0 - if (kc>1) then - ! Shift variables and rescale rows to avoid over- or underflow. - detKm2 = c2_scale*detKm1 ; ddetKm2 = c2_scale*ddetKm1 - detKm1 = c2_scale*det ; ddetKm1 = c2_scale*ddet - det = (Igu(2)+Igl(2)-lam)*detKm1 - (Igu(2)*Igl(1))*detKm2 - ddet = (Igu(2)+Igl(2)-lam)*ddetKm1 - (Igu(2)*Igl(1))*ddetKm2 - detKm1 - endif ! The last two rows of the pressure equation matrix are ! | ... 0 igu(kc-1) b(kc-1)-lam igl(kc-1) | ! \ ... 0 0 igu(kc) b(kc)-lam / + call tridiag_det(Igu, Igl, 1, kc, lam, det, ddet, row_scale=c2_scale) else - ! This initialization of det,ddet imply Dirichlet boundary conditions so that first 3 rows - ! of the matrix are + ! This initialization of det,ddet imply Dirichlet boundary conditions for vertical + ! velocity modes, so that first 3 rows of the matrix are ! / b(2)-lam igl(2) 0 0 0 ... | ! | igu(3) b(3)-lam igl(3) 0 0 ... | ! | 0 igu(4) b(4)-lam igl(4) 0 ... | - ! which is consistent if the eigenvalue problem is for vertical velocity modes. - detKm1 = 1.0 ; ddetKm1 = 0.0 - det = (Igu(2) + Igl(2) - lam) ; ddet = -1.0 ! The last three rows of the w equation matrix are - ! | ... 0 igu(kc-1) b(kc-1)-lam igl(kc-1) 0 | + ! | ... 0 igu(kc-2) b(kc-2)-lam igl(kc-2) 0 | ! | ... 0 0 igu(kc-1) b(kc-1)-lam igl(kc-1) | ! \ ... 0 0 0 igu(kc) b(kc)-lam / + call tridiag_det(Igu, Igl, 2, kc, lam, det, ddet, row_scale=c2_scale) endif - do k=3,kc - ! Shift variables and rescale rows to avoid over- or underflow. - detKm2 = c2_scale*detKm1 ; ddetKm2 = c2_scale*ddetKm1 - detKm1 = c2_scale*det ; ddetKm1 = c2_scale*ddet - - det = (Igu(k)+Igl(k)-lam)*detKm1 - (Igu(k)*Igl(k-1))*detKm2 - ddet = (Igu(k)+Igl(k)-lam)*ddetKm1 - (Igu(k)*Igl(k-1))*ddetKm2 - detKm1 - - ! Rescale det & ddet if det is getting too large or too small. - if (abs(det) > rescale) then - det = I_rescale*det ; detKm1 = I_rescale*detKm1 - ddet = I_rescale*ddet ; ddetKm1 = I_rescale*ddetKm1 - elseif (abs(det) < I_rescale) then - det = rescale*det ; detKm1 = rescale*detKm1 - ddet = rescale*ddet ; ddetKm1 = rescale*ddetKm1 - endif - enddo ! Use Newton's method iteration to find a new estimate of lam. det_it(itt) = det ; ddet_it(itt) = ddet @@ -559,10 +528,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ endif if (calc_modal_structure) then - do k = 1,kc - Igd(k) = Igu(k) + Igl(k) - enddo - call tdma6(kc, -Igu, Igd, -Igl, lam, mode_struct) + call tdma6(kc, Igu, Igl, lam, mode_struct) ms_min = mode_struct(1) ms_max = mode_struct(1) ms_sq = mode_struct(1)**2 @@ -620,51 +586,54 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ end subroutine wave_speed -!> Solve a non-symmetric tridiagonal problem with a scalar contribution to the leading diagonal. +!> Solve a non-symmetric tridiagonal problem with the sum of the upper and lower diagnonals minus a +!! scalar contribution as the leading diagonal. !! This uses the Thomas algorithm rather than the Hallberg algorithm since the matrix is not symmetric. -subroutine tdma6(n, a, b, c, lam, y) +subroutine tdma6(n, a, c, lam, y) integer, intent(in) :: n !< Number of rows of matrix - real, dimension(n), intent(in) :: a !< Lower diagonal [T2 L-2 ~> s2 m-2] - real, dimension(n), intent(in) :: b !< Leading diagonal [T2 L-2 ~> s2 m-2] - real, dimension(n), intent(in) :: c !< Upper diagonal [T2 L-2 ~> s2 m-2] + real, dimension(:), intent(in) :: a !< Lower diagonal [T2 L-2 ~> s2 m-2] + real, dimension(:), intent(in) :: c !< Upper diagonal [T2 L-2 ~> s2 m-2] real, intent(in) :: lam !< Scalar subtracted from leading diagonal [T2 L-2 ~> s2 m-2] - real, dimension(n), intent(inout) :: y !< RHS on entry, result on exit + real, dimension(:), intent(inout) :: y !< RHS on entry, result on exit + ! Local variables - integer :: k, l - real :: beta(n), lambda ! Temporary variables in [T2 L-2 ~> s2 m-2] - real :: I_beta(n) ! Temporary variables in [L2 T-2 ~> m2 s-2] - real :: yy(n) ! A temporary variable with the same units as y on entry. + real :: lambda ! A temporary variable in [T2 L-2 ~> s2 m-2] + real :: beta(n) ! A temporary variable in [T2 L-2 ~> s2 m-2] + real :: I_beta(n) ! A temporary variable in [L2 T-2 ~> m2 s-2] + real :: yy(n) ! A temporary variable with the same units as y on entry. + integer :: k, m lambda = lam - beta(1) = b(1) - lambda + beta(1) = (a(1)+c(1)) - lambda if (beta(1)==0.) then ! lam was chosen too perfectly ! Change lambda and redo this first row lambda = (1. + 1.e-5) * lambda - beta(1) = b(1) - lambda + beta(1) = (a(1)+c(1)) - lambda endif I_beta(1) = 1. / beta(1) yy(1) = y(1) do k = 2, n - beta(k) = ( b(k) - lambda ) - a(k) * c(k-1) * I_beta(k-1) + beta(k) = ( (a(k)+c(k)) - lambda ) - a(k) * c(k-1) * I_beta(k-1) ! Perhaps the following 0 needs to become a tolerance to handle underflow? if (beta(k)==0.) then ! lam was chosen too perfectly ! Change lambda and redo everything up to row k lambda = (1. + 1.e-5) * lambda - I_beta(1) = 1. / ( b(1) - lambda ) - do l = 2, k - I_beta(l) = 1. / ( ( b(l) - lambda ) - a(l) * c(l-1) * I_beta(l-1) ) - yy(l) = y(l) - a(l) * yy(l-1) * I_beta(l-1) + I_beta(1) = 1. / ( (a(1)+c(1)) - lambda ) + do m = 2, k + I_beta(m) = 1. / ( ( (a(m)+c(m)) - lambda ) - a(m) * c(m-1) * I_beta(m-1) ) + yy(m) = y(m) + a(m) * yy(m-1) * I_beta(m-1) enddo else I_beta(k) = 1. / beta(k) endif - yy(k) = y(k) - a(k) * yy(k-1) * I_beta(k-1) + yy(k) = y(k) + a(k) * yy(k-1) * I_beta(k-1) enddo ! The units of y change by a factor of [L2 T-2] in the following lines. y(n) = yy(n) * I_beta(n) do k = n-1, 1, -1 - y(k) = ( yy(k) - c(k) * y(k+1) ) * I_beta(k) + y(k) = ( yy(k) + c(k) * y(k+1) ) * I_beta(k) enddo + end subroutine tdma6 !> Calculates the wave speeds for the first few barolinic modes. @@ -709,10 +678,6 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] Rc ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] - real, dimension(SZK_(G)-1) :: & - a_diag, b_diag, c_diag - ! diagonals of tridiagonal matrix; one value for each - ! interface (excluding surface and bottom) [T2 L-2 ~> s2 m-2] real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] real :: c1_thresh ! if c1 is below this value, don't bother calculating ! cn values for higher modes [L T-1 ~> m s-1] @@ -768,7 +733,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! for root finding (# intervals = 2**sub_it_max) logical :: sub_rootfound ! if true, subdivision has located root integer :: kc ! The number of layers in the column after merging - integer :: nrows, sub, sub_it + integer :: sub, sub_it integer :: i, j, k, k2, itt, is, ie, js, je, nz, row, iint, m, ig, jg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -1044,29 +1009,13 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee endif enddo - ! Define the diagonals of the tridiagonal matrix for use by tridiag_det - a_diag(1) = 0.0 - b_diag(1) = Igu(2)+Igl(2) - c_diag(1) = -Igl(2) - do k=2,kc-2 - a_diag(k) = -Igu(k+1) - b_diag(k) = Igu(k+1)+Igl(k+1) - c_diag(k) = -Igl(k+1) - enddo - a_diag(kc-1) = -Igu(kc) - b_diag(kc-1) = Igu(kc)+Igl(kc) - c_diag(kc-1) = 0.0 - ! Total number of rows in the matrix = number of interior interfaces - nrows = kc-1 - ! Under estimate the first eigenvalue (overestimate the speed) to start with. lam_1 = 1.0 / speed2_tot ! Find the first eigen value do itt=1,max_itt ! calculate the determinant of (A-lam_1*I) - call tridiag_det(a_diag(1:nrows), b_diag(1:nrows), c_diag(1:nrows), & - nrows, lam_1, det, ddet, row_scale=c2_scale) + call tridiag_det(Igu, Igl, 2, kc, lam_1, det, ddet, row_scale=c2_scale) ! If possible, use Newton's method iteration to find a new estimate of lam_1 !det = det_it(itt) ; ddet = ddet_it(itt) @@ -1103,14 +1052,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! that are beyond the first root ! find det_l of first interval (det at left endpoint) - call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lamMin,det_l,ddet_l, row_scale=c2_scale) + call tridiag_det(Igu, Igl, 2, kc, lamMin, det_l, ddet_l, row_scale=c2_scale) ! move interval window looking for zero-crossings************************ do iint=1,numint xr = lamMin + lamInc * iint xl = xr - lamInc - call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,xr,det_r,ddet_r, row_scale=c2_scale) + call tridiag_det(Igu, Igl, 2, kc, xr, det_r, ddet_r, row_scale=c2_scale) if (det_l*det_r < 0.0) then ! if function changes sign if (det_l*ddet_l < 0.0) then ! if function at left is headed to zero nrootsfound = nrootsfound + 1 @@ -1130,8 +1077,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee ! loop over each subinterval: do sub=1,nsub-1,2 ! only check odds; sub = 1; 1,3; 1,3,5,7;... xl_sub = xl + lamInc/(nsub)*sub - call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,xl_sub,det_sub,ddet_sub, row_scale=c2_scale) + call tridiag_det(Igu, Igl, 2, kc, xl_sub, det_sub, ddet_sub, & + row_scale=c2_scale) if (det_sub*det_r < 0.0) then ! if function changes sign if (det_sub*ddet_sub < 0.0) then ! if function at left is headed to zero sub_rootfound = .true. @@ -1173,8 +1120,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee lam_n = xbl(m) ! first guess is left edge of window do itt=1,max_itt ! calculate the determinant of (A-lam_n*I) - call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lam_n,det,ddet, row_scale=c2_scale) + call tridiag_det(Igu, Igl, 2, kc, lam_n, det, ddet, row_scale=c2_scale) ! Use Newton's method to find a new estimate of lam_n dlam = - det / ddet lam_n = lam_n + dlam @@ -1196,11 +1142,11 @@ end subroutine wave_speeds !! with lam, where lam is constant across rows. Only the ratio of det to its derivative and their !! signs are typically used, so internal rescaling by consistent factors are used to avoid !! over- or underflow. -subroutine tridiag_det(a, b, c, nrows, lam, det, ddet, row_scale) +subroutine tridiag_det(a, c, ks, ke, lam, det, ddet, row_scale) real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry unused) - real, dimension(:), intent(in) :: b !< Leading diagonal of matrix (excluding lam) real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry unused) - integer, intent(in) :: nrows !< Size of matrix + integer, intent(in) :: ks !< Starting index to use in determinant + integer, intent(in) :: ke !< Ending index to use in determinant real, intent(in) :: lam !< Value subtracted from b real, intent(out):: det !< Determinant real, intent(out):: ddet !< Derivative of determinant with lam @@ -1214,22 +1160,18 @@ subroutine tridiag_det(a, b, c, nrows, lam, det, ddet, row_scale) real :: I_rescale ! inverse of rescale integer :: k ! row (layer interface) index - if (size(b) /= nrows) call MOM_error(WARNING, "Diagonal b must be same length as nrows.") - if (size(a) /= nrows) call MOM_error(WARNING, "Diagonal a must be same length as nrows.") - if (size(c) /= nrows) call MOM_error(WARNING, "Diagonal c must be same length as nrows.") - I_rescale = 1.0 / rescale rscl = 1.0 ; if (present(row_scale)) rscl = row_scale detKm1 = 1.0 ; ddetKm1 = 0.0 - det = (b(1) - lam) ; ddet = -1.0 - do k=2,nrows + det = (a(ks)+c(ks)) - lam ; ddet = -1.0 + do k=ks+1,ke ! Shift variables and rescale rows to avoid over- or underflow. detKm2 = row_scale*detKm1 ; ddetKm2 = row_scale*ddetKm1 detKm1 = row_scale*det ; ddetKm1 = row_scale*ddet - det = (b(k)-lam)*detKm1 - (a(k)*c(k-1))*detKm2 - ddet = (b(k)-lam)*ddetKm1 - (a(k)*c(k-1))*ddetKm2 - detKm1 + det = ((a(k)+c(k))-lam)*detKm1 - (a(k)*c(k-1))*detKm2 + ddet = ((a(k)+c(k))-lam)*ddetKm1 - (a(k)*c(k-1))*ddetKm2 - detKm1 ! Rescale det & ddet if det is getting too large or too small. if (abs(det) > rescale) then From db74a47b0e6b3af6c75ece2c07bcee197b68dbbb Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Wed, 19 Aug 2020 14:40:59 -0400 Subject: [PATCH 063/103] fix bugs in wave_structure * inconsistent sizes in array copies * test on number of layers * allow to run without internal_tides input file --- src/diagnostics/MOM_wave_structure.F90 | 18 +++++++-------- .../lateral/MOM_internal_tides.F90 | 22 ++++++++++++------- 2 files changed, 23 insertions(+), 17 deletions(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 632a68e0ce..e2de3881ad 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -378,7 +378,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Also, note that "K" refers to an interface, while "k" refers to the layer below. ! Need at least 3 layers (2 internal interfaces) to generate a matrix, also ! need number of layers to be greater than the mode number - if (kc >= ModeNum + 1) then + if (kc > ModeNum + 1) then ! Set depth at surface z_int(1) = 0.0 ! Calculate Igu, Igl, depth, and N2 at each interior interface @@ -485,8 +485,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Calculate terms in vertically integrated energy equation int_dwdz2 = 0.0 ; int_w2 = 0.0 ; int_N2w2 = 0.0 - u_strct2(:) = u_strct(1:nzm)**2 - w_strct2(:) = w_strct(1:nzm)**2 + u_strct2(1:nzm) = u_strct(1:nzm)**2 + w_strct2(1:nzm) = w_strct(1:nzm)**2 ! vertical integration with Trapezoidal rule do k=1,nzm-1 int_dwdz2 = int_dwdz2 + 0.5*(u_strct2(K)+u_strct2(K+1)) * US%m_to_Z*dz(k) @@ -518,12 +518,12 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo endif ! Store values in control structure - CS%w_strct(i,j,1:nzm) = w_strct(:) - CS%u_strct(i,j,1:nzm) = u_strct(:) - CS%W_profile(i,j,1:nzm) = W_profile(:) - CS%Uavg_profile(i,j,1:nzm)= Uavg_profile(:) - CS%z_depths(i,j,1:nzm) = US%Z_to_m*z_int(:) - CS%N2(i,j,1:nzm) = N2(:) + CS%w_strct(i,j,1:nzm) = w_strct(1:nzm) + CS%u_strct(i,j,1:nzm) = u_strct(1:nzm) + CS%W_profile(i,j,1:nzm) = W_profile(1:nzm) + CS%Uavg_profile(i,j,1:nzm)= Uavg_profile(1:nzm) + CS%z_depths(i,j,1:nzm) = US%Z_to_m*z_int(1:nzm) + CS%N2(i,j,1:nzm) = N2(1:nzm) CS%num_intfaces(i,j) = nzm else ! If not enough layers, default to zero diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index a0f1631d6d..c327d1cece 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -15,7 +15,7 @@ module MOM_internal_tides use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, vardesc, MOM_read_data +use MOM_io, only : slasher, vardesc, MOM_read_data, file_exists use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_spatial_means, only : global_area_mean use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) @@ -2324,12 +2324,14 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "REFL_ANGLE_FILE", refl_angle_file, & "The path to the file containing the local angle of "//& "the coastline/ridge/shelf with respect to the equator.", & - fail_if_missing=.false.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_angle_file) call log_param(param_file, mdl, "INPUTDIR/REFL_ANGLE_FILE", filename) allocate(CS%refl_angle(isd:ied,jsd:jed)) ; CS%refl_angle(:,:) = CS%nullangle - call MOM_read_data(filename, 'refl_angle', CS%refl_angle, & - G%domain, timelevel=1) + if (file_exists(filename, G%domain)) then + call MOM_read_data(filename, 'refl_angle', CS%refl_angle, & + G%domain, timelevel=1) + endif ! replace NANs with null value do j=G%jsc,G%jec ; do i=G%isc,G%iec if (is_NaN(CS%refl_angle(i,j))) CS%refl_angle(i,j) = CS%nullangle @@ -2339,11 +2341,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Read in prescribed partial reflection coefficients from file call get_param(param_file, mdl, "REFL_PREF_FILE", refl_pref_file, & "The path to the file containing the reflection coefficients.", & - fail_if_missing=.false.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_pref_file) call log_param(param_file, mdl, "INPUTDIR/REFL_PREF_FILE", filename) allocate(CS%refl_pref(isd:ied,jsd:jed)) ; CS%refl_pref(:,:) = 1.0 - call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain, timelevel=1) + if (file_exists(filename, G%domain)) then + call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain, timelevel=1) + endif !CS%refl_pref = CS%refl_pref*1 ! adjust partial reflection if desired call pass_var(CS%refl_pref,G%domain) @@ -2362,11 +2366,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Read in double-reflective (ridge) tags from file call get_param(param_file, mdl, "REFL_DBL_FILE", refl_dbl_file, & "The path to the file containing the double-reflective ridge tags.", & - fail_if_missing=.false.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_dbl_file) call log_param(param_file, mdl, "INPUTDIR/REFL_DBL_FILE", filename) allocate(ridge_temp(isd:ied,jsd:jed)) ; ridge_temp(:,:) = 0.0 - call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain, timelevel=1) + if (file_exists(filename, G%domain)) then + call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain, timelevel=1) + endif call pass_var(ridge_temp,G%domain) allocate(CS%refl_dbl(isd:ied,jsd:jed)) ; CS%refl_dbl(:,:) = .false. do i=isd,ied; do j=jsd,jed From 7a0dc2a056ed6aa230ce741f7bfbd6f5ec1c642d Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Wed, 19 Aug 2020 14:40:59 -0400 Subject: [PATCH 064/103] fix bugs in wave_structure * inconsistent sizes in array copies * test on number of layers * allow to run without internal_tides input file --- src/diagnostics/MOM_wave_structure.F90 | 18 +++++++-------- .../lateral/MOM_internal_tides.F90 | 22 ++++++++++++------- 2 files changed, 23 insertions(+), 17 deletions(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 632a68e0ce..88b062472f 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -378,7 +378,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Also, note that "K" refers to an interface, while "k" refers to the layer below. ! Need at least 3 layers (2 internal interfaces) to generate a matrix, also ! need number of layers to be greater than the mode number - if (kc >= ModeNum + 1) then + if (kc >= max(3, ModeNum + 1)) then ! Set depth at surface z_int(1) = 0.0 ! Calculate Igu, Igl, depth, and N2 at each interior interface @@ -485,8 +485,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Calculate terms in vertically integrated energy equation int_dwdz2 = 0.0 ; int_w2 = 0.0 ; int_N2w2 = 0.0 - u_strct2(:) = u_strct(1:nzm)**2 - w_strct2(:) = w_strct(1:nzm)**2 + u_strct2(1:nzm) = u_strct(1:nzm)**2 + w_strct2(1:nzm) = w_strct(1:nzm)**2 ! vertical integration with Trapezoidal rule do k=1,nzm-1 int_dwdz2 = int_dwdz2 + 0.5*(u_strct2(K)+u_strct2(K+1)) * US%m_to_Z*dz(k) @@ -518,12 +518,12 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo endif ! Store values in control structure - CS%w_strct(i,j,1:nzm) = w_strct(:) - CS%u_strct(i,j,1:nzm) = u_strct(:) - CS%W_profile(i,j,1:nzm) = W_profile(:) - CS%Uavg_profile(i,j,1:nzm)= Uavg_profile(:) - CS%z_depths(i,j,1:nzm) = US%Z_to_m*z_int(:) - CS%N2(i,j,1:nzm) = N2(:) + CS%w_strct(i,j,1:nzm) = w_strct(1:nzm) + CS%u_strct(i,j,1:nzm) = u_strct(1:nzm) + CS%W_profile(i,j,1:nzm) = W_profile(1:nzm) + CS%Uavg_profile(i,j,1:nzm)= Uavg_profile(1:nzm) + CS%z_depths(i,j,1:nzm) = US%Z_to_m*z_int(1:nzm) + CS%N2(i,j,1:nzm) = N2(1:nzm) CS%num_intfaces(i,j) = nzm else ! If not enough layers, default to zero diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index a0f1631d6d..c327d1cece 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -15,7 +15,7 @@ module MOM_internal_tides use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, vardesc, MOM_read_data +use MOM_io, only : slasher, vardesc, MOM_read_data, file_exists use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_spatial_means, only : global_area_mean use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) @@ -2324,12 +2324,14 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "REFL_ANGLE_FILE", refl_angle_file, & "The path to the file containing the local angle of "//& "the coastline/ridge/shelf with respect to the equator.", & - fail_if_missing=.false.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_angle_file) call log_param(param_file, mdl, "INPUTDIR/REFL_ANGLE_FILE", filename) allocate(CS%refl_angle(isd:ied,jsd:jed)) ; CS%refl_angle(:,:) = CS%nullangle - call MOM_read_data(filename, 'refl_angle', CS%refl_angle, & - G%domain, timelevel=1) + if (file_exists(filename, G%domain)) then + call MOM_read_data(filename, 'refl_angle', CS%refl_angle, & + G%domain, timelevel=1) + endif ! replace NANs with null value do j=G%jsc,G%jec ; do i=G%isc,G%iec if (is_NaN(CS%refl_angle(i,j))) CS%refl_angle(i,j) = CS%nullangle @@ -2339,11 +2341,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Read in prescribed partial reflection coefficients from file call get_param(param_file, mdl, "REFL_PREF_FILE", refl_pref_file, & "The path to the file containing the reflection coefficients.", & - fail_if_missing=.false.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_pref_file) call log_param(param_file, mdl, "INPUTDIR/REFL_PREF_FILE", filename) allocate(CS%refl_pref(isd:ied,jsd:jed)) ; CS%refl_pref(:,:) = 1.0 - call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain, timelevel=1) + if (file_exists(filename, G%domain)) then + call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain, timelevel=1) + endif !CS%refl_pref = CS%refl_pref*1 ! adjust partial reflection if desired call pass_var(CS%refl_pref,G%domain) @@ -2362,11 +2366,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Read in double-reflective (ridge) tags from file call get_param(param_file, mdl, "REFL_DBL_FILE", refl_dbl_file, & "The path to the file containing the double-reflective ridge tags.", & - fail_if_missing=.false.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_dbl_file) call log_param(param_file, mdl, "INPUTDIR/REFL_DBL_FILE", filename) allocate(ridge_temp(isd:ied,jsd:jed)) ; ridge_temp(:,:) = 0.0 - call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain, timelevel=1) + if (file_exists(filename, G%domain)) then + call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain, timelevel=1) + endif call pass_var(ridge_temp,G%domain) allocate(CS%refl_dbl(isd:ied,jsd:jed)) ; CS%refl_dbl(:,:) = .false. do i=isd,ied; do j=jsd,jed From e8b5d96bcb769b79f68a671e35f4f02940d7cab5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 19 Aug 2020 18:47:35 -0400 Subject: [PATCH 065/103] *+Add halo updates needed with VERTEX_SHEAR=True Made a set of changes to add halo updates that are needed to reproduce answers across PE layouts or for reentrant cases with USE_JACKSON_PARAM=True and VERTEX_SHEAR=True. The changes include: 1. Add halo updates for T & S after advection if needed. 2. Add new optional argument to extract_diabatic_member to return the valid temperature, salinity, p_surf and thickness halos that are required upon entry to calls to diabatic. 3. Added the new runtime parameter KAPPA_SHEAR_VERTEX_PSURF_BUG, which when set to False causes the surface pressures used in equation of state calculations in the kappa-shear code to avoid averaging any values from land points. 4. Stopped logging the debugging parameter DEBUG_KAPPA_SHEAR in a prelude to obsoleting it, as the debugging output this triggers is not so invasive as it once was (it is now a few checksums, and not extensive reporting on each column), and there is no reason why DEBUG should not trigger it, as is now the case. 4. Added chksum calls with appropriate halo sizes to check the MOM state before calls to set_diffusivity. 5. Added a haloshift=0 argument to a call to MOM_surface_chksum to avoid spuriously flagging halo regions that were not supposed to reproduce. The answers in most test cases in MOM6-examples are bitwise identical, and there are no changes to output files, but this does change answers in cases with VERTEX_SHEAR=True, including ice_ocean_SIS2/SIS2_bergs_cgrid, which was not previously reproducing across PE layouts. --- src/core/MOM.F90 | 41 ++++++++++++++----- .../vertical/MOM_diabatic_driver.F90 | 15 +++++-- .../vertical/MOM_kappa_shear.F90 | 35 ++++++++++++---- 3 files changed, 69 insertions(+), 22 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a9b9c7fec4..3f60299b6b 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -57,7 +57,7 @@ module MOM use MOM_barotropic, only : Barotropic_CS use MOM_boundary_update, only : call_OBC_register, OBC_register_end, update_OBC_CS use MOM_coord_initialization, only : MOM_initialize_coord -use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS +use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS, extract_diabatic_member use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end use MOM_diagnostics, only : calculate_diagnostic_fields, MOM_diagnostics_init use MOM_diagnostics, only : register_transport_diags, post_transport_diagnostics @@ -595,8 +595,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS dt_therm = dt ; ntstep = 1 if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf CS%tv%p_surf => NULL() - if (CS%use_p_surf_in_EOS .and. associated(forces%p_surf)) CS%tv%p_surf => fluxes%p_surf - + if (associated(forces%p_surf)) then !### This should be fluxes%p_surf! + if (CS%use_p_surf_in_EOS) CS%tv%p_surf => fluxes%p_surf + endif if (CS%UseWaves) call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass) endif @@ -1137,6 +1138,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) type(time_type), intent(in) :: Time_local !< The model time at the end !! of the time step. type(group_pass_type) :: pass_T_S + integer :: halo_sz ! The size of a halo where data must be valid. logical :: showCallTree showCallTree = callTree_showQuery() @@ -1185,12 +1187,19 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) CS%t_dyn_rel_adv = 0.0 call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) - if (CS%diabatic_first .and. associated(CS%tv%T)) then - ! Temperature and salinity need halo updates because they will be used - ! in the dynamics before they are changed again. - call create_group_pass(pass_T_S, CS%tv%T, G%Domain, To_All+Omit_Corners, halo=1) - call create_group_pass(pass_T_S, CS%tv%S, G%Domain, To_All+Omit_Corners, halo=1) - call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) + if (associated(CS%tv%T)) then + call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + if (halo_sz > 0) then + call create_group_pass(pass_T_S, CS%tv%T, G%Domain, To_All, halo=halo_sz) + call create_group_pass(pass_T_S, CS%tv%S, G%Domain, To_All, halo=halo_sz) + call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) + elseif (CS%diabatic_first) then + ! Temperature and salinity need halo updates because they will be used + ! in the dynamics before they are changed again. + call create_group_pass(pass_T_S, CS%tv%T, G%Domain, To_All+Omit_Corners, halo=1) + call create_group_pass(pass_T_S, CS%tv%S, G%Domain, To_All+Omit_Corners, halo=1) + call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) + endif endif CS%preadv_h_stored = .false. @@ -1225,7 +1234,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & type(group_pass_type) :: pass_T_S, pass_T_S_h, pass_uv_T_S_h integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. - integer :: i, j, k, is, ie, js, je, nz! , Isq, Ieq, Jsq, Jeq, n + integer :: halo_sz ! The size of a halo where data must be valid. + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke showCallTree = callTree_showQuery() @@ -1240,6 +1250,13 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call apply_oda_tracer_increments(US%T_to_s*dtdia,G,tv,h,CS%odaCS) endif + if (associated(fluxes%p_surf)) then + call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + if (halo_sz > 0) then + call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass, halo=halo_sz) + endif + endif + if (update_BBL) then ! Calculate the BBL properties and store them inside visc (u,h). ! This is here so that CS%visc is updated before diabatic() when @@ -1278,12 +1295,14 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if ( CS%use_ALE_algorithm ) then call enable_averages(dtdia, Time_end_thermo, CS%diag) ! call pass_vector(u, v, G%Domain) + call cpu_clock_begin(id_clock_pass) if (associated(tv%T)) & call create_group_pass(pass_T_S_h, tv%T, G%Domain, To_All+Omit_Corners, halo=1) if (associated(tv%S)) & call create_group_pass(pass_T_S_h, tv%S, G%Domain, To_All+Omit_Corners, halo=1) call create_group_pass(pass_T_S_h, h, G%Domain, To_All+Omit_Corners, halo=1) call do_group_pass(pass_T_S_h, G%Domain) + call cpu_clock_end(id_clock_pass) call preAle_tracer_diagnostics(CS%tracer_Reg, G, GV) @@ -3375,7 +3394,7 @@ subroutine extract_surface_state(CS, sfc_state_in) endif endif - if (CS%debug) call MOM_surface_chksum("Post extract_sfc", sfc_state, G, US) + if (CS%debug) call MOM_surface_chksum("Post extract_sfc", sfc_state, G, US, haloshift=0) ! Rotate sfc_state back onto the input grid, sfc_state_in if (CS%rotate_index) then diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 7c24b774b3..de7d67b0ab 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -564,9 +564,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim do k=1,nz ; do j=js-halo,je+halo ; do i=is-halo,ie+halo h_orig(i,j,k) = h(i,j,k) ; eatr(i,j,k) = 0.0 ; ebtr(i,j,k) = 0.0 enddo ; enddo ; enddo - endif - if (CS%use_geothermal) then call cpu_clock_begin(id_clock_geothermal) call geothermal(h, tv, dt, eatr, ebtr, G, GV, US, CS%geothermal_CSp, halo=CS%halo_TS_diff) call cpu_clock_end(id_clock_geothermal) @@ -602,6 +600,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call cpu_clock_begin(id_clock_set_diffusivity) ! Sets: Kd_lay, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S and visc%TKE_turb ! Also changes: visc%Kd_shear, visc%Kv_shear and visc%Kv_slow + if (CS%debug) & + call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, & visc, dt, G, GV, US, CS%set_diff_CSp, Kd_lay, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) @@ -1386,6 +1386,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call cpu_clock_begin(id_clock_set_diffusivity) ! Sets: Kd_lay, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S and visc%TKE_turb ! Also changes: visc%Kd_shear, visc%Kv_shear and visc%Kv_slow + if (CS%debug) & + call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, & visc, dt, G, GV, US,CS%set_diff_CSp, Kd_lay, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) @@ -2123,6 +2125,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (associated(tv%T)) call pass_var(tv%S, G%Domain, halo=CS%halo_TS_diff, complete=.false.) call pass_var(h, G%domain, halo=CS%halo_TS_diff, complete=.true.) endif + if (CS%debug) & + call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, & visc, dt, G, GV, US, CS%set_diff_CSp, Kd_lay, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) @@ -2848,8 +2852,8 @@ end subroutine layered_diabatic !> Returns pointers or values of members within the diabatic_CS type. For extensibility, !! each returned argument is an optional argument -subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, & - minimum_forcing_depth, KPP_CSp, energetic_PBL_CSp, diabatic_aux_CSp) +subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, minimum_forcing_depth, & + KPP_CSp, energetic_PBL_CSp, diabatic_aux_CSp, diabatic_halo) type(diabatic_CS), intent(in ) :: CS !< module control structure ! All output arguments are optional type(opacity_CS), optional, pointer :: opacity_CSp !< A pointer to be set to the opacity control structure @@ -2862,6 +2866,8 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, !! and freshwater fluxes are applied [H ~> m or kg m-2]. type(diabatic_aux_CS), optional, pointer :: diabatic_aux_CSp !< A pointer to be set to the diabatic_aux !! control structure + integer, optional, intent( out) :: diabatic_halo !< The halo size where the diabatic algorithms + !! assume thermodynamics properties are valid. ! Pointers to control structures if (present(opacity_CSp)) opacity_CSp => CS%opacity_CSp @@ -2872,6 +2878,7 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, ! Constants within diabatic_CS if (present(evap_CFL_limit)) evap_CFL_limit = CS%evap_CFL_limit if (present(minimum_forcing_depth)) minimum_forcing_depth = CS%minimum_forcing_depth + if (present(diabatic_halo)) diabatic_halo = CS%halo_TS_diff end subroutine extract_diabatic_member diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 04e67f0be5..343998a1af 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -80,6 +80,9 @@ module MOM_kappa_shear !! greater than 1. The lower limit for the permitted fractional !! decrease is (1 - 0.5/kappa_src_max_chg). These limits could !! perhaps be made dynamic with an improved iterative solver. + logical :: psurf_bug !! If true, do a simple average of the cell surface pressures to get a + !! surface pressure at the corner if VERTEX_SHEAR=True. Otherwise mask + !! out any land points in the average. logical :: all_layer_TKE_bug !< If true, report back the latest estimate of TKE instead of the !! time average TKE when there is mass in all layers. Otherwise always !! report the time-averaged TKE, as is currently done when there @@ -534,9 +537,19 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo endif f2 = G%CoriolisBu(I,J)**2 - surface_pres = 0.0 ; if (associated(p_surf)) & - surface_pres = 0.25 * ((p_surf(i,j) + p_surf(i+1,j+1)) + & - (p_surf(i+1,j) + p_surf(i,j+1))) + surface_pres = 0.0 + if (associated(p_surf)) then + if (CS%psurf_bug) then + ! This is wrong because it is averaging values from land in some places. + surface_pres = 0.25 * ((p_surf(i,j) + p_surf(i+1,j+1)) + & + (p_surf(i+1,j) + p_surf(i,j+1))) + else + surface_pres = ((G%mask2dT(i,j) * p_surf(i,j) + G%mask2dT(i+1,j+1) * p_surf(i+1,j+1)) + & + (G%mask2dT(i+1,j) * p_surf(i+1,j) + G%mask2dT(i,j+1) * p_surf(i,j+1)) ) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) + endif + endif ! ---------------------------------------------------- ! Set the initial guess for kappa, here defined at interfaces. @@ -1759,6 +1772,7 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) ! Local variables logical :: merge_mixedlayer + logical :: debug_shear logical :: just_read ! If true, this module is not used, so only read the parameters. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1879,11 +1893,18 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "could perhaps be made dynamic with an improved iterative solver.", & default=10.0, units="nondim", do_not_log=just_read) - call get_param(param_file, mdl, "DEBUG_KAPPA_SHEAR", CS%debug, & - "If true, write debugging data for the kappa-shear code. \n"//& - "Caution: this option is _very_ verbose and should only "//& - "be used in single-column mode!", & + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true., do_not_log=just_read) + call get_param(param_file, mdl, "DEBUG_KAPPA_SHEAR", debug_shear, & + "If true, write debugging data for the kappa-shear code.", & + default=.false., debuggingParam=.true., do_not_log=.true.) + if (debug_shear) CS%debug = .true. + call get_param(param_file, mdl, "KAPPA_SHEAR_VERTEX_PSURF_BUG", CS%psurf_bug, & + "If true, do a simple average of the cell surface pressures to get a pressure "//& + "at the corner if VERTEX_SHEAR=True. Otherwise mask out any land points in "//& + "the average.", default=.true., do_not_log=(just_read .or. (.not.CS%KS_at_vertex))) + call get_param(param_file, mdl, "KAPPA_SHEAR_ITER_BUG", CS%dKdQ_iteration_bug, & "If true, use an older, dimensionally inconsistent estimate of the "//& "derivative of diffusivity with energy in the Newton's method iteration. "//& From 0eea62e22467fdbc3824c4cc5792709f1082d7aa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 20 Aug 2020 09:49:21 -0400 Subject: [PATCH 066/103] Fixed a dOxygen comment syntax error --- src/parameterizations/vertical/MOM_kappa_shear.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 343998a1af..3ba3d2b74c 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -80,7 +80,7 @@ module MOM_kappa_shear !! greater than 1. The lower limit for the permitted fractional !! decrease is (1 - 0.5/kappa_src_max_chg). These limits could !! perhaps be made dynamic with an improved iterative solver. - logical :: psurf_bug !! If true, do a simple average of the cell surface pressures to get a + logical :: psurf_bug !< If true, do a simple average of the cell surface pressures to get a !! surface pressure at the corner if VERTEX_SHEAR=True. Otherwise mask !! out any land points in the average. logical :: all_layer_TKE_bug !< If true, report back the latest estimate of TKE instead of the From b204203ab68a3e9e1e1a7253969bd66ecda64e20 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Thu, 20 Aug 2020 17:36:50 -0400 Subject: [PATCH 067/103] catch missing files --- .../lateral/MOM_internal_tides.F90 | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index c327d1cece..2bb3c3b0f1 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -2326,11 +2326,14 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "the coastline/ridge/shelf with respect to the equator.", & fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_angle_file) - call log_param(param_file, mdl, "INPUTDIR/REFL_ANGLE_FILE", filename) allocate(CS%refl_angle(isd:ied,jsd:jed)) ; CS%refl_angle(:,:) = CS%nullangle if (file_exists(filename, G%domain)) then + call log_param(param_file, mdl, "INPUTDIR/REFL_ANGLE_FILE", filename) call MOM_read_data(filename, 'refl_angle', CS%refl_angle, & G%domain, timelevel=1) + else + if (trim(refl_angle_file) /= '' ) call MOM_error(FATAL, & + "REFL_ANGLE_FILE: "//trim(filename)//" not found") endif ! replace NANs with null value do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -2343,10 +2346,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "The path to the file containing the reflection coefficients.", & fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_pref_file) - call log_param(param_file, mdl, "INPUTDIR/REFL_PREF_FILE", filename) allocate(CS%refl_pref(isd:ied,jsd:jed)) ; CS%refl_pref(:,:) = 1.0 if (file_exists(filename, G%domain)) then + call log_param(param_file, mdl, "INPUTDIR/REFL_PREF_FILE", filename) call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain, timelevel=1) + else + if (trim(refl_pref_file) /= '' ) call MOM_error(FATAL, & + "REFL_PREF_FILE: "//trim(filename)//" not found") endif !CS%refl_pref = CS%refl_pref*1 ! adjust partial reflection if desired call pass_var(CS%refl_pref,G%domain) @@ -2368,10 +2374,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "The path to the file containing the double-reflective ridge tags.", & fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_dbl_file) - call log_param(param_file, mdl, "INPUTDIR/REFL_DBL_FILE", filename) allocate(ridge_temp(isd:ied,jsd:jed)) ; ridge_temp(:,:) = 0.0 if (file_exists(filename, G%domain)) then + call log_param(param_file, mdl, "INPUTDIR/REFL_DBL_FILE", filename) call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain, timelevel=1) + else + if (trim(refl_dbl_file) /= '' ) call MOM_error(FATAL, & + "REFL_DBL_FILE: "//trim(filename)//" not found") endif call pass_var(ridge_temp,G%domain) allocate(CS%refl_dbl(isd:ied,jsd:jed)) ; CS%refl_dbl(:,:) = .false. From 4256a5c84cf9ae640e4d65defcd2e3fd10fbf2ed Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 21 Aug 2020 16:52:33 -0400 Subject: [PATCH 068/103] Fix epipycnal pairing array size declarations Corrected the size of 4 arrays used to describe layer pairings in tracer_epipycnal_ML_diff, to avoid the possibility of segmentation faults when there are very few interior layers compared with the number of mixed and buffer layers. Also corrected a number of spelling errors in comments. In runs that previously worked, all answers should be bitwise identical, and they are identical in all MOM6-examples test cases. --- src/tracer/MOM_tracer_hor_diff.F90 | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 02255d9424..53ed8881e3 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -36,7 +36,7 @@ module MOM_tracer_hor_diff public tracer_hordiff, tracer_hor_diff_init, tracer_hor_diff_end -!> The ocntrol structure for along-layer and epineutral tracer diffusion +!> The control structure for along-layer and epineutral tracer diffusion type, public :: tracer_hor_diff_CS ; private real :: KhTr !< The along-isopycnal tracer diffusivity [L2 T-1 ~> m2 s-1]. real :: KhTr_Slope_Cff !< The non-dimensional coefficient in KhTr formula [nondim] @@ -122,7 +122,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online !! for epipycnal mixing between mixed layer and the interior. ! Optional inputs for offline tracer transport logical, optional, intent(in) :: do_online_flag !< If present and true, do online - !! tracer transport with stored velcities. + !! tracer transport with stored velocities. real, dimension(SZIB_(G),SZJ_(G)), & optional, intent(in) :: read_khdt_x !< If present, these are the zonal !! diffusivities from previous run. @@ -609,7 +609,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & real, dimension(SZI_(G), SZJ_(G), max(1,GV%nk_rho_varies)) :: & rho_coord ! The coordinate density that is used to mix along [R ~> kg m-3]. - ! The naming mnemnonic is a=above,b=below,L=Left,R=Right,u=u-point,v=v-point. + ! The naming mnemonic is a=above,b=below,L=Left,R=Right,u=u-point,v=v-point. ! These are 1-D arrays of pointers to 2-d arrays to minimize memory usage. type(p2d), dimension(SZJ_(G)) :: & deep_wt_Lu, deep_wt_Ru, & ! The relative weighting of the deeper of a pair [nondim]. @@ -644,10 +644,6 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & h_used_R, & ! have actually been used [H ~> m or kg m-2]. h_supply_frac_L, & ! The fraction of the demanded thickness that can h_supply_frac_R ! actually be supplied from a layer. - integer, dimension(SZK_(G)) :: & - kbs_Lp, & ! The sorted indicies of the Left and Right columns for - kbs_Rp ! each pairing. - integer, dimension(SZI_(G), SZJ_(G)) :: & num_srt, & ! The number of layers that are sorted in each column. k_end_srt, & ! The maximum index in each column that might need to be @@ -677,9 +673,16 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & real :: h_L, h_R ! Thicknesses to the left and right [H ~> m or kg m-2]. real :: wt_a, wt_b ! Fractional weights of layers above and below [nondim]. real :: vol ! A cell volume or mass [H L2 ~> m3 or kg]. - logical, dimension(SZK_(G)) :: & + + ! The total number of pairings is usually much less than twice the number of layers, but + ! the memory in these 1-d columns of pairings can be allocated generously for safety. + integer, dimension(SZK_(G)*2) :: & + kbs_Lp, & ! The sorted indices of the Left and Right columns for + kbs_Rp ! each pairing. + logical, dimension(SZK_(G)*2) :: & left_set, & ! If true, the left or right point determines the density of right_set ! of the trio. If densities are exactly equal, both are true. + real :: tmp real :: p_ref_cv(SZI_(G)) ! The reference pressure for the coordinate density [R L2 T-2 ~> Pa] @@ -1186,8 +1189,8 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! Ensure that the tracer flux does not drive the tracer values ! outside of the range Tr_min_face <= Tr <= Tr_max_face, or if it - ! does that the concentration in both contributing peices exceed - ! this range equally. With downgradient fluxes and the initial tracer + ! does that the concentration in both contributing pieces exceed + ! this range equally. With down-gradient fluxes and the initial tracer ! concentrations determining the valid range, the latter condition ! only enters for large values of the effective diffusive CFL number. if (Tr_flux > 0.0) then @@ -1221,8 +1224,8 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! Ensure that the tracer flux does not drive the tracer values ! outside of the range Tr_min_face <= Tr <= Tr_max_face, or if it - ! does that the concentration in both contributing peices exceed - ! this range equally. With downgradient fluxes and the initial tracer + ! does that the concentration in both contributing pieces exceed + ! this range equally. With down-gradient fluxes and the initial tracer ! concentrations determining the valid range, the latter condition ! only enters for large values of the effective diffusive CFL number. if (Tr_flux < 0.0) then From c830ff5a4e2c09239c37569ef1d62235e5f2f02e Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Fri, 21 Aug 2020 18:42:21 -0400 Subject: [PATCH 069/103] In register_diag_field for some 2D diagnostics, changed to diag%axesCu1, diag%axesCv1 --- src/core/MOM_CoriolisAdv.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index cf274d32a9..c969a75313 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -1193,7 +1193,7 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) !endif - CS%id_hf_gKEu_2d = register_diag_field('ocean_model', 'hf_gKEu_2d', diag%axesCuL, Time, & + CS%id_hf_gKEu_2d = register_diag_field('ocean_model', 'hf_gKEu_2d', diag%axesCu1, Time, & 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & 'm-1 s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_gKEu_2d > 0) then @@ -1201,7 +1201,7 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) endif - CS%id_hf_gKEv_2d = register_diag_field('ocean_model', 'hf_gKEv_2d', diag%axesCvL, Time, & + CS%id_hf_gKEv_2d = register_diag_field('ocean_model', 'hf_gKEv_2d', diag%axesCv1, Time, & 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & 'm-1 s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_gKEv_2d > 0) then @@ -1225,7 +1225,7 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) ! call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) !endif - CS%id_hf_rvxu_2d = register_diag_field('ocean_model', 'hf_rvxu_2d', diag%axesCvL, Time, & + CS%id_hf_rvxu_2d = register_diag_field('ocean_model', 'hf_rvxu_2d', diag%axesCv1, Time, & 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & 'm-1 s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_rvxu_2d > 0) then @@ -1233,7 +1233,7 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) endif - CS%id_hf_rvxv_2d = register_diag_field('ocean_model', 'hf_rvxv_2d', diag%axesCuL, Time, & + CS%id_hf_rvxv_2d = register_diag_field('ocean_model', 'hf_rvxv_2d', diag%axesCu1, Time, & 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & 'm-1 s-2', conversion=US%L_T2_to_m_s2) if (CS%id_hf_rvxv_2d > 0) then From 17936f3fd20dbc6725b9f0992933fc31ea3a5079 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 24 Aug 2020 10:01:39 -0600 Subject: [PATCH 070/103] Add modifications suggested by Bob Hallberg * Fix grid metrics * Fix averaging expression to get the kinetic energy at a vorticity point * Fix loop ranges --- .../lateral/MOM_hor_visc.F90 | 21 ++++++++++--------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index a60d60bb9d..2edafa0f27 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -515,7 +515,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo ! Components for the shearing strain - do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 dvdx(I,J) = CS%DY_dxBu(I,J)*(v(i+1,J,k)*G%IdyCv(i+1,J) - v(i,J,k)*G%IdyCv(i,J)) dudy(I,J) = CS%DX_dyBu(I,J)*(u(I,j+1,k)*G%IdxCu(I,j+1) - u(I,j,k)*G%IdxCu(I,j)) enddo ; enddo @@ -694,11 +694,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Vorticity if (CS%no_slip) then - do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) enddo ; enddo else - do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) enddo ; enddo endif @@ -711,22 +711,23 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then ! Vorticity gradient - do J=js-2,Jeq+2 ; do i=is-1,Ieq+2 + do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) vort_xy_dx(i,J) = DY_dxBu * (vort_xy(I,J) * G%IdyCu(I,j) - vort_xy(I-1,J) * G%IdyCu(I-1,j)) enddo ; enddo - do j=js-1,Jeq+2 ; do I=is-2,Ieq+2 + do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) vort_xy_dy(I,j) = DX_dyBu * (vort_xy(I,J) * G%IdxCv(i,J) - vort_xy(I,J-1) * G%IdxCv(i,J-1)) enddo ; enddo ! Laplacian of vorticity do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 - DY_dxCv = G%dyCv(i,J) * G%IdxCv(i,J) - DX_dyCu = G%dyCu(I,j) * G%IdyCu(I,j) - Del2vort_q(I,J) = DY_dxCv * (vort_xy_dx(i+1,J) * G%IdyT(i+1,j) - vort_xy_dx(i,J) * G%IdyT(i,j)) + & - DX_dyCu * (vort_xy_dy(I,j+1) * G%IdyT(i,j+1) - vort_xy_dy(I,j) * G%IdyT(i,j)) + DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) + DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) + + Del2vort_q(I,J) = DY_dxBu * (vort_xy_dx(i+1,J) * G%IdyCv(i+1,J) - vort_xy_dx(i,J) * G%IdyCv(i,J)) + & + DX_dyBu * (vort_xy_dy(I,j+1) * G%IdyCu(I,j+1) - vort_xy_dy(I,j) * G%IdyCu(I,j)) enddo ; enddo do J=Jsq,Jeq+1 ; do I=Isq,Ieq+1 Del2vort_h(i,j) = 0.25*(Del2vort_q(I,J) + Del2vort_q(I-1,J) + Del2vort_q(I,J-1) + Del2vort_q(I-1,J-1)) @@ -1091,7 +1092,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%Re_Ah > 0.0) then - KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + KE = 0.125*((u(I,j,k)+u(I,j+1,k))**2 + (v(i,J,k)+v(i+1,J,k))**2) Ah = sqrt(KE) * CS%Re_Ah_const_xy(i,j) endif From 8a8dad5d3af626adf1ae7e73e4225229a029df1f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 24 Aug 2020 21:48:54 -0400 Subject: [PATCH 071/103] +Allow position=NORTH_FACE in pass_var calls Added code to handle the cases where the position argument to pass_var is set to NORTH_FACE or EAST_FACE. All answers are bitwise identical. --- src/framework/MOM_domains.F90 | 64 +++++++++++++++++++++++------------ 1 file changed, 42 insertions(+), 22 deletions(-) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 7cf9df39f1..f578df61c9 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -26,11 +26,12 @@ module MOM_domains use mpp_domains_mod, only : mpp_group_update_initialized use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update use mpp_domains_mod, only : compute_block_extent => mpp_compute_block_extent -use mpp_parameter_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER -use mpp_parameter_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE -use mpp_parameter_mod, only : To_North => SUPDATE, To_South => NUPDATE, CENTER -use fms_io_mod, only : file_exist, parse_mask_table -use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set,fms_affinity_get +use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +use mpp_domains_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE +use mpp_domains_mod, only : To_North => SUPDATE, To_South => NUPDATE +use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE => NORTH, EAST_FACE => EAST +use fms_io_mod, only : file_exist, parse_mask_table +use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get implicit none ; private @@ -40,7 +41,8 @@ module MOM_domains public :: pass_var_start, pass_var_complete, fill_symmetric_edges, broadcast public :: pass_vector_start, pass_vector_complete public :: global_field_sum, sum_across_PEs, min_across_PEs, max_across_PEs -public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER, CENTER +public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +public :: CORNER, CENTER, NORTH_FACE, EAST_FACE public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: create_group_pass, do_group_pass, group_pass_type public :: start_group_pass, complete_group_pass @@ -153,8 +155,8 @@ subroutine pass_var_3d(array, MOM_dom, sideflag, complete, position, halo, & !! progress resumes. Omitting complete is the !! same as setting complete to .true. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER by - !! default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be @@ -198,8 +200,8 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner !! progress resumes. Omitting complete is the !! same as setting complete to .true. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full halo !! by default. integer, optional, intent(in) :: inner_halo !< The size of an inner halo to avoid updating, @@ -267,6 +269,24 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner elseif (size(array,2) == jed+1) then jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CORNER array.") ; endif + elseif (pos == NORTH_FACE) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for NORTH_FACE array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for NORTH_FACE array.") ; endif + elseif (pos == EAST_FACE) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for EAST_FACE array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for EAST_FACE array.") ; endif else call MOM_error(FATAL, "pass_var_2d: Unrecognized position") endif @@ -297,8 +317,8 @@ function pass_var_start_2d(array, MOM_dom, sideflag, position, complete, halo, & !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. logical, optional, intent(in) :: complete !< An optional argument indicating whether the !! halo updates should be completed before !! progress resumes. Omitting complete is the @@ -342,8 +362,8 @@ function pass_var_start_3d(array, MOM_dom, sideflag, position, complete, halo, & !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. logical, optional, intent(in) :: complete !< An optional argument indicating whether the !! halo updates should be completed before !! progress resumes. Omitting complete is the @@ -390,8 +410,8 @@ subroutine pass_var_complete_2d(id_update, array, MOM_dom, sideflag, position, h !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be @@ -433,8 +453,8 @@ subroutine pass_var_complete_3d(id_update, array, MOM_dom, sideflag, position, h !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be @@ -901,8 +921,8 @@ subroutine create_var_group_pass_2d(group, array, MOM_dom, sideflag, position, & !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be @@ -946,8 +966,8 @@ subroutine create_var_group_pass_3d(group, array, MOM_dom, sideflag, position, h !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be From a05eeeee790bd5ae00175d562440c3b5c5f55bcb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 25 Aug 2020 15:39:03 -0400 Subject: [PATCH 072/103] +Revised interface to write_cputime Revised the interface to write_cputime, adding one optional argument and making another intent inout argument optional when it was not going to be reset, and also adding a flush of an I/O channel, and added a new subroutine, MOM_write_cputime_end, to be called during cleanup, potentially via write_cputime. The write_cputime calls from the solo driver routines have been modified in accord with these changes, and a final write_cputime call has been added so that the time used by the whole run is reported. These changes should address the problems in MOM6 issue #853, which should be closed once this PR is merged into dev/gfdl. All answers are bitwise identical, but there are minor interface changes and a new publicly visible subroutine. --- .../ice_solo_driver/ice_shelf_driver.F90 | 5 +- config_src/solo_driver/MOM_driver.F90 | 5 +- src/framework/MOM_write_cputime.F90 | 51 ++++++++++++++----- 3 files changed, 44 insertions(+), 17 deletions(-) diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index 9113b60c64..b1323a5485 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -353,7 +353,7 @@ program Shelf_main call close_file(unit) endif - if (cpu_steps > 0) call write_cputime(Time, 0, nmax, write_CPU_CSp) + if (cpu_steps > 0) call write_cputime(Time, 0, write_CPU_CSp) if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & .or. (Restart_control < 0)) permit_incr_restart = .false. @@ -403,7 +403,7 @@ program Shelf_main Time = Master_Time if (cpu_steps > 0) then ; if (MOD(ns, cpu_steps) == 0) then - call write_cputime(Time, ns, nmax, write_CPU_CSp) + call write_cputime(Time, ns, write_CPU_CSp, nmax) endif ; endif ! See if it is time to write out a restart file - timestamped or not. @@ -459,6 +459,7 @@ program Shelf_main call callTree_waypoint("End Shelf_main") call diag_mediator_end(Time, diag, end_diag_manager=.true.) + if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index f180cd9717..ba52d9c02a 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -447,7 +447,7 @@ program MOM_main call close_file(unit) endif - if (cpu_steps > 0) call write_cputime(Time, 0, nmax, write_CPU_CSp) + if (cpu_steps > 0) call write_cputime(Time, 0, write_CPU_CSp) if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & .or. (Restart_control < 0)) permit_incr_restart = .false. @@ -564,7 +564,7 @@ program MOM_main Time = Master_Time if (cpu_steps > 0) then ; if (MOD(ns, cpu_steps) == 0) then - call write_cputime(Time, ns+ntstep-1, nmax, write_CPU_CSp) + call write_cputime(Time, ns+ntstep-1, write_CPU_CSp, nmax) endif ; endif call mech_forcing_diags(forces, dt_forcing, grid, Time, diag, surface_forcing_CSp%handles) @@ -652,6 +652,7 @@ program MOM_main call callTree_waypoint("End MOM_main") call diag_mediator_end(Time, diag, end_diag_manager=.true.) + if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index 1f0e001073..2c1cb3378a 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -3,15 +3,15 @@ module MOM_write_cputime ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : sum_across_PEs, pe_here, num_pes +use MOM_coms, only : sum_across_PEs, num_pes use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe -use MOM_io, only : open_file, APPEND_FILE, ASCII_FILE, WRITEONLY_FILE +use MOM_io, only : open_file, close_file, APPEND_FILE, ASCII_FILE, WRITEONLY_FILE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_time_manager, only : time_type, get_time, operator(>) implicit none ; private -public write_cputime, MOM_write_cputime_init, write_cputime_start_clock +public write_cputime, MOM_write_cputime_init, MOM_write_cputime_end, write_cputime_start_clock !----------------------------------------------------------------------- @@ -33,7 +33,7 @@ module MOM_write_cputime real :: cputime2 = 0.0 !< The accumulated cpu time. integer :: previous_calls = 0 !< The number of times write_CPUtime has been called. integer :: prev_n = 0 !< The value of n from the last call. - integer :: fileCPU_ascii !< The unit number of the CPU time file. + integer :: fileCPU_ascii= -1 !< The unit number of the CPU time file. character(len=200) :: CPUfile !< The name of the CPU time file. end type write_cputime_CS @@ -101,16 +101,35 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) end subroutine MOM_write_cputime_init -!> This subroutine assesses how much CPU time the model has taken and determines how long the model -!! should be run before it saves a restart file and stops itself. -subroutine write_cputime(day, n, nmax, CS) - type(time_type), intent(inout) :: day !< The current model time. - integer, intent(in) :: n !< The time step number of the current execution. - integer, intent(inout) :: nmax !< The number of iterations after which to stop so - !! that the simulation will not run out of CPU time. - type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous +!> Close the MOM_write_cputime module. +subroutine MOM_write_cputime_end(CS) + type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous !! call to MOM_write_cputime_init. + if (.not.associated(CS)) return + + ! Flush and close the output files. + if (is_root_pe() .and. CS%fileCPU_ascii > 0) then + call flush(CS%fileCPU_ascii) + call close_file(CS%fileCPU_ascii) + endif + + deallocate(CS) + +end subroutine MOM_write_cputime_end + +!> This subroutine assesses how much CPU time the model has taken and determines how long the model +!! should be run before it saves a restart file and stops itself. Optionally this may also be used +!! to trigger this module's end routine. +subroutine write_cputime(day, n, CS, nmax, call_end) + type(time_type), intent(inout) :: day !< The current model time. + integer, intent(in) :: n !< The time step number of the current execution. + type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous + !! call to MOM_write_cputime_init. + integer, optional, intent(inout) :: nmax !< The number of iterations after which to stop so + !! that the simulation will not run out of CPU time. + logical, optional, intent(in) :: call_end !< If true, also call MOM_write_cputime_end. + ! Local variables real :: d_cputime ! The change in CPU time since the last call ! this subroutine. @@ -145,7 +164,7 @@ subroutine write_cputime(day, n, nmax, CS) ((CS%dn_dcpu_min*d_cputime < (n - CS%prev_n)) .or. & (CS%dn_dcpu_min < 0.0))) & CS%dn_dcpu_min = (n - CS%prev_n) / d_cputime - if (CS%dn_dcpu_min >= 0.0) then + if (present(nmax) .and. (CS%dn_dcpu_min >= 0.0)) then ! Have the model stop itself after 95% of the CPU time has been used. nmax = n + INT( CS%dn_dcpu_min * & (0.95*CS%maxcpu * REAL(num_pes())*CLOCKS_PER_SEC - & @@ -180,9 +199,15 @@ subroutine write_cputime(day, n, nmax, CS) write(CS%fileCPU_ascii,'(F12.3,", "I11,", ", F12.3,", ", F12.3)') & reday, n, (CS%cputime2 / real(CLOCKS_PER_SEC)), & d_cputime / real(CLOCKS_PER_SEC) + + call flush(CS%fileCPU_ascii) endif CS%previous_calls = CS%previous_calls + 1 + if (present(call_end)) then + if (call_end) call MOM_write_cputime_end(CS) + endif + end subroutine write_cputime !> \namespace mom_write_cputime From b2010ddb8652b4b169efb1663b3cfb6cd52754e1 Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Tue, 25 Aug 2020 17:27:13 -0400 Subject: [PATCH 073/103] Updating the default setting for BBL_USE_EOS to match USE_REGRIDDING --- src/parameterizations/vertical/MOM_set_viscosity.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index d4d3251885..12c3aa4486 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1846,6 +1846,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS logical :: default_2018_answers logical :: use_kappa_shear, adiabatic, use_omega, MLE_use_PBL_MLD logical :: use_CVMix_ddiff, differential_diffusion, use_KPP + logical :: use_regridding character(len=200) :: filename, tideamp_file type(OBC_segment_type), pointer :: segment => NULL() ! pointer to OBC segment type ! This include declares and sets the variable "version". @@ -1991,10 +1992,13 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "velocity magnitude. DRAG_BG_VEL is only used when "//& "BOTTOMDRAGLAW is defined.", units="m s-1", default=0.0, scale=US%m_s_to_L_T) endif + call get_param(param_file, mdl, "USE_REGRIDDING", use_regridding, & + do_not_log = .true.) call get_param(param_file, mdl, "BBL_USE_EOS", CS%BBL_use_EOS, & "If true, use the equation of state in determining the "//& "properties of the bottom boundary layer. Otherwise use "//& - "the layer target potential densities.", default=.false.) + "the layer target potential densities. The default of "//& + "this is determined by USE_REGRIDDING.", default=use_regridding) endif call get_param(param_file, mdl, "BBL_THICK_MIN", CS%BBL_thick_min, & "The minimum bottom boundary layer thickness that can be "//& From 329b9006490c90c8616b8ea2af5441e8a848e2f0 Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Tue, 25 Aug 2020 17:34:08 -0400 Subject: [PATCH 074/103] Adding FATAL error if trying to use BBL_USE_EOS = False in ALE mode --- src/parameterizations/vertical/MOM_set_viscosity.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 12c3aa4486..29098082e3 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1999,6 +1999,9 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "properties of the bottom boundary layer. Otherwise use "//& "the layer target potential densities. The default of "//& "this is determined by USE_REGRIDDING.", default=use_regridding) + if (use_regridding .and. (.not. CS%BBL_use_EOS)) & + call MOM_error(FATAL,"When using MOM6 in ALE mode it is required to "//& + "set BBL_USE_EOS to True") endif call get_param(param_file, mdl, "BBL_THICK_MIN", CS%BBL_thick_min, & "The minimum bottom boundary layer thickness that can be "//& From ca10be7c1b58563470fc4f5f783e9a80e6aff40f Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Tue, 25 Aug 2020 18:12:11 -0400 Subject: [PATCH 075/103] Registering default for USE_REGRIDDING to MOM_set_viscosity --- src/parameterizations/vertical/MOM_set_viscosity.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 29098082e3..02fa647e7e 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1993,7 +1993,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "BOTTOMDRAGLAW is defined.", units="m s-1", default=0.0, scale=US%m_s_to_L_T) endif call get_param(param_file, mdl, "USE_REGRIDDING", use_regridding, & - do_not_log = .true.) + do_not_log = .true., default = .false. ) call get_param(param_file, mdl, "BBL_USE_EOS", CS%BBL_use_EOS, & "If true, use the equation of state in determining the "//& "properties of the bottom boundary layer. Otherwise use "//& From e3bc47a8d99c3c40286470f7855f9755000105b8 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 26 Aug 2020 10:08:18 -0600 Subject: [PATCH 076/103] Fix letter case to follow MOM6 convention --- src/parameterizations/lateral/MOM_hor_visc.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 2edafa0f27..f35c2fb398 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -636,7 +636,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then if ((J >= js-1) .and. (J <= je+1)) then do I = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+1,OBC%segment(n)%HI%ied) - h_u(I,j) = h_u(i,j+1) + h_u(I,j) = h_u(I,j+1) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_E) then @@ -1087,8 +1087,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! Smagorinsky_Ah or Leith_Ah if (use_MEKE_Au) then ! *Add* the MEKE contribution - Ah = Ah + 0.25*( (MEKE%Au(I,J) + MEKE%Au(I+1,J+1)) + & - (MEKE%Au(I+1,J) + MEKE%Au(I,J+1)) ) + Ah = Ah + 0.25*( (MEKE%Au(i,j) + MEKE%Au(i+1,j+1)) + & + (MEKE%Au(i+1,j) + MEKE%Au(i,j+1)) ) endif if (CS%Re_Ah > 0.0) then @@ -1194,7 +1194,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, CS%dy2h(i+1,j)*str_xx(i+1,j)) + & G%IdxCu(I,j)*(CS%dx2q(I,J-1)*str_xy(I,J-1) - & CS%dx2q(I,J) *str_xy(I,J))) * & - G%IareaCu(I,j)) / (h_u(i,j) + h_neglect) + G%IareaCu(I,j)) / (h_u(I,j) + h_neglect) enddo ; enddo if (apply_OBC) then From 2946903bca2e3eb98fda1e3e6b7bea72a0c1c1e9 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 26 Aug 2020 14:43:25 -0600 Subject: [PATCH 077/103] Fix one more letter case to follow MOM6 convention --- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index f35c2fb398..953cc6d838 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1923,7 +1923,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif endif if (CS%Leith_Ah) then - CS%biharm6_const_xy(i,j) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3) + CS%biharm6_const_xy(I,J) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3) endif CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2)) if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xy(i,j) = grid_sp_q3 / CS%Re_Ah From c8a1f077225fe7f7d1af2bf523f2265e7d95a90a Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Fri, 28 Aug 2020 22:58:24 -0400 Subject: [PATCH 078/103] Set variable_buoyforce = True (even if False is chosen in MOM_input) for buoyancy surface restoration = True. --- config_src/solo_driver/MOM_surface_forcing.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 0a56abb681..8db310893b 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -302,6 +302,12 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US endif ! calls to various buoyancy forcing options + if (CS%restorebuoy .and. .not.CS%variable_buoyforce) then + call MOM_error(WARNING, "With RESTOREBUOY = True, VARIABLE_BUOYFORCE = True should be used. "//& + "Changed to VARIABLE_BUOYFORCE = True") + CS%variable_buoyforce = .true. + endif + if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & (.not.CS%adiabatic)) then if (trim(CS%buoy_config) == "file") then From 995e422322657eb5972b5db5187e5ea7a233293f Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 31 Aug 2020 18:07:24 -0400 Subject: [PATCH 079/103] Fix spelling in comments and line length - One line was too long - Noticed several spelling and grammar problems in comments --- src/core/MOM_PressureForce_FV.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index fc2d40eaf3..0165a44642 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -480,9 +480,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. - !real :: dTdi2, dTdj2 ! Differences in T variance [degC2] - real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stenil of T [degC or degC2] - real :: Hl(5), mn_H ! Copy of local stencial of H [H ~> m] + real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stencil of T [degC or degC2] + real :: Hl(5), mn_H ! Copy of local stencil of H [H ~> m] real, parameter :: C1_6 = 1.0/6.0 integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb @@ -506,9 +505,9 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (CS%Stanley_T2_det_coeff>=0.) then if (.not. associated(tv%varT)) call safe_alloc_ptr(tv%varT, G%isd, G%ied, G%jsd, G%jed, GV%ke) do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - ! Strictly speaking we should be estimate the horizontal grid-scale variance + ! Strictly speaking we should estimate the *horizontal* grid-scale variance ! but neither of the following blocks make a rotation to the horizontal - ! but work along coordinate + ! and instead work along coordinate. ! This block calculates a simple |delta T| along coordinates and does ! not allow vanishing layer thicknesses or layers tracking topography @@ -529,7 +528,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm mn_H = ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff mn_H = 1. / mn_H ! Hereafter, mn_H is the reciprocal of mean h for the stencil ! Mean of T - Tl(1) = tv%T(i,j,k) ; Tl(2) = tv%T(i-1,j,k) ; Tl(3) = tv%T(i+1,j,k) ; Tl(4) = tv%T(i,j-1,k) ; Tl(5) = tv%T(i,j+1,k) + Tl(1) = tv%T(i,j,k) ; Tl(2) = tv%T(i-1,j,k) ; Tl(3) = tv%T(i+1,j,k) + Tl(4) = tv%T(i,j-1,k) ; Tl(5) = tv%T(i,j+1,k) mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * mn_H ! Adjust T vectors to have zero mean Tl(:) = Tl(:) - mn_T ; mn_T = 0. From 4668673cf4ec410bd2f2c56fd006be65af2679bb Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 1 Sep 2020 12:41:24 -0400 Subject: [PATCH 080/103] .testing Makefile typo fix The restart tests were incorrectly reported as restart.diag tests in the output log. This patch fixes these typos. Restart test diagnostics are currently not checked, and this patch is a good reminder that we need to get these in ASAP. --- .testing/Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index ab978fdadc..32a5db06ab 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -293,9 +293,9 @@ $(eval $(call CMP_RULE,regression,symmetric target)) || !( \ mkdir -p results/$*; \ (diff $$^ | tee results/$*/chksum_diag.restart.diff | head) ; \ - echo -e "${FAIL}: Diagnostics $*.restart.diag have changed." \ + echo -e "${FAIL}: Solutions $*.restart have changed." \ ) - @echo -e "${PASS}: Diagnostics $*.restart.diag agree." + @echo -e "${PASS}: Solutions $*.restart agree." # TODO: chksum_diag parsing of restart files From bbc0f0dc30a11e0c855e0e895e937751ad3d7637 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 1 Sep 2020 15:36:10 -0400 Subject: [PATCH 081/103] Adds some targets to run groups of TCs - New targets run.symmetric, run.asymmetric, run.nans, run.openmp added for convenience and in anticipation of want to run the model just once for coverage upload. --- .testing/Makefile | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/.testing/Makefile b/.testing/Makefile index 32a5db06ab..6f3553a694 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -243,6 +243,12 @@ test.nans: $(foreach c,$(CONFIGS),$(c).nan $(c).nan.diag) test.dims: $(foreach c,$(CONFIGS),$(foreach d,$(DIMS),$(c).dim.$(d) $(c).dim.$(d).diag)) test.regressions: $(foreach c,$(CONFIGS),$(c).regression $(c).regression.diag) +.PHONY: run.symmetric run.asymmetric run.nans run.openmp +run.symmetric: $(foreach c,$(CONFIGS),work/$(c)/symmetric/ocean.stats) +run.asymmetric: $(foreach c,$(filter-out tc3,$(CONFIGS)),$(CONFIGS),work/$(c)/asymmetric/ocean.stats) +run.nans: $(foreach c,$(CONFIGS),work/$(c)/nan/ocean.stats) +run.openmp: $(foreach c,$(CONFIGS),work/$(c)/openmp/ocean.stats) + # Color highlights for test results RED=\033[0;31m GREEN=\033[0;32m From 53b21b6636ba649f5245ec3e61a641601d683dab Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 1 Sep 2020 15:38:34 -0400 Subject: [PATCH 082/103] Adds a coverage job to Travis-CI sequence - Keeping the coverage within the regression job, this adds a conditional job for all other that uploads coverage. --- .travis.yml | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/.travis.yml b/.travis.yml index 10816b7122..03bdff31dc 100644 --- a/.travis.yml +++ b/.travis.yml @@ -41,6 +41,8 @@ jobs: - make test.summary # NOTE: Code coverage upload is here to reduce load imbalance + # We do coverage with the regressions if part of a pull request + # otherwise as a separate job. - if: type = pull_request env: - JOB="x86 Regression testing" @@ -57,6 +59,19 @@ jobs: - make -k -s test.regressions - make test.summary + - if: NOT type = pull_request + env: + - JOB="Coverage upload" + - REPORT_COVERAGE=true + - DO_REGRESSION_TESTS=false + - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk + script: + - cd .testing + - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' + - make build/symmetric/MOM6 + - echo -en 'travis_fold:end:script.1\\r' + - make -k -s run.symmetric + - arch: arm64 env: - JOB="ARM64 Configuration testing" From 4dbc12697dd536f019c3282caf56b1975c064112 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 1 Sep 2020 17:50:58 -0400 Subject: [PATCH 083/103] Adds land masking of thicknesses in SGS estimate - The restart tests were failing because land values differ before/after a restart. Adding 2d land masking of h value in the stencil removes the sensitivity. --- src/core/MOM_PressureForce_FV.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 0165a44642..942c29854e 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -524,7 +524,11 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! This block does a thickness weighted variance calculation and helps control for ! extreme gradients along layers which are vanished against topography. It is ! still a poor approximation in the interior when coordinates are strongly tilted. - hl(1) = h(i,j,k) ; hl(2) = h(i-1,j,k) ; hl(3) = h(i+1,j,k) ; hl(4) = h(i,j-1,k) ; hl(5) = h(i,j+1,k) + hl(1) = h(i,j,k) * G%mask2dT(i,j) + hl(2) = h(i-1,j,k) * G%mask2dCu(I-1,j) + hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) + hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) + hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) mn_H = ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff mn_H = 1. / mn_H ! Hereafter, mn_H is the reciprocal of mean h for the stencil ! Mean of T From f841d28a800fa396016967243c5bb11923301fea Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 1 Sep 2020 20:30:32 -0400 Subject: [PATCH 084/103] *Corrected the test whether to use fluxes%psurf Changed the test to detect whether the surface pressure has been set for use in the equation of state calculations in the thermodynamic step from evaluating whether forces%p_surf is associated to whether fluxes%p_surf is associated. Because these two pointers often point to the same array, this only changes answers in the coupled_AM2_LM3_SIS2/Intersperse_ice_1deg test case, but it could change answer in other cases, depending on how MOM6 is called. Because this only appears to change answers for one test case that is not widely used yet, and does not impact configurations that are used outside of GFDL, the decision was taken not to introduce a bug flag to preserve the old incorrect answers. --- src/core/MOM.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 3f60299b6b..3398c14d50 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -595,7 +595,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS dt_therm = dt ; ntstep = 1 if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf CS%tv%p_surf => NULL() - if (associated(forces%p_surf)) then !### This should be fluxes%p_surf! + if (associated(fluxes%p_surf)) then if (CS%use_p_surf_in_EOS) CS%tv%p_surf => fluxes%p_surf endif if (CS%UseWaves) call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass) From df12b66bcd70fabdde9f89236bd0feebe0c381cb Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Wed, 2 Sep 2020 11:46:19 -0400 Subject: [PATCH 085/103] WARNING changed to FATAL error. The error message has been modified. --- config_src/solo_driver/MOM_surface_forcing.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 8db310893b..7e56bd520c 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -303,9 +303,9 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US ! calls to various buoyancy forcing options if (CS%restorebuoy .and. .not.CS%variable_buoyforce) then - call MOM_error(WARNING, "With RESTOREBUOY = True, VARIABLE_BUOYFORCE = True should be used. "//& - "Changed to VARIABLE_BUOYFORCE = True") - CS%variable_buoyforce = .true. + call MOM_error(FATAL, "With RESTOREBUOY = True, VARIABLE_BUOYFORCE = True should be used. "//& + "Otherwise, this can lead to diverging soultions when a simulation "//& + "is continued using a restart file.") endif if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & From b89c6403aca7c40ec6d44fddc587984aa1703ce3 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 2 Sep 2020 12:04:47 -0400 Subject: [PATCH 086/103] Update MOM_surface_forcing.F90 --- config_src/solo_driver/MOM_surface_forcing.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 7e56bd520c..3d8b398516 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -304,7 +304,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US ! calls to various buoyancy forcing options if (CS%restorebuoy .and. .not.CS%variable_buoyforce) then call MOM_error(FATAL, "With RESTOREBUOY = True, VARIABLE_BUOYFORCE = True should be used. "//& - "Otherwise, this can lead to diverging soultions when a simulation "//& + "Otherwise, this can lead to diverging solutions when a simulation "//& "is continued using a restart file.") endif From 2fe58383ad2c6183581686d3e9941a0c4576b2d3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Sep 2020 16:34:38 -0400 Subject: [PATCH 087/103] (*)Reduce size of GV%Rlay and improve error handling Reduced the size of GV%Rlay to GV%ke, befitting a layer variable, and added code to issue error messages or appropriately handle cases with very few layers that would have led to segmentation faults without error handling. This includes explicitly setting argument array sizes in various set_coord subroutines, and correcting the descriptions of some EOS_type arguments. All answers in the MOM6-examples regression suite are bitwise identical, but there may be some answer changes in cases that should not have worked previously. This PR addresses MOM6 issue #966, which might now be closed. --- src/ALE/MOM_regridding.F90 | 21 ++- src/core/MOM_verticalGrid.F90 | 3 +- .../MOM_coord_initialization.F90 | 153 +++++++++--------- .../MOM_state_initialization.F90 | 9 +- src/tracer/MOM_tracer_hor_diff.F90 | 19 +-- src/user/BFB_initialization.F90 | 15 +- src/user/ISOMIP_initialization.F90 | 2 +- src/user/Neverworld_initialization.F90 | 3 +- src/user/adjustment_initialization.F90 | 9 +- src/user/benchmark_initialization.F90 | 10 +- src/user/user_initialization.F90 | 23 ++- 11 files changed, 138 insertions(+), 129 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 889e10e32d..2a77cb06fe 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -375,6 +375,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m "Unsupported format in grid definition '"//trim(filename)//"'. Error message "//trim(message)) call field_size(trim(fileName), trim(varName), nzf) ke = nzf(1)-1 + if (ke < 1) call MOM_error(FATAL, trim(mdl)//" initialize_regridding via Var "//trim(varName)//& + "in FILE "//trim(filename)//" requires at least 2 target interface values.") if (CS%regridding_scheme == REGRIDDING_RHO) then allocate(rho_target(ke+1)) call MOM_read_data(trim(fileName), trim(varName), rho_target) @@ -392,7 +394,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m allocate(dz(ke)) call MOM_read_data(trim(fileName), trim(varName), dz) endif - if (main_parameters .and. ke/=GV%ke) then + if (main_parameters .and. (ke/=GV%ke)) then call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & 'Mismatch in number of model levels and "'//trim(string)//'".') endif @@ -2016,17 +2018,22 @@ end subroutine setCoordinateResolution !> Set target densities based on the old Rlay variable subroutine set_target_densities_from_GV( GV, US, CS ) type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(regridding_CS), intent(inout) :: CS !< Regridding control structure ! Local variables integer :: k, nz nz = CS%nk - CS%target_density(1) = (GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2))) - CS%target_density(nz+1) = (GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1))) - do k = 2,nz - CS%target_density(k) = CS%target_density(k-1) + CS%coordinateResolution(k) - enddo + if (nz == 1) then ! Set a broad range of bounds. Regridding may not be meaningful in this case. + CS%target_density(1) = 0.0 + CS%target_density(2) = 2.0*GV%Rlay(1) + else + CS%target_density(1) = (GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2))) + CS%target_density(nz+1) = (GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1))) + do k=2,nz + CS%target_density(k) = CS%target_density(k-1) + CS%coordinateResolution(k) + enddo + endif CS%target_density_set = .true. end subroutine set_target_densities_from_GV diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index 6e65d38c8a..7495e0033b 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -174,8 +174,7 @@ subroutine verticalGridInit( param_file, GV, US ) allocate( GV%sInterface(nk+1) ) allocate( GV%sLayer(nk) ) allocate( GV%g_prime(nk+1) ) ; GV%g_prime(:) = 0.0 - ! The extent of Rlay should be changed to nk? - allocate( GV%Rlay(nk+1) ) ; GV%Rlay(:) = 0.0 + allocate( GV%Rlay(nk) ) ; GV%Rlay(:) = 0.0 end subroutine verticalGridInit diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 5b2bd7130f..c1ec788836 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -105,6 +105,10 @@ subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_dept case default ; call MOM_error(FATAL,"MOM_initialize_coord: "// & "Unrecognized coordinate setup"//trim(config)) end select + ! There are nz+1 values of g_prime because it is an interface field, but the value at the bottom + ! should not matter. This is here just to avoid having an uninitialized value in some output. + GV%g_prime(nz+1) = 10.0*GV%g_Earth + if (debug) call chksum(US%R_to_kg_m3*GV%Rlay(:), "MOM_initialize_coord: Rlay ", 1, nz) if (debug) call chksum(US%m_to_Z*US%L_to_m**2*US%s_to_T**2*GV%g_prime(:), "MOM_initialize_coord: g_prime ", 1, nz) call setVerticalGridAxes( GV%Rlay, GV, scale=US%R_to_kg_m3 ) @@ -123,13 +127,13 @@ end subroutine MOM_initialize_coord !> Sets the layer densities (Rlay) and the interface reduced gravities (g). subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(GV%ke), intent(out) :: Rlay !< The layers' target coordinate values + !! (potential density) [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! Local variables real :: g_int ! Reduced gravities across the internal interfaces [L2 Z-1 T-2 ~> m s-2]. real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. @@ -157,13 +161,14 @@ end subroutine set_coord_from_gprime !> Sets the layer densities (Rlay) and the interface reduced gravities (g). subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(GV%ke), intent(out) :: Rlay !< The layers' target coordinate values + !! (potential density) [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + ! Local variables real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. real :: Rlay_Ref! The surface layer's target density [R ~> kg m-3]. @@ -184,14 +189,14 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) "The range of reference potential densities in the layers.", & units="kg m-3", default=2.0, scale=US%kg_m3_to_R) - g_prime(1) = g_fs Rlay(1) = Rlay_Ref do k=2,nz - Rlay(k) = Rlay(k-1) + RLay_range/(real(nz-1)) + Rlay(k) = Rlay(k-1) + RLay_range/(real(nz-1)) enddo ! These statements set the interface reduced gravities. ! + g_prime(1) = g_fs do k=2,nz - g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) + g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) enddo call callTree_leave(trim(mdl)//'()') @@ -199,17 +204,17 @@ end subroutine set_coord_from_layer_density !> Sets the layer densities (Rlay) and the interface reduced gravities (g) from a profile of g'. subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state, P_Ref) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters - type(EOS_type), pointer :: eqn_of_state !< integer selecting the equation of state. - real, intent(in) :: P_Ref !< The coordinate-density reference pressure - !! [R L2 T-2 ~> Pa]. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(GV%ke), intent(out) :: Rlay !< The layers' target coordinate values + !! (potential density) [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure + real, intent(in) :: P_Ref !< The coordinate-density reference pressure + !! [R L2 T-2 ~> Pa]. + ! Local variables real :: T_ref ! Reference temperature real :: S_ref ! Reference salinity @@ -232,7 +237,7 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state call get_param(param_file, mdl, "GINT", g_int, & "The reduced gravity across internal interfaces.", & units="m s-2", fail_if_missing=.true., scale=US%m_s_to_L_T**2*US%Z_to_m) - ! + ! These statements set the interface reduced gravities. ! g_prime(1) = g_fs do k=2,nz ; g_prime(k) = g_int ; enddo @@ -250,17 +255,15 @@ end subroutine set_coord_from_TS_ref !> Sets the layer densities (Rlay) and the interface reduced gravities (g) from a T-S profile. subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_state, P_Ref) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters - type(EOS_type), pointer :: eqn_of_state !< integer that selects equation of state. - real, intent(in) :: P_Ref !< The coordinate-density reference pressure - !! [R L2 T-2 ~> Pa]. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure + real, intent(in) :: P_Ref !< The coordinate-density reference pressure + !! [R L2 T-2 ~> Pa]. ! Local variables real, dimension(GV%ke) :: T0, S0, Pref @@ -299,17 +302,15 @@ end subroutine set_coord_from_TS_profile !> Sets the layer densities (Rlay) and the interface reduced gravities (g) from a linear T-S profile. subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_state, P_Ref) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters - type(EOS_type), pointer :: eqn_of_state !< integer that selects equation of state - real, intent(in) :: P_Ref !< The coordinate-density reference pressure - !! [R L2 T-2 ~> Pa]. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure + real, intent(in) :: P_Ref !< The coordinate-density reference pressure + !! [R L2 T-2 ~> Pa]. ! Local variables real, dimension(GV%ke) :: T0, S0, Pref @@ -357,6 +358,9 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta "The reduced gravity at the free surface.", units="m s-2", & default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) + if ((GV%nk_rho_varies > 0) .and. (nz < GV%nk_rho_varies+2)) & + call MOM_error(FATAL, "set_coord_from_TS_range requires that NZ >= NKML+NKBL+2.") + k_light = GV%nk_rho_varies + 1 ! Set T0(k) to range from T_LIGHT to T_DENSE, and simliarly for S0(k). @@ -376,20 +380,20 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta do k=k_light-1,1,-1 Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) enddo - do k=2,nz ; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo + do k=2,nz ; g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) ; enddo call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_range ! Sets the layer densities (Rlay) and the interface reduced gravities (g) from data in file. subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + ! Local variables real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. integer :: k, nz @@ -435,13 +439,13 @@ end subroutine set_coord_from_file !! to the bottom defined by the parameter RLAY_RANGE !! (defaulting to 2.0 if not defined) subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + ! Local variables character(len=40) :: mdl = "set_coord_linear" ! This subroutine real :: Rlay_ref, Rlay_range, g_fs @@ -464,12 +468,12 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) ! surface interface has density Rlay_ref and the bottom ! is Rlay_range larger do k=1,nz - Rlay(k) = Rlay_Ref + RLay_range*((real(k)-0.5)/real(nz)) + Rlay(k) = Rlay_Ref + RLay_range*((real(k)-0.5)/real(nz)) enddo ! These statements set the interface reduced gravities. g_prime(1) = g_fs do k=2,nz - g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) + g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) enddo call callTree_leave(trim(mdl)//'()') @@ -479,13 +483,12 @@ end subroutine set_coord_linear !! This is for use only in ALE mode where Rlay should not be used and g_prime(1) alone !! might be used. subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces, - !! [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! Local variables real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. character(len=40) :: mdl = "set_coord_to_none" ! This subroutine's name. diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 9f505325bf..de33409fed 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1558,7 +1558,7 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. - type(EOS_type), pointer :: eqn_of_state !< Integer that selects the equatio of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: P_Ref !< The coordinate-density reference pressure !! [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -2335,7 +2335,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param ! Rb contains the layer interface densities allocate(Rb(nz+1)) do k=2,nz ; Rb(k) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo - Rb(1) = 0.0 ; Rb(nz+1) = 2.0*GV%Rlay(nz) - GV%Rlay(nz-1) + Rb(1) = 0.0 + if (nz>1) then + Rb(nz+1) = 2.0*GV%Rlay(nz) - GV%Rlay(nz-1) + else + Rb(nz+1) = 2.0 * GV%Rlay(1) + endif nkml = 0 ; if (separate_mixed_layer) nkml = GV%nkml diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 53ed8881e3..43ede7cff5 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -727,11 +727,10 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! Use bracketing and bisection to find the k-level that the densest of the ! mixed and buffer layer corresponds to, such that: ! GV%Rlay(max_kRho-1) < Rml_max <= GV%Rlay(max_kRho) -!$OMP parallel do default(none) shared(is,ie,js,je,nz,nkmb,G,GV,Rml_max,max_kRho) & -!$OMP private(k_min,k_max,k_test) + !$OMP parallel do default(shared) private(k_min,k_max,k_test) do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.5) then - if (Rml_max(i,j) > GV%Rlay(nz)) then ; max_kRho(i,j) = nz+1 - elseif (Rml_max(i,j) <= GV%Rlay(nkmb+1)) then ; max_kRho(i,j) = nkmb+1 + if ((Rml_max(i,j) > GV%Rlay(nz)) .or. (nkmb+1 > nz)) then ; max_kRho(i,j) = nz+1 + elseif ((Rml_max(i,j) <= GV%Rlay(nkmb+1)) .or. (nkmb+2 > nz)) then ; max_kRho(i,j) = nkmb+1 else k_min = nkmb+2 ; k_max = nz do @@ -754,10 +753,8 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & if (PEmax_kRho > nz) PEmax_kRho = nz ! PEmax_kRho could have been nz+1. h_exclude = 10.0*(GV%Angstrom_H + GV%H_subroundoff) -!$OMP parallel default(none) shared(is,ie,js,je,nkmb,G,GV,h,h_exclude,num_srt,k0_srt, & -!$OMP rho_srt,h_srt,PEmax_kRho,k_end_srt,rho_coord,max_srt) & -!$OMP private(ns,tmp,itmp) -!$OMP do + !$OMP parallel default(shared) private(ns,tmp,itmp) + !$OMP do do j=js-1,je+1 do k=1,nkmb ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.5) then if (h(i,j,k) > h_exclude) then @@ -778,7 +775,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & enddo ! Sort each column by increasing density. This should already be close, ! and the size of the arrays are small, so straight insertion is used. -!$OMP do + !$OMP do do j=js-1,je+1; do i=is-1,ie+1 do k=2,num_srt(i,j) ; if (rho_srt(i,k,j) < rho_srt(i,k-1,j)) then ! The last segment needs to be shuffled earlier in the list. @@ -789,12 +786,12 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & enddo endif ; enddo enddo ; enddo -!$OMP do + !$OMP do do j=js-1,je+1 max_srt(j) = 0 do i=is-1,ie+1 ; max_srt(j) = max(max_srt(j), num_srt(i,j)) ; enddo enddo -!$OMP end parallel + !$OMP end parallel do j=js,je k_size = max(2*max_srt(j),1) diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 9e8f612a35..1c5ee016ae 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -36,14 +36,13 @@ module BFB_initialization !! southern edge of the domain. The temperatures are then converted to densities of the top and bottom layers !! and linearly interpolated for the intermediate layers. subroutine BFB_set_coord(Rlay, g_prime, GV, US, param_file, eqn_of_state) - real, dimension(NKMEM_), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. - real, dimension(NKMEM_), intent(out) :: g_prime !< The reduced gravity at - !! each interface [L2 Z-1 T-2 ~> m s-2]. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(EOS_type), pointer :: eqn_of_state !< Integer that selects the - !! equation of state. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure ! Local variables real :: drho_dt, SST_s, T_bot, rho_top, rho_bot integer :: k, nz diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 0a3cfb3fbe..d125495d7f 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -370,7 +370,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi if (fit_salin) then ! A first guess of the layers' salinity. do k=nz,1,-1 - S0(k) = max(0.0, S0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dS1) + S0(k) = max(0.0, S0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dS1) enddo ! Refine the guesses for each layer. do itt=1,6 diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90 index 5a21966c9d..d019854310 100644 --- a/src/user/Neverworld_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -248,8 +248,7 @@ subroutine Neverworld_initialize_thickness(h, G, GV, US, param_file, eqn_of_stat type(param_file_type), intent(in) :: param_file !< A structure indicating the open !! file to parse for model !! parameter values. - type(EOS_type), pointer :: eqn_of_state !< integer that selects the - !! equation of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: P_Ref !< The coordinate-density !! reference pressure [R L2 T-2 ~> Pa]. ! Local variables diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 6dde9c68ef..0ceaabbec7 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -125,8 +125,13 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read e0(k) = -G%max_depth * (real(k-1) / real(nz)) enddo endif - target_values(1) = ( GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2)) ) - target_values(nz+1) = ( GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1)) ) + if (nz > 1) then + target_values(1) = ( GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2)) ) + target_values(nz+1) = ( GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1)) ) + else ! This might not be needed, but it avoids segmentation faults if nz=1. + target_values(1) = 0.0 + target_values(nz+1) = 2.0 * GV%Rlay(1) + endif do k = 2,nz target_values(k) = target_values(k-1) + ( GV%Rlay(nz) - GV%Rlay(1) ) / (nz-1) enddo diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index e32c8b9e41..cc82ea6761 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -91,8 +91,7 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. - type(EOS_type), pointer :: eqn_of_state !< integer that selects the - !! equation of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: P_Ref !< The coordinate-density !! reference pressure [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -217,16 +216,15 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & eqn_of_state, P_Ref, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< The potential temperature + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature !! that is being initialized. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< The salinity that is being + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is being !! initialized. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for !! model parameter values. - type(EOS_type), pointer :: eqn_of_state !< integer that selects the - !! equation of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: P_Ref !< The coordinate-density !! reference pressure [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index 55c609802e..a5d0fc90f7 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -38,17 +38,15 @@ module user_initialization !> Set vertical coordinates. subroutine USER_set_coord(Rlay, g_prime, GV, US, param_file, eqn_of_state) - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid - !! structure. - real, dimension(:), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity at - !! each interface [L2 Z-1 T-2 ~> m s-2]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure indicating the - !! open file to parse for model - !! parameter values. - type(EOS_type), pointer :: eqn_of_state !< Integer that selects the - !! equation of state. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(GV%ke), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. + real, dimension(GV%ke+1), intent(out) :: g_prime !< The reduced gravity at each + !! interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure call MOM_error(FATAL, & "USER_initialization.F90, USER_set_coord: " // & @@ -144,8 +142,7 @@ subroutine USER_init_temperature_salinity(T, S, G, param_file, eqn_of_state, jus type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model !! parameter values. - type(EOS_type), pointer :: eqn_of_state !< Integer that selects the - !! equation of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will only !! read parameters without changing T & S. From 1d717f57013dffae216297d14cf9b2a0f12957d2 Mon Sep 17 00:00:00 2001 From: jskenigson Date: Wed, 2 Sep 2020 14:52:27 -0600 Subject: [PATCH 088/103] Update MOM_PressureForce_FV.F90 mn_T = 0 so remove subtraction of mn_T^2 in SGS temperature variance --- src/core/MOM_PressureForce_FV.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 942c29854e..fc47ef11e5 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -542,7 +542,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * mn_H ! Variance should be positive but round-off can violate this. Calculating ! variance directly would fix this but requires more operations. - tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * max(0., mn_T2 - mn_T*mn_T) + tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * max(0., mn_T2) enddo ; enddo ; enddo endif From 5aa08635ced42046ae5a56ec69d01cb4ba3c5552 Mon Sep 17 00:00:00 2001 From: jkenigson Date: Wed, 2 Sep 2020 17:57:42 -0600 Subject: [PATCH 089/103] Updated MOM_thickness_diffuse to use the deterministic parameterization of the SGS temperature variance --- .../lateral/MOM_thickness_diffuse.F90 | 52 ++++++++++++++----- 1 file changed, 38 insertions(+), 14 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index b59ab34c91..d338785406 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -158,6 +158,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp real :: hv(SZI_(G), SZJ_(G)) ! v-thickness [H ~> m or kg m-2] real :: KH_u_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] real :: KH_v_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] + real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stencil of T [degC or degC2] + real :: Hl(5), mn_H ! Copy of local stencil of H [H ~> m] if (.not. associated(CS)) call MOM_error(FATAL, "MOM_thickness_diffuse: "//& "Module must be initialized before it is used.") @@ -746,16 +748,38 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (use_Stanley) then !$OMP do do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - ! SGS variance in i-direction [degC2] - dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & - + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & - ) * G%dxT(i,j) * 0.5 )**2 - ! SGS variance in j-direction [degC2] - dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & - + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & - ) * G%dyT(i,j) * 0.5 )**2 - Tsgs2(i,j,k) = CS%Stanley_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) - enddo ; enddo ; enddo + !! SGS variance in i-direction [degC2] + !dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & + ! + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & + ! ) * G%dxT(i,j) * 0.5 )**2 + !! SGS variance in j-direction [degC2] + !dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & + ! + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & + ! ) * G%dyT(i,j) * 0.5 )**2 + !Tsgs2(i,j,k) = CS%Stanley_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) + ! This block does a thickness weighted variance calculation and helps control for + ! extreme gradients along layers which are vanished against topography. It is + ! still a poor approximation in the interior when coordinates are strongly tilted. + hl(1) = h(i,j,k) * G%mask2dT(i,j) + hl(2) = h(i-1,j,k) * G%mask2dCu(I-1,j) + hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) + hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) + hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) + mn_H = ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff + mn_H = 1. / mn_H ! Hereafter, mn_H is the reciprocal of mean h for the stencil + ! Mean of T + Tl(1) = T(i,j,k) ; Tl(2) = T(i-1,j,k) ; Tl(3) = T(i+1,j,k) + Tl(4) = T(i,j-1,k) ; Tl(5) = T(i,j+1,k) + mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * mn_H + ! Adjust T vectors to have zero mean + Tl(:) = Tl(:) - mn_T ; mn_T = 0. + ! Variance of T + mn_T2 = ( hl(1)*Tl(1)*Tl(1) + ( ( hl(2)*Tl(2)*Tl(2) + hl(3)*Tl(3)*Tl(3) ) & + + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * mn_H + ! Variance should be positive but round-off can violate this. Calculating + ! variance directly would fix this but requires more operations. + Tsgs2(i,j,k) = CS%Stanley_T2_det_coeff * max(0., mn_T2) + enddo ; enddo ; enddo endif !$OMP do do j=js-1,je+1 @@ -846,8 +870,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (use_Stanley) then ! Correction to the horizontal density gradient due to nonlinearity in ! the EOS rectifying SGS temperature anomalies - drdiA = drdiA + drho_dT_dT_u(I) * ( Tsgs2(i+1,j,k-1)-Tsgs2(i,j,k-1) ) - drdiB = drdiB + drho_dT_dT_u(I) * ( Tsgs2(i+1,j,k)-Tsgs2(i,j,k) ) + drdiA = drdiA + drho_dT_dT_u(I) * 0.5 * ( Tsgs2(i+1,j,k-1)-Tsgs2(i,j,k-1) ) + drdiB = drdiB + drho_dT_dT_u(I) * 0.5 * ( Tsgs2(i+1,j,k)-Tsgs2(i,j,k) ) endif if (find_work) drdi_u(I,k) = drdiB @@ -1111,8 +1135,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (use_Stanley) then ! Correction to the horizontal density gradient due to nonlinearity in ! the EOS rectifying SGS temperature anomalies - drdjA = drdjA + drho_dT_dT_v(I) * ( Tsgs2(i,j+1,k-1)-Tsgs2(i,j,k-1) ) - drdjB = drdjB + drho_dT_dT_v(I) * ( Tsgs2(i,j+1,k)-Tsgs2(i,j,k) ) + drdjA = drdjA + drho_dT_dT_v(I) * 0.5 * ( Tsgs2(i,j+1,k-1)-Tsgs2(i,j,k-1) ) + drdjB = drdjB + drho_dT_dT_v(I) * 0.5 * ( Tsgs2(i,j+1,k)-Tsgs2(i,j,k) ) endif if (find_work) drdj_v(i,k) = drdjB From b155bf36b607792c045fcd823095f77981cff8a7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Sep 2020 21:41:27 -0400 Subject: [PATCH 090/103] (*)Correct the use of memory macros for arguments Corrected a number of memory macros that would cause MOM6 to give the wrong answers and probably lead to segmentation faults if global indexing were enabled. Macros like NIMEM_ are intended to be used to support static or dynamic memory in the declaration of ALLOCABLE_ arrays, but instead were being used to define the sizes of arguments in some routines, which would cause these arrays to start at 1, not G%isd, inside these routines. All answers in the MOM6-examples test suite are bitwise identical. --- src/tracer/MOM_tracer_flow_control.F90 | 34 +++++++++++++------------- src/tracer/dye_example.F90 | 8 +++--- src/user/BFB_initialization.F90 | 6 ++--- src/user/SCM_CVMix_tests.F90 | 18 +++++++------- 4 files changed, 33 insertions(+), 33 deletions(-) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 5e9f01c7be..4c7c27c7e6 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -264,7 +264,8 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid !! structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< A structure to parse for !! run-time parameters type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to @@ -332,15 +333,15 @@ end subroutine tracer_flow_control_init !> This subroutine extracts the chlorophyll concentrations from the model state, if possible subroutine get_chl_from_model(Chl_array, G, CS) - real, dimension(NIMEM_,NJMEM_,NKMEM_), & + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(out) :: Chl_array !< The array in which to store the model's !! Chlorophyll-A concentrations in mg m-3. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. if (CS%use_MOM_generic_tracer) then - call MOM_generic_tracer_get('chl','field',Chl_array, CS%MOM_generic_tracer_CSp) + call MOM_generic_tracer_get('chl', 'field', Chl_array, CS%MOM_generic_tracer_CSp) else call MOM_error(FATAL, "get_chl_from_model was called in a configuration "// & "that is unable to provide a sensible model-based value.\n"// & @@ -377,25 +378,24 @@ end subroutine call_tracer_set_forcing !> This subroutine calls all registered tracer column physics subroutines. subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, US, tv, optics, CS, & debug, evap_CFL_limit, minimum_forcing_depth) - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_old !< Layer thickness before entrainment + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Layer thickness before entrainment !! [H ~> m or kg m-2]. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_new !< Layer thickness after entrainment + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Layer thickness after entrainment !! [H ~> m or kg m-2]. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: ea !< an array to which the amount of + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: ea !< an array to which the amount of !! fluid entrained from the layer above during this call !! will be added [H ~> m or kg m-2]. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: eb !< an array to which the amount of + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: eb !< an array to which the amount of !! fluid entrained from the layer below during this call !! will be added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to !! any possible forcing fields. !! Unused fields have NULL ptrs. - real, dimension(NIMEM_,NJMEM_), intent(in) :: Hml !< Mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] real, intent(in) :: dt !< The amount of time covered by this !! call [T ~> s] - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid - !! structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. @@ -542,12 +542,12 @@ end subroutine call_tracer_column_fns subroutine call_tracer_stocks(h, stock_values, G, GV, CS, stock_names, stock_units, & num_stocks, stock_index, got_min_max, global_min, global_max, & xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) - real, dimension(NIMEM_,NJMEM_,NKMEM_), & + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(:), intent(out) :: stock_values !< The integrated amounts of a tracer !! on the current PE, usually in kg x concentration [kg conc]. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to !! call_tracer_register. @@ -725,9 +725,9 @@ end subroutine store_stocks subroutine call_tracer_surface_state(sfc_state, h, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - real, dimension(NIMEM_,NJMEM_,NKMEM_), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 5f2f139899..cd17415b21 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -189,7 +189,7 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary @@ -326,11 +326,11 @@ end subroutine dye_tracer_column_physics !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. function dye_stock(h, stocks, G, GV, CS, names, units, stock_index) - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of - !! each tracer, in kg times concentration units [kg conc]. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of + !! each tracer, in kg times concentration units [kg conc]. type(dye_tracer_CS), pointer :: CS !< The control structure returned by a !! previous call to register_dye_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 9e8f612a35..af77401266 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -86,13 +86,13 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, para type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(sponge_CS), pointer :: CSp !< A pointer to the sponge control structure - real, dimension(NIMEM_, NJMEM_, NKMEM_), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] ! Local variables - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta, in depth units [Z ~> m]. + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for eta, in depth units [Z ~> m]. real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. - real :: H0(SZK_(G)) ! Resting layer thicknesses in depth units [Z ~> m]. + real :: H0(SZK_(GV)) ! Resting layer thicknesses in depth units [Z ~> m]. real :: min_depth ! The minimum ocean depth in depth units [Z ~> m]. real :: slat, wlon, lenlat, lenlon, nlat real :: max_damping ! The maximum damping rate [T-1 ~> s-1] diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index 1bb1b9555e..9f36e7033d 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -53,15 +53,15 @@ module SCM_CVMix_tests !> Initializes temperature and salinity for the SCM CVMix test example subroutine SCM_CVMix_tests_TS_init(T, S, h, G, GV, US, param_file, just_read_params) - real, dimension(NIMEM_,NJMEM_, NKMEM_), intent(out) :: T !< Potential temperature [degC] - real, dimension(NIMEM_,NJMEM_, NKMEM_), intent(out) :: S !< Salinity [psu] - real, dimension(NIMEM_,NJMEM_, NKMEM_), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< Input parameter structure - logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [psu] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Input parameter structure + logical, optional, intent(in) :: just_read_params !< If present and true, this call + !! will only read parameters without changing h. ! Local variables real :: UpperLayerTempMLD !< Upper layer Temp MLD thickness [Z ~> m]. real :: UpperLayerSaltMLD !< Upper layer Salt MLD thickness [Z ~> m]. From 751faaa2b26ceee8393b74228be684e6fac26a6f Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 3 Sep 2020 18:15:17 -0400 Subject: [PATCH 091/103] OBC: segment parser refactoring The segment configuration parser was encountering problems with GFortran 10.2, where the `fields` array update was being removed by the -O2 optimizer. In fact, the `parse_segment_data_str` function was doing two separate operations, where the first call would determine the number of fields and save their names into an array, and the second call would parse the data contents of each input field. The presence of optional arguments were used to effectively select the preferred operation. It is possible that the presence of these optional arguments was interfering with optimization, causing the removal of the `fields` update. While this is most likely a bug in the GFortran compiler, we address the problem by instead splitting this function into two independent functions, which allows us to remove the optional arguments. When split, the function appears to work correctly under O2 optimization. --- src/core/MOM_open_boundary.F90 | 149 +++++++++++++++------------------ 1 file changed, 66 insertions(+), 83 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 37ebeda1fa..d0f7caa0c2 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -669,7 +669,7 @@ subroutine initialize_segment_data(G, OBC, PF) call MOM_error(FATAL, mesg) endif - call parse_segment_data_str(trim(segstr), fields=fields, num_fields=num_fields) + call parse_segment_manifest_str(trim(segstr), num_fields, fields) if (num_fields == 0) then call MOM_mesg('initialize_segment_data: num_fields = 0') cycle ! cycle to next segment @@ -690,7 +690,8 @@ subroutine initialize_segment_data(G, OBC, PF) JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do m=1,num_fields - call parse_segment_data_str(trim(segstr), var=trim(fields(m)), value=value, filenam=filename, fieldnam=fieldname) + call parse_segment_data_str(trim(segstr), m, trim(fields(m)), & + value, filename, fieldname) if (trim(filename) /= 'none') then OBC%update_OBC = .true. ! Data is assumed to be time-dependent if we are reading from file OBC%needs_IO_for_data = .true. ! At least one segment is using I/O for OBC data @@ -1344,92 +1345,73 @@ integer function interpret_int_expr(string, imax) end function interpret_int_expr end subroutine parse_segment_str -!> Parse an OBC_SEGMENT_%%%_DATA string - subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fields, num_fields, debug ) - character(len=*), intent(in) :: segment_str !< A string in form of - !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." - character(len=*), optional, intent(in) :: var !< The name of the variable for which parameters are needed - character(len=*), optional, intent(out) :: filenam !< The name of the input file if using "file" method - character(len=*), optional, intent(out) :: fieldnam !< The name of the variable in the input file if using - !! "file" method - real, optional, intent(out) :: value !< A constant value if using the "value" method - character(len=*), dimension(MAX_OBC_FIELDS), & - optional, intent(out) :: fields !< List of fieldnames for each segment - integer, optional, intent(out) :: num_fields !< The number of fields in the segment data - logical, optional, intent(in) :: debug !< If present and true, write verbose debugging messages - ! Local variables - character(len=128) :: word1, word2, word3, method - integer :: lword, nfields, n, m - logical :: continue,dbg - character(len=32), dimension(MAX_OBC_FIELDS) :: flds - nfields=0 - continue=.true. - dbg=.false. - if (PRESENT(debug)) dbg=debug +!> Parse an OBC_SEGMENT_%%%_DATA string and determine its fields +subroutine parse_segment_manifest_str(segment_str, num_fields, fields) + character(len=*), intent(in) :: segment_str !< A string in form of + !< "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." + integer, intent(out) :: num_fields !< The number of fields in the segment data + character(len=*), dimension(MAX_OBC_FIELDS), intent(out) :: fields + !< List of fieldnames for each segment - do while (continue) - word1 = extract_word(segment_str,',',nfields+1) - if (trim(word1) == '') exit - nfields=nfields+1 - word2 = extract_word(word1,'=',1) - flds(nfields) = trim(word2) - enddo - - if (PRESENT(fields)) then - do n=1,nfields - fields(n) = flds(n) - enddo - endif + ! Local variables + character(len=128) :: word1, word2 + + num_fields = 0 + do + word1 = extract_word(segment_str, ',', num_fields+1) + if (trim(word1) == '') exit + num_fields = num_fields + 1 + word2 = extract_word(word1, '=', 1) + fields(num_fields) = trim(word2) + enddo +end subroutine parse_segment_manifest_str - if (PRESENT(num_fields)) then - num_fields=nfields - return - endif - m=0 - if (PRESENT(var)) then - do n=1,nfields - if (trim(var)==trim(flds(n))) then - m=n - exit - endif - enddo - if (m==0) then - call abort() - endif +!> Parse an OBC_SEGMENT_%%%_DATA string +subroutine parse_segment_data_str(segment_str, idx, var, value, filename, fieldname) + character(len=*), intent(in) :: segment_str !< A string in form of + !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." + integer, intent(in) :: idx !< Index of segment_str record + character(len=*), intent(in) :: var !< The name of the variable for which parameters are needed + character(len=*), intent(out) :: filename !< The name of the input file if using "file" method + character(len=*), intent(out) :: fieldname !< The name of the variable in the input file if using + !! "file" method + real, optional, intent(out) :: value !< A constant value if using the "value" method - ! Process first word which will start with the fieldname - word3 = extract_word(segment_str,',',m) - word1 = extract_word(word3,':',1) -! if (trim(word1) == '') exit - word2 = extract_word(word1,'=',1) - if (trim(word2) == trim(var)) then - method=trim(extract_word(word1,'=',2)) - lword=len_trim(method) - if (method(lword-3:lword) == 'file') then - ! raise an error id filename/fieldname not in argument list - word1 = extract_word(word3,':',2) - filenam = extract_word(word1,'(',1) - fieldnam = extract_word(word1,'(',2) - lword=len_trim(fieldnam) - fieldnam = fieldnam(1:lword-1) ! remove trailing parenth - value=-999. - elseif (method(lword-4:lword) == 'value') then - filenam = 'none' - fieldnam = 'none' - word1 = extract_word(word3,':',2) - lword=len_trim(word1) - read(word1(1:lword),*,end=986,err=987) value - endif - endif + ! Local variables + character(len=128) :: word1, word2, word3, method + integer :: lword + + ! Process first word which will start with the fieldname + word3 = extract_word(segment_str, ',', idx) + word1 = extract_word(word3, ':', 1) + !if (trim(word1) == '') exit + word2 = extract_word(word1, '=', 1) + if (trim(word2) == trim(var)) then + method = trim(extract_word(word1, '=', 2)) + lword = len_trim(method) + if (method(lword-3:lword) == 'file') then + ! raise an error id filename/fieldname not in argument list + word1 = extract_word(word3, ':', 2) + filename = extract_word(word1, '(', 1) + fieldname = extract_word(word1, '(', 2) + lword = len_trim(fieldname) + fieldname = fieldname(1:lword-1) ! remove trailing parenth + value = -999. + elseif (method(lword-4:lword) == 'value') then + filename = 'none' + fieldname = 'none' + word1 = extract_word(word3, ':', 2) + lword = len_trim(word1) + read(word1(1:lword), *, end=986, err=987) value endif + endif - return - 986 call MOM_error(FATAL,'End of record while parsing segment data specification! '//trim(segment_str)) - 987 call MOM_error(FATAL,'Error while parsing segment data specification! '//trim(segment_str)) - - end subroutine parse_segment_data_str + return +986 call MOM_error(FATAL,'End of record while parsing segment data specification! '//trim(segment_str)) +987 call MOM_error(FATAL,'Error while parsing segment data specification! '//trim(segment_str)) +end subroutine parse_segment_data_str !> Parse all the OBC_SEGMENT_%%%_DATA strings again @@ -1458,12 +1440,13 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) call get_param(PF, mdl, segnam, segstr) if (segstr == '') cycle - call parse_segment_data_str(trim(segstr), fields=fields, num_fields=num_fields) + call parse_segment_manifest_str(trim(segstr), num_fields, fields) if (num_fields == 0) cycle ! At this point, just search for TEMP and SALT as tracers 1 and 2. do m=1,num_fields - call parse_segment_data_str(trim(segstr), var=trim(fields(m)), value=value, filenam=filename, fieldnam=fieldname) + call parse_segment_data_str(trim(segstr), m, trim(fields(m)), & + value, filename, fieldname) if (trim(filename) /= 'none') then if (fields(m) == 'TEMP') then if (segment%is_E_or_W_2) then From edff25e02a920a8058af7b8d40ced0311b121912 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 4 Sep 2020 18:09:16 -0400 Subject: [PATCH 092/103] Rename intermediate variable in Stanley PGF parameterization - A variable was poorly named and also changed units mid-stream. The newly named variable now only has the same units ever. --- src/core/MOM_PressureForce_FV.F90 | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 942c29854e..03d2c807a7 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -480,8 +480,11 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. - real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stencil of T [degC or degC2] - real :: Hl(5), mn_H ! Copy of local stencil of H [H ~> m] + real :: Tl(5) ! copy and T in local stencil [degC] + real :: mn_T ! mean of T in local stencil [degC] + real :: mn_T2 ! mean of T**2 in local stencil [degC] + real :: hl(5) ! Copy of local stencil of H [H ~> m] + real :: r_sm_H ! Reciprocal of sum of H in local stencil [H-1 ~> m-1] real, parameter :: C1_6 = 1.0/6.0 integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb @@ -529,17 +532,16 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) - mn_H = ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff - mn_H = 1. / mn_H ! Hereafter, mn_H is the reciprocal of mean h for the stencil + r_sm_H = 1. / ( ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff ) ! Mean of T Tl(1) = tv%T(i,j,k) ; Tl(2) = tv%T(i-1,j,k) ; Tl(3) = tv%T(i+1,j,k) Tl(4) = tv%T(i,j-1,k) ; Tl(5) = tv%T(i,j+1,k) - mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * mn_H + mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * r_sm_H ! Adjust T vectors to have zero mean Tl(:) = Tl(:) - mn_T ; mn_T = 0. ! Variance of T mn_T2 = ( hl(1)*Tl(1)*Tl(1) + ( ( hl(2)*Tl(2)*Tl(2) + hl(3)*Tl(3)*Tl(3) ) & - + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * mn_H + + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * r_sm_H ! Variance should be positive but round-off can violate this. Calculating ! variance directly would fix this but requires more operations. tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * max(0., mn_T2 - mn_T*mn_T) From 4ac556c63443b59999570d07437db31a2d4d0bd2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 8 Sep 2020 08:47:02 -0400 Subject: [PATCH 093/103] Properly set vertex_shear in set_diffusivity_init Always call kappa_shear_at_vertex so that the Vertex_shear element of the control structure for the MOM_set_diffusivity module is always actively set. It had previously been initialized only if USE_JACKSON_PARAM is true, which led to the issues reported in MOM6 issue #1201. Also clarified or corrected some of the comments in MOM_kappa_shear. All answers will be bitwise identical in all cases that worked previously, and this PR corrects the problems noted in issue #1201, which can closed once it is accepted. --- .../vertical/MOM_kappa_shear.F90 | 22 ++++++++++++------- .../vertical/MOM_set_diffusivity.F90 | 2 +- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 3ba3d2b74c..9705b36543 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -656,6 +656,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & optional, intent(out) :: dz_Int_1d !< The extent of a finite-volume space surrounding an interface, !! as used in calculating kappa and TKE [Z ~> m]. + ! Local variables real, dimension(nzc) :: & u, & ! The zonal velocity after a timestep of mixing [L T-1 ~> m s-1]. v, & ! The meridional velocity after a timestep of mixing [L T-1 ~> m s-1]. @@ -1231,7 +1232,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & real, dimension(nz+1), optional, & intent(out) :: local_src !< The sum of all local sources for kappa, !! [T-1 ~> s-1]. -! This subroutine calculates new, consistent estimates of TKE and kappa. + ! This subroutine calculates new, consistent estimates of TKE and kappa. ! Local variables real, dimension(nz) :: & @@ -1756,7 +1757,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & end subroutine find_kappa_tke -!> This subroutineinitializesthe parameters that regulate shear-driven mixing +!> This subroutine initializes the parameters that regulate shear-driven mixing function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< The current model time. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -1943,25 +1944,30 @@ end function kappa_shear_init !! parameterization will be used without needing to duplicate the log entry. logical function kappa_shear_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! Reads the parameter "USE_JACKSON_PARAM" and returns state. + + ! Local variables character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. + ! This function reads the parameter "USE_JACKSON_PARAM" and returns its value. call get_param(param_file, mdl, "USE_JACKSON_PARAM", kappa_shear_is_used, & default=.false., do_not_log=.true.) end function kappa_shear_is_used -!> This function indicates to other modules whether the Jackson et al shear mixing -!! parameterization will be used without needing to duplicate the log entry. +!> This function indicates to other modules whether the Jackson et al shear mixing parameterization +!! will be used at the vertices without needing to duplicate the log entry. It returns false if +!! the Jackson et al scheme is not used or if it is used via calculations at the tracer points. logical function kappa_shear_at_vertex(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! Reads the parameter "USE_JACKSON_PARAM" and returns state. - character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. + ! Local variables + character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. logical :: do_kappa_shear + ! This function returns true only if the parameters "USE_JACKSON_PARAM" and "VERTEX_SHEAR" are both true. + + kappa_shear_at_vertex = .false. call get_param(param_file, mdl, "USE_JACKSON_PARAM", do_kappa_shear, & default=.false., do_not_log=.true.) - kappa_shear_at_vertex = .false. if (do_Kappa_Shear) & call get_param(param_file, mdl, "VERTEX_SHEAR", kappa_shear_at_vertex, & "If true, do the calculations of the shear-driven mixing "//& diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 42babae7d8..b81cf62631 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -2219,7 +2219,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "Bryan-Lewis and internal tidal dissipation are both enabled. Choose one.") CS%useKappaShear = kappa_shear_init(Time, G, GV, US, param_file, CS%diag, CS%kappaShear_CSp) - if (CS%useKappaShear) CS%Vertex_Shear = kappa_shear_at_vertex(param_file) + CS%Vertex_Shear = kappa_shear_at_vertex(param_file) if (CS%useKappaShear) & id_clock_kappaShear = cpu_clock_id('(Ocean kappa_shear)', grain=CLOCK_MODULE) From 7ae514ee905940025acac522b9da6c2ce2a2ffc4 Mon Sep 17 00:00:00 2001 From: jkenigson Date: Wed, 9 Sep 2020 17:05:56 -0600 Subject: [PATCH 094/103] Moved variable declarations to correct subroutine! --- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index d338785406..7931ba2143 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -158,8 +158,6 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp real :: hv(SZI_(G), SZJ_(G)) ! v-thickness [H ~> m or kg m-2] real :: KH_u_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] real :: KH_v_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] - real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stencil of T [degC or degC2] - real :: Hl(5), mn_H ! Copy of local stencil of H [H ~> m] if (.not. associated(CS)) call MOM_error(FATAL, "MOM_thickness_diffuse: "//& "Module must be initialized before it is used.") @@ -691,6 +689,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV logical :: use_Stanley integer :: is, ie, js, je, nz, IsdB, halo integer :: i, j, k + real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stencil of T [degC or degC2] + real :: Hl(5), mn_H ! Copy of local stencil of H [H ~> m] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ; IsdB = G%IsdB I4dt = 0.25 / dt From b67d3c6bcdf5533070cc91d93f099e1cd1db3bec Mon Sep 17 00:00:00 2001 From: Jessica Kenigson Date: Wed, 9 Sep 2020 20:33:44 -0600 Subject: [PATCH 095/103] Fixed a typo in variable name --- .gitmodules | 6 ++++++ pkg/geoKdTree | 1 + pkg/mom6_da_hooks | 1 + src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 2 +- 4 files changed, 9 insertions(+), 1 deletion(-) create mode 160000 pkg/geoKdTree create mode 160000 pkg/mom6_da_hooks diff --git a/.gitmodules b/.gitmodules index 637f1188ed..fcddebca83 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,3 +4,9 @@ [submodule "pkg/GSW-Fortran"] path = pkg/GSW-Fortran url = https://github.com/TEOS-10/GSW-Fortran.git +[submodule "pkg/geoKdTree"] + path = pkg/geoKdTree + url = https://github.com/travissluka/geoKdTree.git +[submodule "pkg/mom6_da_hooks"] + path = pkg/mom6_da_hooks + url = https://github.com/NOAA-GFDL/MOM6_DA_hooks.git diff --git a/pkg/geoKdTree b/pkg/geoKdTree new file mode 160000 index 0000000000..f8ac844ac5 --- /dev/null +++ b/pkg/geoKdTree @@ -0,0 +1 @@ +Subproject commit f8ac844ac558979e43697a6f5e7d9305efea088e diff --git a/pkg/mom6_da_hooks b/pkg/mom6_da_hooks new file mode 160000 index 0000000000..9c930afc5e --- /dev/null +++ b/pkg/mom6_da_hooks @@ -0,0 +1 @@ +Subproject commit 9c930afc5e2c4f86085476f524fc71dec321f68b diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 7931ba2143..d4530ebb2d 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -778,7 +778,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * mn_H ! Variance should be positive but round-off can violate this. Calculating ! variance directly would fix this but requires more operations. - Tsgs2(i,j,k) = CS%Stanley_T2_det_coeff * max(0., mn_T2) + Tsgs2(i,j,k) = CS%Stanley_det_coeff * max(0., mn_T2) enddo ; enddo ; enddo endif !$OMP do From 3ce4172b6ddb16f658b834e535e353d1c5c4d9ab Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 10 Sep 2020 23:33:37 -0800 Subject: [PATCH 096/103] Clean up pass_var for tracer reservoirs. --- src/core/MOM_open_boundary.F90 | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index d0f7caa0c2..2320c7d78a 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1588,10 +1588,18 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) if (OBC%oblique_BCs_exist_globally) call pass_vector(OBC%rx_oblique, OBC%ry_oblique, G%Domain, & To_All+Scalar_Pair) if (associated(OBC%cff_normal)) call pass_var(OBC%cff_normal, G%Domain, position=CORNER) - if (associated(OBC%tres_x) .or. associated(OBC%tres_y)) then + if (associated(OBC%tres_x) .and. associated(OBC%tres_y)) then do m=1,OBC%ntr call pass_vector(OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%Domain, To_All+Scalar_Pair) enddo + elseif (associated(OBC%tres_x)) then + do m=1,OBC%ntr + call pass_var(OBC%tres_x(:,:,:,m), G%Domain, position=EAST_FACE) + enddo + elseif (associated(OBC%tres_y)) then + do m=1,OBC%ntr + call pass_var(OBC%tres_y(:,:,:,m), G%Domain, position=NORTH_FACE) + enddo endif ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid @@ -4717,8 +4725,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart endif ! Still painfully inefficient, now in four dimensions. - ! Allocating both for now so that the pass_vector works. - if (any(OBC%tracer_x_reservoirs_used) .or. any(OBC%tracer_y_reservoirs_used)) then + if (any(OBC%tracer_x_reservoirs_used)) then allocate(OBC%tres_x(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke,OBC%ntr)) OBC%tres_x(:,:,:,:) = 0.0 do m=1,OBC%ntr @@ -4734,8 +4741,8 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart endif endif enddo -! endif -! if (any(OBC%tracer_y_reservoirs_used)) then + endif + if (any(OBC%tracer_y_reservoirs_used)) then allocate(OBC%tres_y(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke,OBC%ntr)) OBC%tres_y(:,:,:,:) = 0.0 do m=1,OBC%ntr From 304d0c76e00ec4591d20a02e4c40f64148eb297a Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 11 Sep 2020 18:02:35 +0000 Subject: [PATCH 097/103] Post tracer concentration when synced Tracer concentrations were being posted at the same time as the transport diagnostics. This leads to some unexpected behavior (e.g. SST and 3D temperature are not consistent) because the concentrations are potentially being posted at an intermediate state. In addition to fixing this problem for all tracers, the subroutine has been renamed to be more descriptive of what kinds of diagnostics might fall into this category. --- src/core/MOM.F90 | 4 ++-- src/tracer/MOM_tracer_registry.F90 | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ad9e235b27..5790dc625e 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -100,7 +100,7 @@ module MOM use MOM_tracer_hor_diff, only : tracer_hordiff, tracer_hor_diff_init use MOM_tracer_hor_diff, only : tracer_hor_diff_end, tracer_hor_diff_CS use MOM_tracer_registry, only : tracer_registry_type, register_tracer, tracer_registry_init -use MOM_tracer_registry, only : register_tracer_diagnostics, post_tracer_diagnostics +use MOM_tracer_registry, only : register_tracer_diagnostics, post_tracer_diagnostics_at_sync use MOM_tracer_registry, only : post_tracer_transport_diagnostics use MOM_tracer_registry, only : preALE_tracer_diagnostics, postALE_tracer_diagnostics use MOM_tracer_registry, only : lock_tracer_registry, tracer_registry_end @@ -785,7 +785,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & call calculate_diagnostic_fields(u, v, h, CS%uh, CS%vh, CS%tv, CS%ADp, & CS%CDp, p_surf, CS%t_dyn_rel_diag, CS%diag_pre_sync,& G, GV, US, CS%diagnostics_CSp) - call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, CS%t_dyn_rel_diag) + call post_tracer_diagnostics_at_sync(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, CS%t_dyn_rel_diag) call diag_copy_diag_to_storage(CS%diag_pre_sync, h, CS%diag) if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") call disable_averaging(CS%diag) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 01d15fb887..f1ad26c916 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -29,7 +29,7 @@ module MOM_tracer_registry public register_tracer public MOM_tracer_chksum, MOM_tracer_chkinv -public register_tracer_diagnostics, post_tracer_diagnostics, post_tracer_transport_diagnostics +public register_tracer_diagnostics, post_tracer_diagnostics_at_sync, post_tracer_transport_diagnostics public preALE_tracer_diagnostics, postALE_tracer_diagnostics public tracer_registry_init, lock_tracer_registry, tracer_registry_end public tracer_name_lookup @@ -630,9 +630,9 @@ subroutine postALE_tracer_diagnostics(Reg, G, GV, diag, dt) end subroutine postALE_tracer_diagnostics -!> post_tracer_diagnostics does post_data calls for any diagnostics that are -!! being handled via the tracer registry. -subroutine post_tracer_diagnostics(Reg, h, diag_prev, diag, G, GV, dt) +!> Post tracer diganostics when that should only be posted when MOM's state +!! is self-consistent (also referred to as 'synchronized') subroutine +post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry @@ -656,6 +656,7 @@ subroutine post_tracer_diagnostics(Reg, h, diag_prev, diag, G, GV, dt) call diag_copy_storage_to_diag(diag, diag_prev) do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then Tr => Reg%Tr(m) + if (Tr%id_tr > 0) call post_data(Tr%id_tr, Tr%t, diag) if (Tr%id_tendency > 0) then work3d(:,:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie @@ -681,7 +682,7 @@ subroutine post_tracer_diagnostics(Reg, h, diag_prev, diag, G, GV, dt) endif ; enddo call diag_restore_grids(diag) -end subroutine post_tracer_diagnostics +end subroutine post_tracer_diagnostics_at_sync !> Post the advective and diffusive tendencies subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) @@ -700,7 +701,6 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then Tr => Reg%Tr(m) - if (Tr%id_tr > 0) call post_data(Tr%id_tr, Tr%t, diag) if (Tr%id_adx > 0) call post_data(Tr%id_adx, Tr%ad_x, diag, alt_h=h_diag) if (Tr%id_ady > 0) call post_data(Tr%id_ady, Tr%ad_y, diag, alt_h=h_diag) if (Tr%id_dfx > 0) call post_data(Tr%id_dfx, Tr%df_x, diag, alt_h=h_diag) From e93c031f1f2b47170f5fa26410d3076a2ed10a48 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 11 Sep 2020 19:10:29 +0000 Subject: [PATCH 098/103] Neglected subroutine in new declaration Careless me left out 'subroutine' in the declaration of post_tracer_diagnostics_at_sync --- src/tracer/MOM_tracer_registry.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index c0281301ff..7ebd7bf917 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -710,7 +710,7 @@ end subroutine postALE_tracer_diagnostics !> Post tracer diganostics when that should only be posted when MOM's state !! is self-consistent (also referred to as 'synchronized') subroutine -post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) +subroutine post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry From 503eaa31dc2b26a3a886567b4461e1f100b39ddf Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 11 Sep 2020 15:10:41 -0400 Subject: [PATCH 099/103] Update MOM_tracer_registry.F90 Corrected an obvious syntax error in a subroutine declaration. --- src/tracer/MOM_tracer_registry.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index c0281301ff..c06846d53b 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -709,8 +709,8 @@ subroutine postALE_tracer_diagnostics(Reg, G, GV, diag, dt) end subroutine postALE_tracer_diagnostics !> Post tracer diganostics when that should only be posted when MOM's state -!! is self-consistent (also referred to as 'synchronized') subroutine -post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) +!! is self-consistent (also referred to as 'synchronized') +subroutine post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry From e45f73f4e163ddf04e9b1451f37613095fec82f2 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 11 Sep 2020 23:59:15 +0000 Subject: [PATCH 100/103] Diagnostic for post-transport tracer concentration Adds a tracer diagnostic for the intermediate state of tracer concentrations right after horizontal transport (advection and diffusion) has occurred. For cases where DIABATIC_FIRST = False, this will definitely not be identical to the tracer concentration diagnostic that is posted when the MOM6 state is 'synchronized' (e.g. all forcing terms within a MOM6 timestep have been calculated and applied). --- src/tracer/MOM_tracer_registry.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index c06846d53b..cb8f1716fe 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -120,7 +120,7 @@ module MOM_tracer_registry integer :: diag_form = 1 !< An integer indicating which template is to be used to label diagnostics. !>@{ Diagnostic IDs - integer :: id_tr = -1 + integer :: id_tr = -1, id_tr_post_horzn = -1 integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 integer :: id_lbd_bulk_dfx = -1, id_lbd_bulk_dfy = -1, id_lbd_dfx = -1, id_lbd_dfy = -1 integer :: id_lbd_dfx_2d = -1 , id_lbd_dfy_2d = -1 @@ -408,6 +408,10 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) cmor_long_name=cmor_longname, cmor_units=Tr%cmor_units, & cmor_standard_name=cmor_long_std(cmor_longname)) endif + Tr%id_tr_post_horzn = register_diag_field("ocean_model", & + trim(name)//"_post_horzn", diag%axesTL, Time, & + trim(longname)//" after horizontal transport (advection/diffusion) "//& + "has occurred", trim(units)) if (Tr%diag_form == 1) then Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, trim(flux_longname)//" advective zonal flux" , & @@ -779,6 +783,7 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then Tr => Reg%Tr(m) + if (Tr%id_tr_post_horzn> 0) call post_data(Tr%id_tr_post_horzn, Tr%t, diag) if (Tr%id_adx > 0) call post_data(Tr%id_adx, Tr%ad_x, diag, alt_h=h_diag) if (Tr%id_ady > 0) call post_data(Tr%id_ady, Tr%ad_y, diag, alt_h=h_diag) if (Tr%id_dfx > 0) call post_data(Tr%id_dfx, Tr%df_x, diag, alt_h=h_diag) From de0c88dd5c38fb1f3594ce3ada7c379c12c7afd8 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 14 Sep 2020 15:53:19 -0400 Subject: [PATCH 101/103] Testing: Warn on new diagnostic in regression This patch attempts to detect if a new diagnostic has been added, which was previously interpreted as a regression. Previously, any diff in chksum_diag between a PR and dev/gfdl was interpreted as a regression. This included new diagnostics, which do not actually change any existing answers. This patch only raises an error (blocking the merge) if there are detected changes in dev/gfdl's chksum_diag. If the diff only reports new lines in chksum_diag from the PR, then it reports in the log as a WARN and reports as a PASS to the CI (currently Travis). This patch also fixes a minor typo in the .restart test ($$* should have been $*). Several Make variables using shell-style brackets {} were also replaced with Make brackets (). --- .testing/Makefile | 49 ++++++++++++++++++++++++++++++++++------------- 1 file changed, 36 insertions(+), 13 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 6f3553a694..f6e0a31b97 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -251,11 +251,13 @@ run.openmp: $(foreach c,$(CONFIGS),work/$(c)/openmp/ocean.stats) # Color highlights for test results RED=\033[0;31m +YELLOW=\033[0;33m GREEN=\033[0;32m RESET=\033[0m DONE=${GREEN}DONE${RESET} PASS=${GREEN}PASS${RESET} +WARN=${YELLOW}WARN${RESET} FAIL=${RED}FAIL${RESET} # Comparison rules @@ -267,18 +269,18 @@ define CMP_RULE @cmp $$^ || !( \ mkdir -p results/$$*; \ (diff $$^ | tee results/$$*/ocean.stats.$(1).diff | head) ; \ - echo -e "${FAIL}: Solutions $$*.$(1) have changed." \ + echo -e "$(FAIL): Solutions $$*.$(1) have changed." \ ) - @echo -e "${PASS}: Solutions $$*.$(1) agree." + @echo -e "$(PASS): Solutions $$*.$(1) agree." .PRECIOUS: $(foreach b,$(2),work/%/$(b)/chksum_diag) %.$(1).diag: $(foreach b,$(2),work/%/$(b)/chksum_diag) @cmp $$^ || !( \ mkdir -p results/$$*; \ (diff $$^ | tee results/$$*/chksum_diag.$(1).diff | head) ; \ - echo -e "${FAIL}: Diagnostics $$*.$(1).diag have changed." \ + echo -e "$(FAIL): Diagnostics $$*.$(1).diag have changed." \ ) - @echo -e "${PASS}: Diagnostics $$*.$(1).diag agree." + @echo -e "$(PASS): Diagnostics $$*.$(1).diag agree." endef $(eval $(call CMP_RULE,grid,symmetric asymmetric)) @@ -288,7 +290,7 @@ $(eval $(call CMP_RULE,repro,symmetric repro)) $(eval $(call CMP_RULE,openmp,symmetric openmp)) $(eval $(call CMP_RULE,nan,symmetric nan)) $(foreach d,$(DIMS),$(eval $(call CMP_RULE,dim.$(d),symmetric dim.$(d)))) -$(eval $(call CMP_RULE,regression,symmetric target)) +#$(eval $(call CMP_RULE,regression,symmetric target)) # Custom comparison rules @@ -298,13 +300,34 @@ $(eval $(call CMP_RULE,regression,symmetric target)) @cmp $(foreach f,$^,<(tr -s ' ' < $(f) | cut -d ' ' -f3- | tail -n 1)) \ || !( \ mkdir -p results/$*; \ - (diff $$^ | tee results/$*/chksum_diag.restart.diff | head) ; \ - echo -e "${FAIL}: Solutions $*.restart have changed." \ + (diff $^ | tee results/$*/chksum_diag.restart.diff | head) ; \ + echo -e "$(FAIL): Solutions $*.restart have changed." \ ) - @echo -e "${PASS}: Solutions $*.restart agree." + @echo -e "$(PASS): Solutions $*.restart agree." # TODO: chksum_diag parsing of restart files +# stats rule is unchanged, but we cannot use CMP_RULE to generate it. +%.regression: $(foreach b,symmetric target,work/%/$(b)/ocean.stats) + @cmp $^ || !( \ + mkdir -p results/$*; \ + (diff $^ | tee results/$*/ocean.stats.regression.diff | head) ; \ + echo -e "$(FAIL): Solutions $*.regression have changed." \ + ) + @echo -e "$(PASS): Solutions $*.regression agree." + +# Regression testing only checks for changes in existing diagnostics +%.regression.diag: $(foreach b,symmetric target,work/%/$(b)/chksum_diag) + @! diff $^ | grep "^[<>]" | grep "^>" \ + || ! (\ + mkdir -p results/$*; \ + (diff $^ | tee results/$*/chksum_diag.regression.diff | head) ; \ + echo -e "$(FAIL): Diagnostics $*.regression.diag have changed." \ + ) + diff $^ || echo -e "$(WARN): New diagnostics in $<" + @echo -e "$(PASS): Diagnostics $*.regression.diag agree." + + #--- # Test run output files @@ -337,9 +360,9 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 cat std.out | tee ../../../results/$$*/std.$(1).out | tail -20 ; \ cat std.err | tee ../../../results/$$*/std.$(1).err | tail -20 ; \ rm ocean.stats chksum_diag ; \ - echo -e "${FAIL}: $$*.$(1) failed at runtime." \ + echo -e "$(FAIL): $$*.$(1) failed at runtime." \ ) - @echo -e "${DONE}: $$*.$(1); no runtime errors." + @echo -e "$(DONE): $$*.$(1); no runtime errors." if [ $(3) ]; then \ mkdir -p results/$$* ; \ bash <(curl -s https://codecov.io/bash) -n $$@ \ @@ -395,7 +418,7 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 || !( \ cat std1.out | tee ../../../results/$*/std.restart1.out | tail ; \ cat std1.err | tee ../../../results/$*/std.restart1.err | tail ; \ - echo -e "${FAIL}: $*.restart failed at runtime." \ + echo -e "$(FAIL): $*.restart failed at runtime." \ ) # Setup the next inputs cd $(@D) && rm -rf INPUT && mv RESTART INPUT @@ -406,7 +429,7 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 || !( \ cat std2.out | tee ../../../results/$*/std.restart2.out | tail ; \ cat std2.err | tee ../../../results/$*/std.restart2.err | tail ; \ - echo -e "${FAIL}: $*.restart failed at runtime." \ + echo -e "$(FAIL): $*.restart failed at runtime." \ ) # TODO: Restart checksum diagnostics @@ -434,7 +457,7 @@ test.summary: fi; \ false ; \ else \ - echo -e "${PASS}: All tests passed!"; \ + echo -e "$(PASS): All tests passed!"; \ fi From ad84de0928c57eb85a03bf687694807a1bff4f14 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 16 Sep 2020 17:02:04 -0400 Subject: [PATCH 102/103] Correct submodule setup - Commit b67d3c6bcdf5533070cc91d93f099e1cd1db3bec added back two submodules that still exist on the NCAR branch but no longer are used in the GFDL branch and soon will be expunged on the main branch too. This removes the submodules as was done in NOAA_GFDL/MOM6#1139. --- .gitmodules | 6 ------ pkg/geoKdTree | 1 - pkg/mom6_da_hooks | 1 - 3 files changed, 8 deletions(-) delete mode 160000 pkg/geoKdTree delete mode 160000 pkg/mom6_da_hooks diff --git a/.gitmodules b/.gitmodules index fcddebca83..637f1188ed 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,9 +4,3 @@ [submodule "pkg/GSW-Fortran"] path = pkg/GSW-Fortran url = https://github.com/TEOS-10/GSW-Fortran.git -[submodule "pkg/geoKdTree"] - path = pkg/geoKdTree - url = https://github.com/travissluka/geoKdTree.git -[submodule "pkg/mom6_da_hooks"] - path = pkg/mom6_da_hooks - url = https://github.com/NOAA-GFDL/MOM6_DA_hooks.git diff --git a/pkg/geoKdTree b/pkg/geoKdTree deleted file mode 160000 index f8ac844ac5..0000000000 --- a/pkg/geoKdTree +++ /dev/null @@ -1 +0,0 @@ -Subproject commit f8ac844ac558979e43697a6f5e7d9305efea088e diff --git a/pkg/mom6_da_hooks b/pkg/mom6_da_hooks deleted file mode 160000 index 9c930afc5e..0000000000 --- a/pkg/mom6_da_hooks +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 9c930afc5e2c4f86085476f524fc71dec321f68b From ac27e44a57488de732af8e3ea8f060666452c7e3 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 16 Sep 2020 17:28:47 -0400 Subject: [PATCH 103/103] Updates units and adds OpenMP directives - Following suggestions from @Hallberg-NOAA for PR #1193, I've copied the more completely-documented declaration lines from PressureForce_FV_Bouss() to thickness_diffuse_full(). - Similarly to the other module made a change of an intermediate variable to its reciprocal. - Corrected missing OpenMP directives for some local variables. --- .../lateral/MOM_thickness_diffuse.F90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index d4530ebb2d..3de7b0121b 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -675,7 +675,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver ! times unit conversion factors [T-2 L2 Z-2 ~> s-2] - real :: dTdi2, dTdj2 ! pot. temp. differences, squared. + real :: Tl(5) ! copy and T in local stencil [degC] + real :: mn_T ! mean of T in local stencil [degC] + real :: mn_T2 ! mean of T**2 in local stencil [degC] + real :: hl(5) ! Copy of local stencil of H [H ~> m] + real :: r_sm_H ! Reciprocal of sum of H in local stencil [H-1 ~> m-1] real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: Tsgs2 ! Sub-grid temperature variance [degC2] real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: diag_sfn_x, diag_sfn_unlim_x ! Diagnostics @@ -689,8 +693,6 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV logical :: use_Stanley integer :: is, ie, js, je, nz, IsdB, halo integer :: i, j, k - real :: Tl(5), mn_T, mn_T2 ! copy and moment of local stencil of T [degC or degC2] - real :: Hl(5), mn_H ! Copy of local stencil of H [H ~> m] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ; IsdB = G%IsdB I4dt = 0.25 / dt @@ -732,7 +734,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, use_Stanley, & !$OMP CS,G,GV,tv,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v,Tsgs2,T, & !$OMP diag_sfn_x, diag_sfn_y, diag_sfn_unlim_x, diag_sfn_unlim_y ) & -!$OMP private(dTdi2,dTdj2) +!$OMP private(hl,r_sm_H,Tl,mn_T,mn_T2) ! Find the maximum and minimum permitted streamfunction. !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 @@ -765,17 +767,16 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) - mn_H = ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff - mn_H = 1. / mn_H ! Hereafter, mn_H is the reciprocal of mean h for the stencil + r_sm_H = 1. / ( ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff ) ! Mean of T Tl(1) = T(i,j,k) ; Tl(2) = T(i-1,j,k) ; Tl(3) = T(i+1,j,k) Tl(4) = T(i,j-1,k) ; Tl(5) = T(i,j+1,k) - mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * mn_H + mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * r_sm_H ! Adjust T vectors to have zero mean Tl(:) = Tl(:) - mn_T ; mn_T = 0. ! Variance of T mn_T2 = ( hl(1)*Tl(1)*Tl(1) + ( ( hl(2)*Tl(2)*Tl(2) + hl(3)*Tl(3)*Tl(3) ) & - + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * mn_H + + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * r_sm_H ! Variance should be positive but round-off can violate this. Calculating ! variance directly would fix this but requires more operations. Tsgs2(i,j,k) = CS%Stanley_det_coeff * max(0., mn_T2)