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