wrfv2_fire/dyn_em/module_positive_definite.F

   1 MODULE module_positive_definite
   2
   3   USE module_wrf_error      ! frame
   4
   5 CONTAINS
   6
   7 SUBROUTINE positive_definite_slab( f,                            &
   8                                    ids, ide, jds, jde, kds, kde, &
   9                                    ims, ime, jms, jme, kms, kme, &
  10                                    its, ite, jts, jte, kts, kte)
  11
  12   IMPLICIT NONE
  13
  14   ! Arguments
  15   INTEGER, INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
  16                             ims, ime, jms, jme, kms, kme, &
  17                             its, ite, jts, jte, kts, kte
  18   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: f
  19
  20   ! Local variables
  21   REAL, DIMENSION(:), ALLOCATABLE :: line
  22   INTEGER :: j, k, i_end, j_end, k_end
  23   REAL :: fmin, ftotal_pre, rftotal_post
  24
  25   ! Initialize variables
  26   i_end = ide-1
  27   j_end = MIN(jte, jde-1)
  28   k_end = kte-1
  29   ! Only do anything if we have to...
  30   IF (ANY(f(ids:i_end,kts:k_end,jts:j_end) < 0.)) THEN
  31      ! number of points in the X direction, not including U-stagger
  32      ALLOCATE(line(ide-ids))
  33      DO j = jts, j_end
  34      DO k = kts, kte-1
  35         !while_lt_0_loop: DO WHILE (ANY(f(ids:i_end,k,j) < 0.))
  36         f_lt_0: IF (ANY(f(ids:i_end,k,j) < 0.)) THEN
  37            line(:) = f(ids:i_end,k,j)
  38            ! This is actually an integration over x assuming dx is constant
  39            ftotal_pre = SUM(line)
  40            ! If the total is negative, set everything to 0. and exit
  41            IF (ftotal_pre < 0.) THEN
  42               line(:) = 0.
  43            ELSE
  44               ! Value to add to array to make sure every element is > 0.
  45               fmin = MINVAL(line)
  46               line(:) = line(:) - fmin ! fmin is negative...
  47               rftotal_post = 1./SUM(line)
  48               line = line*ftotal_pre*rftotal_post
  49               ! The following error can naturally occur on 32-bit machines:
  50               !IF (SUM(line) /= ftotal_pre) THEN
  51               !   write(wrf_err_message,*) 'ERROR: module_positive_definite, ',&
  52               !                            'mismatching sums ',j,k,ftotal_pre,&
  53               !                            SUM(line),fmin,1./rftotal_post
  54               !   write(*,*) line
  55               !   CALL wrf_error_fatal( wrf_err_message )
  56               !END IF
  57            END IF
  58            f(ids:i_end,k,j) = line(:)
  59         END IF f_lt_0
  60         !END DO while_lt_0_loop
  61      END DO
  62      END DO
  63      DEALLOCATE(line)
  64   END IF
  65
  66 END SUBROUTINE positive_definite_slab
  67
  68 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  69
  70 SUBROUTINE positive_definite_sheet( f, f_total, nx, ny )
  71
  72   IMPLICIT NONE
  73
  74   ! Arguments
  75   INTEGER, INTENT(IN   ) :: nx, ny
  76   REAL, DIMENSION( nx, ny ), INTENT(INOUT) :: f
  77   REAL, DIMENSION( ny ), INTENT(IN) :: f_total
  78
  79   ! Local variables
  80   REAL, DIMENSION(:), ALLOCATABLE :: line
  81   INTEGER :: iy
  82   REAL :: fmin, rftotal_post, sum_line
  83   REAL, PARAMETER :: eps = 1.0e-15
  84
  85   ! Only do anything if we have to...
  86   IF (ANY(f < 0.)) THEN
  87      ALLOCATE(line(nx))
  88      DO iy = 1, ny
  89         !while_lt_0_loop: DO WHILE (ANY(f(:,iy) < 0.))
  90         f_lt_0: IF (ANY(f(:,iy) < 0.)) THEN
  91            line(:) = f(:,iy)
  92            ! If the total is negative, set everything to 0. and exit
  93            IF (f_total(iy) < 0.) THEN
  94               line(:) = 0.
  95            ELSE
  96               ! Value to add to array to make sure every element is > 0.
  97               fmin = MINVAL(line)
  98               line(:) = line(:) - fmin ! fmin is negative...
  99               sum_line = SUM(line)
 100               IF(sum_line > eps) THEN
 101                 rftotal_post = 1./sum_line
 102                 line = line*f_total(iy)*rftotal_post
 103               ELSE
 104                 line(:) = 0.
 105               END IF
 106               ! The following error can naturally occur on 32-bit machines:
 107               !IF (SUM(line) /= f_total(iy)) THEN
 108               !   write(wrf_err_message,*) 'ERROR: module_positive_definite, ',&
 109               !                            'mismatching sums ',iy,f_total(iy),  &
 110               !                            SUM(line),fmin,1./rftotal_post
 111               !   write(*,*) line
 112               !   CALL wrf_error_fatal( wrf_err_message )
 113               !END IF
 114            END IF
 115            f(:,iy) = line(:)
 116         END IF f_lt_0
 117         !END DO while_lt_0_loop
 118      END DO
 119      DEALLOCATE(line)
 120   END IF
 121
 122 END SUBROUTINE positive_definite_sheet
 123
 124 END MODULE module_positive_definite