Changeset 4662 for palm/trunk

Timestamp:

Sep 2, 2020 1:40:38 PM (4 years ago)

Author:

pavelkrc

Message:

Bugfix of LAD in RTM with legacy discretization

File:

• palm/trunk/SOURCE/radiation_model_mod.f90 (modified) (5 diffs)

palm/trunk/SOURCE/radiation_model_mod.f90

@@ -28 +28 @@
 ! -----------------
 ! $Id$
+! Bugfix of LAD in CSF generation in legacy raytracing
+!
+! 4661 2020-09-01 16:00:22Z pavelkrc
 ! Bugfix for rad_angular_discretization = .FALSE.
 !
@@ -6877 +6880 @@
        INTEGER(iwp)        ::  nzptl, nzubl, nzutl
        REAL(wp)            ::  mrl
-       REAL(wp), PARAMETER ::  eps_lad = 1E-10_wp   !< minimum considered nonzero
 #if defined( __parallel )
        INTEGER(iwp), DIMENSION(:), POINTER, SAVE ::  gridsurf_rma   !< fortran pointer, but lower bounds are 1
@@ -6917 +6919 @@
 
                    DO k = nzt+1, 1, -1
-                       IF ( lad_s(k,j,i) > eps_lad )  THEN
+                       IF ( lad_s(k,j,i) > 0.0_wp )  THEN
 !--                        we are at the top of the pcs
                            pct(j,i) = k + k_topo
                            pch(j,i) = k
-                           npcbl = npcbl + 1 + COUNT(lad_s(1:k-1,j,i) > eps_lad)
+                           npcbl = npcbl + COUNT(lad_s(1:k,j,i) > 0.0_wp)
                            EXIT
                        ENDIF
@@ -7031 +7033 @@
 
                    DO k = k_topo + 1, pct(j,i)
-                       IF ( lad_s(k-k_topo,j,i) > eps_lad )  THEN
+                       IF ( lad_s(k-k_topo,j,i) > 0.0_wp )  THEN
                           ipcgb = ipcgb + 1
                           gridpcbl(k,j,i) = ipcgb
@@ -8624 +8626 @@
                 lad_s_target = sub_lad(boxes(1,i),boxes(2,i),boxes(3,i))
 #endif
+                IF ( lad_s_target <= 0.0_wp )  CYCLE  ! under LAD top, but LAD=0
+
                 cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist)