FV3: this commit #refs 47097

Change-Id: I7929ed4f709626cb1f8f9781aa10ed5f6dcefb05

atmos_cubed_sphere/driver/fvGFS/DYCORE_typedefs.F90

@@ -83,8 +83,8 @@ module DYCORE_typedefs
     real(kind=r8_kind)  :: fcst_hour      !< current forecast hour (same as fhour)
     type(var_subtype), allocatable :: data(:) !< holds pointers to data in packed format (allocated to nblks)
     contains
-      procedure create => diag_create
-      procedure zero   => diag_zero
+      procedure :: create => diag_create
+      procedure :: zero   => diag_zero
   end type DYCORE_diag_type
 
 

atmos_cubed_sphere/driver/fvGFS/atmosphere.F90

@@ -912,7 +912,7 @@ subroutine atmosphere_nggps_diag (Time, init)
    logical, optional, intent(in) :: init
 
    if (PRESENT(init)) then
-     if (init == .true.) then
+     if (init) then
        call fv_nggps_diag_init(Atm(mytile:mytile), Atm(mytile)%atmos_axes, Time)
        return
      else

atmos_cubed_sphere/driver/fvGFS/fv_nggps_diag.F90

@@ -606,9 +606,9 @@ subroutine fv_dyn_bundle_setup(axes, dyn_bundle, fcst_grid, quilting )
 !*** add global attributes in the field bundle:
    call ESMF_AttributeAdd(dyn_bundle, convention="NetCDF", purpose="FV3", &
      attrList=(/"hydrostatic", &
-                 "ncnsto    ", &
-                 "ak        ", &
-                 "bk        "/), rc=rc)
+                "ncnsto     ", &
+                "ak         ", &
+                "bk         "/), rc=rc)
    if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
      line=__LINE__, &
      file=__FILE__)) &
@@ -693,21 +693,63 @@ subroutine fv_dyn_bundle_setup(axes, dyn_bundle, fcst_grid, quilting )
      if( id>2 ) then
 !      if(mpp_pe()==mpp_root_pe())print *,' in dyn add grid, axis_name=',     &
 !         trim(axis_name(id)),'axis_data=',axis_data
