Temperature and source function refinements (#253)

Remove a workaround for PGI Fortran 19 and `present` status; interpolate level temperatures on device.
earth-system-radiation · Dec 18, 2023 · 5ac4d0a · 5ac4d0a
1 parent 93e1062
commit 5ac4d0a
Showing 1 changed file with 31 additions and 34 deletions.
diff --git a/rrtmgp-frontend/mo_gas_optics_rrtmgp.F90 b/rrtmgp-frontend/mo_gas_optics_rrtmgp.F90
@@ -304,30 +304,21 @@ function gas_optics_int(this,                             &
 
     !
     ! Interpolate source function
-    !
-    if(present(tlev)) then
-      !
-      ! present status of optional argument should be passed to source()
-      !   but isn't with PGI 19.10
-      !
-      error_msg = source(this,                               &
-                         ncol, nlay, nband, ngpt,            &
-                         play, plev, tlay, tsfc,             &
-                         jtemp, jpress, jeta, tropo, fmajor, &
-                         sources,                            &
-                         tlev)
-      !$acc exit data delete(tlev)
+    ! present status of optional argument is passed to source()
+    !
+    error_msg = source(this,                               &
+                       ncol, nlay, nband, ngpt,            &
+                       play, plev, tlay, tsfc,             &
+                       jtemp, jpress, jeta, tropo, fmajor, &
+                       sources,                            &
+                       tlev)
+    if(present(tlev)) then   
+      !$acc        exit data      delete(tlev)
       !$omp target exit data map(release:tlev)
-    else
-      error_msg = source(this,                               &
-                         ncol, nlay, nband, ngpt,            &
-                         play, plev, tlay, tsfc,             &
-                         jtemp, jpress, jeta, tropo, fmajor, &
-                         sources)
-    end if
-    !$acc exit data delete(tsfc)
+    end if 
+    !$acc        exit data      delete(tsfc)
     !$omp target exit data map(release:tsfc)
-    !$acc exit data delete(jtemp, jpress, tropo, fmajor, jeta)
+    !$acc        exit data      delete(jtemp, jpress, tropo, fmajor, jeta)
     !$omp target exit data map(release:jtemp, jpress, tropo, fmajor, jeta)
   end function gas_optics_int
   !------------------------------------------------------------------------------------------
@@ -858,7 +849,15 @@ function source(this,                               &
     error_msg = ""
     !
     ! Source function needs temperature at interfaces/levels and at layer centers
+    !   Allocate small local array for tlev unconditionally
     !
+    !$acc        data copyin(sources) copyout( sources%lay_source, sources%lev_source)     &
+    !$acc                             copyout( sources%sfc_source, sources%sfc_source_Jac) & 
+    !$acc              create(tlev_arr)
+    !$omp target data                 map(from:sources%lay_source, sources%lev_source)     &
+    !$omp                             map(from:sources%sfc_source, sources%sfc_source_Jac) &
+    !$omp           map(alloc:tlev_arr)
+
     if (present(tlev)) then
       !   Users might have provided these
       tlev_wk => tlev
@@ -868,32 +867,30 @@ function source(this,                               &
       ! Interpolate temperature to levels if not provided
       !   Interpolation and extrapolation at boundaries is weighted by pressure
       !
+     !$acc                parallel loop gang vector
+     !$omp target teams distribute parallel do simd 
       do icol = 1, ncol
-         tlev_arr(icol,1) = tlay(icol,1) &
+         tlev_arr(icol,1)      = tlay(icol,1) &
                            + (plev(icol,1)-play(icol,1))*(tlay(icol,2)-tlay(icol,1))  &
-              &                                           / (play(icol,2)-play(icol,1))
+                                                          / (play(icol,2)-play(icol,1))
+         tlev_arr(icol,nlay+1) = tlay(icol,nlay)                                                             &
+                                + (plev(icol,nlay+1)-play(icol,nlay))*(tlay(icol,nlay)-tlay(icol,nlay-1))  &
+                                                          / (play(icol,nlay)-play(icol,nlay-1))
       end do
-      do ilay = 2, nlay
+     !$acc                parallel loop gang vector collapse(2) 
+     !$omp target teams distribute parallel do simd collapse(2)
+     do ilay = 2, nlay
         do icol = 1, ncol
            tlev_arr(icol,ilay) = (play(icol,ilay-1)*tlay(icol,ilay-1)*(plev(icol,ilay  )-play(icol,ilay)) &
                                 +  play(icol,ilay  )*tlay(icol,ilay  )*(play(icol,ilay-1)-plev(icol,ilay))) /  &
                                   (plev(icol,ilay)*(play(icol,ilay-1) - play(icol,ilay)))
         end do
       end do
-      do icol = 1, ncol
-         tlev_arr(icol,nlay+1) = tlay(icol,nlay)                                                             &
-                                + (plev(icol,nlay+1)-play(icol,nlay))*(tlay(icol,nlay)-tlay(icol,nlay-1))  &
-                                                                      / (play(icol,nlay)-play(icol,nlay-1))
-      end do
     end if
 
     !-------------------------------------------------------------------
     ! Compute internal (Planck) source functions at layers and levels,
     !  which depend on mapping from spectral space that creates k-distribution.
-    !$acc        data copyin(sources) copyout( sources%lay_source, sources%lev_source) &
-    !$acc                             copyout( sources%sfc_source, sources%sfc_source_Jac)
-    !$omp target data                 map(from:sources%lay_source, sources%lev_source) &
-    !$omp                             map(from:sources%sfc_source, sources%sfc_source_Jac)
 
     !$acc kernels copyout(top_at_1)
     !$omp target map(from:top_at_1)