1 | include(dom.inc)
   2 | 
   3 |       SUBROUTINE WSGG_CASE(all_k_abs, WSGG_W, Lb, celldata, nelmts,     &
   4 |      &                     alpha_wsgg, k_wsgg, all_WVNB, all_DWVNB,     &
   5 |      &                     ngg, nallbandes, ieltd, ieltf)
   6 | 
   7 |       USE mod_inout
   8 |       USE mod_pmm
   9 | #ifdef USEPALM
  10 |       USE palmlib
  11 | #endif
  12 | 
  13 |       IMPLICIT NONE
  14 | 
  15 |       include 'dom_constants.h'
  16 | 
  17 | !     IN
  18 |       DOM_INT                          :: nallbandes
  19 |       DOM_INT                          :: ngg, ieltd, ieltf
  20 |       DOM_INT                          :: nelmts
  21 |       DOM_REAL,DIMENSION(nallbandes)   :: all_WVNB,all_DWVNB
  22 |       DOM_REAL,DIMENSION(nelmts)       :: Lb
  23 |       DOM_REAL,DIMENSION(8,nelmts)     :: celldata
  24 |       DOM_REAL,DIMENSION(ngg)          :: k_wsgg
  25 |       DOM_REAL,DIMENSION(6,ngg)        :: alpha_wsgg
  26 | 
  27 | !     OUT
  28 |       DOM_REAL,DIMENSION(ngg,nelmts)   :: all_k_abs
  29 |       DOM_REAL,DIMENSION(ngg,nelmts)   :: WSGG_W
  30 | 
  31 | !     LOCAL
  32 |       DOM_REAL,DIMENSION(ngg,nelmts)   :: local_all_k_abs
  33 |       DOM_REAL,DIMENSION(ngg,nelmts)   :: local_WSGG_W
  34 |       DOM_REAL,DIMENSION(nelmts)       :: K_SOOT, FSK_SOOT
  35 |       DOM_REAL,DIMENSION(ngg)          :: k_absmel
  36 |       DOM_REAL,DIMENSION(nallbandes)   :: F
  37 |       DOM_REAL                         :: blae, planck
  38 |       DOM_REAL                         :: WVNB_SI,DWVNB_SI
  39 |       DOM_INT                          :: ielt, i, ierr
  40 |       DOM_INT                          :: i_bande, n_cl
  41 |       DOM_INT                          :: j_gas,jk_gas
  42 | 
  43 |       WSGG_W          = 0.
  44 |       local_WSGG_W    = 0.
  45 | 
  46 |       local_all_k_abs = 0.
  47 |       all_k_abs       = 0.
  48 |       FSK_SOOT        = 0.
  49 | 
  50 | !     ---------------------------------------------!
  51 | !     Non-homogeneous system or homogeneous system !
  52 | !     ---------------------------------------------!
  53 | 
  54 |       IF (homosyst.eq.'NO') THEN
  55 |         n_cl=ieltf
  56 |       ELSEIF (homosyst.eq.'YES') THEN
  57 |         n_cl=ieltd
  58 |       ENDIF
  59 | 
  60 |       DO ielt=ieltd,n_cl
  61 |         
  62 | !       ---------------------------------!
  63 | !       Mean soot absorption calculation !
  64 | !       ---------------------------------!
  65 | 
  66 |         DO i_bande=1,nallbandes
  67 | 
  68 |           WVNB_SI = 100.*all_WVNB(i_bande)
  69 |           DWVNB_SI= 100.*all_DWVNB(i_bande)
  70 | 
  71 |           F(i_bande)=blae(WVNB_SI,celldata(1,ielt))/(pi*Lb(ielt))*      &
  72 |      &               DWVNB_SI
  73 | 
  74 |           K_SOOT(ielt)=WVNB_SI*5.5*celldata(8,ielt)
  75 | 
  76 |           FSK_SOOT(ielt)=FSK_SOOT(ielt)+F(i_bande)*K_SOOT(ielt)
  77 | 
  78 |         ENDDO
  79 | 
  80 |         FSK_SOOT(ielt) = FSK_SOOT(ielt) / SUM(F)
  81 | 
  82 | !       -----------------------!
  83 | !       Mean kabs and weight w !
  84 | !       -----------------------!
  85 | 
  86 |         DO j_gas=1,ngg
  87 | 
  88 |           local_WSGG_W(j_gas,ielt)     = alpha_wsgg(1,j_gas)
  89 | 
  90 |           DO jk_gas=1,5
  91 | 
  92 |             local_WSGG_W(j_gas,ielt)   = local_WSGG_W(j_gas,ielt)+      &
  93 |      &      alpha_wsgg(jk_gas+1,j_gas)*celldata(1,ielt)**jk_gas
  94 | 
  95 |           ENDDO
  96 | 
  97 |           local_all_k_abs(j_gas,ielt) = k_wsgg(j_gas)*celldata(3,ielt)* &
  98 |      &    celldata(2,ielt)+FSK_SOOT(ielt)/local_WSGG_W(j_gas,ielt)
  99 | 
 100 |         ENDDO
 101 | 
 102 |       ENDDO
 103 | 
 104 |       IF (homosyst.eq.'YES') THEN
 105 |         DO i=ieltd+1,ieltf
 106 |           local_all_k_abs(:,i) = local_all_k_abs(:,ieltd)
 107 |           local_WSGG_W(:,i)    = local_WSGG_W(:,ieltd)
 108 |         ENDDO
 109 |       ENDIF
 110 | 
 111 | !     ------------------------------------------------------!
 112 | !     sending local_all_k_abs....change to a pmm subroutine !
 113 | !     ------------------------------------------------------!
 114 | 
 115 |       CALL MPI_ALLREDUCE(local_all_k_abs, all_k_abs, ngg*nelmts,        &
 116 |      &                   MPI_DOUBLE_PRECISION, MPI_SUM, COMM_PARA ,     &
 117 |      &                   ierr)
 118 | 
 119 |       CALL MPI_ALLREDUCE(local_WSGG_W, WSGG_W, ngg*nelmts,              &
 120 |      &                   MPI_DOUBLE_PRECISION, MPI_SUM, COMM_PARA ,     &
 121 |      &                   ierr)
 122 | 
 123 |       END SUBROUTINE WSGG_CASE