-      if(trim(edgesS)/='') then
-        call ESMF_AttributeAdd(fcst_grid, convention="NetCDF", purpose="FV3",  &
-          attrList=(/trim(axis_name(id)),trim(axis_name(id))//":long_name",    &
-                    trim(axis_name(id))//":units", trim(axis_name(id))//":cartesian_axis", &
-                    trim(axis_name(id))//":positive", trim(axis_name(id))//":edges"/), rc=rc)
-      else
-        call ESMF_AttributeAdd(fcst_grid, convention="NetCDF", purpose="FV3",  &
-          attrList=(/trim(axis_name(id)),trim(axis_name(id))//":long_name",    &
-                    trim(axis_name(id))//":units", trim(axis_name(id))//":cartesian_axis", &
-                    trim(axis_name(id))//":positive"/), rc=rc)
-      endif
+!
+! Previous definition using variable-length character arrays violates the Fortran standards.
+! While this worked with Intel compilers, it caused the model to crash in different places
+! with both GNU and PGI. Compilers should throw an error at compile time, but it seems that
+! they can't handle the "trim(...) // ..." expressions.
+! The Standard (Fortran 2003) way to do this correctly is to tell the array constructor
+! how long to make the fixed array of characters:
+!
+!   call ESMF_AttributeAdd(fcst_grid, convention="NetCDF", purpose="FV3", &
+!   attrList=(/ character(128) :: trim(axis_name(id)),trim(axis_name(id))//":long_name", &
+!             trim(axis_name(id))//":units", trim(axis_name(id))//":cartesian_axis", &
+!             trim(axis_name(id))//":positive", trim(axis_name(id))//":edges"/), rc=rc)
+!
+! However this fails for GNU and PGI, see https://gcc.gnu.org/bugzilla/show_bug.cgi?id=85547
+! The easiest and safest way forward is to define the attributes one by one as it is done
+! as it is done below in add_field_to_bundle.
+!
+      ! Add attributes one by one
+      call ESMF_AttributeAdd(fcst_grid, convention="NetCDF", purpose="FV3",  &
+        attrList=(/trim(axis_name(id))/), rc=rc)
+      if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
+        line=__LINE__, &
+        file=__FILE__)) &
+        return  ! bail out
+      call ESMF_AttributeAdd(fcst_grid, convention="NetCDF", purpose="FV3",  &
+        attrList=(/trim(axis_name(id))//":long_name"/), rc=rc)
+      if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
+        line=__LINE__, &
+        file=__FILE__)) &
+        return  ! bail out
+      call ESMF_AttributeAdd(fcst_grid, convention="NetCDF", purpose="FV3",  &
+        attrList=(/trim(axis_name(id))//":units"/), rc=rc)
+      if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
+        line=__LINE__, &
+        file=__FILE__)) &
+        return  ! bail out
+      call ESMF_AttributeAdd(fcst_grid, convention="NetCDF", purpose="FV3",  &
+        attrList=(/trim(axis_name(id))//":cartesian_axis"/), rc=rc)
+      if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
+        line=__LINE__, &
+        file=__FILE__)) &
+        return  ! bail out
+      call ESMF_AttributeAdd(fcst_grid, convention="NetCDF", purpose="FV3",  &
+        attrList=(/trim(axis_name(id))//":positive"/), rc=rc)
       if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
         line=__LINE__, &
         file=__FILE__)) &
         return  ! bail out
+      if(trim(edgesS)/='') then
+        call ESMF_AttributeAdd(fcst_grid, convention="NetCDF", purpose="FV3",  &
+          attrList=(/trim(axis_name(id))//":edges"/), rc=rc)
+        if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
+          line=__LINE__, &
+          file=__FILE__)) &
+          return  ! bail out
+      endif
+      ! Set attributes
       call ESMF_AttributeSet(fcst_grid, convention="NetCDF", purpose="FV3", &
         name=trim(axis_name(id)), valueList=axis_data, rc=rc)
       if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &

atmos_cubed_sphere/makefile

@@ -94,6 +94,10 @@ $(LIBRARY): $(OBJS)
 ./driver/fvGFS/fv_nggps_diag.o : ./driver/fvGFS/fv_nggps_diag.F90
 	$(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c $< -o $@
 
+# additional include files (ESMF_INC) needed for PGI
+./driver/fvGFS/atmosphere.o : ./driver/fvGFS/atmosphere.F90
+	$(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) $(OTHER_FFLAGS) $(ESMF_INC) -c $< -o $@
+
 .PHONY: clean
 clean:
 	@echo "Cleaning fv3core ... "

atmos_cubed_sphere/tools/fv_diagnostics.F90

@@ -2476,10 +2476,8 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
 
           allocate(var2(isc:iec,jsc:jec))
           allocate(a3(isc:iec,jsc:jec,npz))
-
-          call eqv_pot(a3, Atm(n)%pt, Atm(n)%delp, Atm(n)%delz, Atm(n)%peln, Atm(n)%pkz, Atm(n)%q(isd,jsd,1,sphum),    &
-               isc, iec, jsc, jec, ngc, npz, Atm(n)%flagstruct%hydrostatic, Atm(n)%flagstruct%moist_phys)
-
+          call eqv_pot(a3, Atm(n)%pt, Atm(n)%delp, Atm(n)%delz, Atm(n)%peln, Atm(n)%pkz, Atm(n)%q(isd:ied,jsd:jed,1:npz,sphum), &
+                       isc, iec, jsc, jec, ngc, npz, Atm(n)%flagstruct%hydrostatic, Atm(n)%flagstruct%moist_phys)
 
 !$OMP parallel do default(shared)
           do j=jsc,jec
@@ -2545,7 +2543,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq)
             used=send_data(idiag%id_pmaskv2, a2, Time)
        endif
 
-       if ( idiag%id_u100m>0 .or. idiag%id_v100m>0 .or.  idiag%id_w100m>0 .or. idiag%id_w5km>0 .or. idiag%id_w2500m>0 .or. idiag%id_w1km>0 .or. idiag%id_basedbz>0 .or. idiag%id_dbz4km>0) then
+       if ( idiag%id_u100m>0 .or. idiag%id_v100m>0 .or. idiag%id_w100m>0 .or. idiag%id_w5km>0 .or. idiag%id_w2500m>0 .or. idiag%id_w1km>0 .or. idiag%id_basedbz>0 .or. idiag%id_dbz4km>0) then
           if (.not.allocated(wz)) allocate ( wz(isc:iec,jsc:jec,npz+1) )
           if ( Atm(n)%flagstruct%hydrostatic) then
              rgrav = 1. / grav

fms/include/fms_platform.h

@@ -92,8 +92,8 @@
 #define NF_GET_ATT_REAL nf_get_att_double
 #endif
 
-#if defined __CRAYXT_COMPUTE_LINUX_TARGET || defined __GFORTRAN__
-!Cray XT compilers do not support real*16 computation
+#if defined __CRAYXT_COMPUTE_LINUX_TARGET || defined __PGI
+!Cray XT and PGI compilers do not support real*16 computation
 !also known as 128-bit or quad precision
 #define NO_QUAD_PRECISION
 #endif

fms/mpp/affinity.c

@@ -29,9 +29,14 @@
 
 static pid_t gettid(void)
 {
+#ifdef __APPLE__
+  return syscall(SYS_gettid);
+#else
   return syscall(__NR_gettid);
+#endif
 }
 
+#ifndef __APPLE__
 /*
  * Returns this thread's CPU affinity, if bound to a single core,
  * or else -1.
@@ -80,3 +85,4 @@ void set_cpu_affinity( int cpu )
 }
 
 void set_cpu_affinity_(int *cpu) { set_cpu_affinity(*cpu); }	/* Fortran interface */
+#endif

fms/mpp/include/mpp_domains_define.inc

@@ -5234,16 +5234,20 @@ end subroutine check_message_size
     real,    dimension(4*num_contact) :: refineRecv, refineSend
     integer, dimension(4*num_contact) :: rotateSend, rotateRecv, tileSend, tileRecv
     integer                           :: nsend, nrecv, nsend2, nrecv2
-    type(contact_type), dimension(domain%ntiles)            :: eCont, wCont, sCont, nCont
+    type(contact_type), dimension(:), allocatable           :: eCont, wCont, sCont, nCont
     type(overlap_type), dimension(0:size(domain%list(:))-1) :: overlapSend, overlapRecv
     integer                                                 :: unit
 
     if( position .NE. CENTER )  call mpp_error(FATAL,  "mpp_domains_define.inc: " //&
          "routine define_contact_point can only be used to calculate overlapping for cell center.")
 
     ntiles  = domain%ntiles
+    allocate(eCont(1:ntiles))
+    allocate(wCont(1:ntiles))
+    allocate(sCont(1:ntiles))
+    allocate(nCont(1:ntiles))
 
-    eCont(:)%ncontact = 0; 
+    eCont(:)%ncontact = 0
 
     do n = 1, ntiles
        eCont(n)%ncontact = 0; sCont(n)%ncontact = 0; wCont(n)%ncontact = 0; nCont(n)%ncontact = 0;
@@ -5812,6 +5816,11 @@ end subroutine check_message_size
        deallocate(nCont(n)%is2, nCont(n)%ie2, nCont(n)%js2, nCont(n)%je2 )
     end do
 
+    deallocate(eCont)
+    deallocate(wCont)
+    deallocate(sCont)
+    deallocate(nCont)
+
     domain%initialized = .true.
 
 

gfsphysics/GFS_layer/GFS_diagnostics.F90

@@ -715,6 +715,11 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop
 !rab      enddo
 !rab    enddo
 
+! DH gfortran cannot point to members of arrays of derived types such
+! as IntDiag(nb)%topfsw(:)%upfxc (the compilation succeeds, but the
+! pointers do not reference the correct data and the output either
+! contains garbage (Inf, NaN), or the netCDF I/O layer crashes.
+#ifndef __GFORTRAN__
     idx = idx + 1
     ExtDiag(idx)%axes = 2
     ExtDiag(idx)%name = 'sw_upfxc'
@@ -774,6 +779,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop
     do nb = 1,nblks
       ExtDiag(idx)%data(nb)%var2 => IntDiag(nb)%topflw(:)%upfx0
     enddo
+#endif
 
 !--- physics accumulated diagnostics ---
     idx = idx + 1

gfsphysics/GFS_layer/GFS_driver.F90

@@ -443,6 +443,27 @@ subroutine GFS_stochastic_driver (Model, Statein, Stateout, Sfcprop, Coupling, &
     implicit none
 
     !--- interface variables
+! DH* gfortran correctly throws an error if the intent() declarations
+! for arguments differ between the actual routine (here) and the dummy
+! interface routine (IPD_func0d_proc in IPD_typedefs.F90):
+!
+! Error: Interface mismatch in procedure pointer assignment at (1): INTENT mismatch in argument 'control'
+!
+! Since IPD_func0d_proc declares all arguments as intent(inout), we
+! need to do the same here - however, this way we are loosing the
+! valuable information on the actual intent to this routine. *DH
+#ifdef __GFORTRAN__
+    type(GFS_control_type),         intent(inout) :: Model
+    type(GFS_statein_type),         intent(inout) :: Statein
+    type(GFS_stateout_type),        intent(inout) :: Stateout
+    type(GFS_sfcprop_type),         intent(inout) :: Sfcprop
+    type(GFS_coupling_type),        intent(inout) :: Coupling
+    type(GFS_grid_type),            intent(inout) :: Grid
+    type(GFS_tbd_type),             intent(inout) :: Tbd
+    type(GFS_cldprop_type),         intent(inout) :: Cldprop
+    type(GFS_radtend_type),         intent(inout) :: Radtend
+    type(GFS_diag_type),            intent(inout) :: Diag
+#else
     type(GFS_control_type),   intent(in   ) :: Model
     type(GFS_statein_type),   intent(in   ) :: Statein
     type(GFS_stateout_type),  intent(in   ) :: Stateout
@@ -453,6 +474,7 @@ subroutine GFS_stochastic_driver (Model, Statein, Stateout, Sfcprop, Coupling, &
     type(GFS_cldprop_type),   intent(in   ) :: Cldprop
     type(GFS_radtend_type),   intent(in   ) :: Radtend
     type(GFS_diag_type),      intent(inout) :: Diag
+#endif
     !--- local variables
     integer :: k, i
     real(kind=kind_phys) :: upert, vpert, tpert, qpert, qnew,sppt_vwt

gfsphysics/GFS_layer/GFS_physics_driver.F90

@@ -406,6 +406,27 @@ subroutine GFS_physics_driver                                 &
       implicit none
 !
 !  ---  interface variables
+! DH* gfortran correctly throws an error if the intent() declarations
+! for arguments differ between the actual routine (here) and the dummy
+! interface routine (IPD_func0d_proc in IPD_typedefs.F90):
+!
+! Error: Interface mismatch in procedure pointer assignment at (1): INTENT mismatch in argument 'control'
+!
+! Since IPD_func0d_proc declares all arguments as intent(inout), we
+! need to do the same here - however, this way we are loosing the
+! valuable information on the actual intent to this routine. *DH
+#ifdef __GFORTRAN__
+      type(GFS_control_type),         intent(inout) :: Model
+      type(GFS_statein_type),         intent(inout) :: Statein
+      type(GFS_stateout_type),        intent(inout) :: Stateout
+      type(GFS_sfcprop_type),         intent(inout) :: Sfcprop
+      type(GFS_coupling_type),        intent(inout) :: Coupling
+      type(GFS_grid_type),            intent(inout) :: Grid
+      type(GFS_tbd_type),             intent(inout) :: Tbd
+      type(GFS_cldprop_type),         intent(inout) :: Cldprop
+      type(GFS_radtend_type),         intent(inout) :: Radtend
+      type(GFS_diag_type),            intent(inout) :: Diag
+#else
       type(GFS_control_type),         intent(in)    :: Model
       type(GFS_statein_type),         intent(inout) :: Statein
       type(GFS_stateout_type),        intent(inout) :: Stateout
@@ -416,6 +437,7 @@ subroutine GFS_physics_driver                                 &
       type(GFS_cldprop_type),         intent(inout) :: Cldprop
       type(GFS_radtend_type),         intent(inout) :: Radtend
       type(GFS_diag_type),            intent(inout) :: Diag
+#endif
 !
 !  ---  local variables
 

gfsphysics/GFS_layer/GFS_radiation_driver.F90

@@ -1018,6 +1018,27 @@ subroutine GFS_radiation_driver                             &
 
       implicit none
 
+! DH* gfortran correctly throws an error if the intent() declarations
+! for arguments differ between the actual routine (here) and the dummy
+! interface routine (IPD_func0d_proc in IPD_typedefs.F90):
+!
+! Error: Interface mismatch in procedure pointer assignment at (1): INTENT mismatch in argument 'control'
+!
+! Since IPD_func0d_proc declares all arguments as intent(inout), we
+! need to do the same here - however, this way we are loosing the
+! valuable information on the actual intent to this routine. *DH
+#ifdef __GFORTRAN__
+      type(GFS_control_type),         intent(inout) :: Model
+      type(GFS_statein_type),         intent(inout) :: Statein
+      type(GFS_stateout_type),        intent(inout) :: Stateout
+      type(GFS_sfcprop_type),         intent(inout) :: Sfcprop
+      type(GFS_coupling_type),        intent(inout) :: Coupling
+      type(GFS_grid_type),            intent(inout) :: Grid
+      type(GFS_tbd_type),             intent(inout) :: Tbd
+      type(GFS_cldprop_type),         intent(inout) :: Cldprop
+      type(GFS_radtend_type),         intent(inout) :: Radtend
+      type(GFS_diag_type),            intent(inout) :: Diag
+#else
       type(GFS_control_type),         intent(in)    :: Model
       type(GFS_statein_type),         intent(in)    :: Statein
       type(GFS_stateout_type),        intent(inout) :: Stateout
@@ -1028,7 +1049,7 @@ subroutine GFS_radiation_driver                             &
       type(GFS_cldprop_type),         intent(in)    :: Cldprop
       type(GFS_radtend_type),         intent(inout) :: Radtend
       type(GFS_diag_type),            intent(inout) :: Diag
-        
+#endif
 
 ! =================   subprogram documentation block   ================ !
 !                                                                       !