1 | include(dom.inc)
   2 | 
   3 |       SUBROUTINE FSCK_CASE(all_k_abs, w, Lb, celldata, nelmts, all_WVNB,  &
   4 |      &                     all_DWVNB, KCO, DCO, KC, DC, KH, DH, ngbands,  &
   5 |      &                     nallbandes, nkabs, 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                          :: nkabs, ieltd, ieltf
  20 |       DOM_INT                          :: nelmts, ngbands
  21 |       DOM_REAL,DIMENSION(14,nallbandes):: KCO,DCO,KC,DC,KH,DH
  22 |       DOM_REAL,DIMENSION(nallbandes)   :: all_WVNB,all_DWVNB
  23 |       DOM_REAL,DIMENSION(nelmts)       :: Lb
  24 |       DOM_REAL,DIMENSION(8,nelmts)     :: celldata
  25 | 
  26 | !     OUT
  27 |       DOM_REAL,DIMENSION(nkabs)        :: w
  28 |       DOM_REAL,DIMENSION(nkabs,nelmts) :: all_k_abs
  29 | 
  30 | !     LOCAL
  31 |       DOM_REAL,DIMENSION(nkabs,nelmts) :: local_all_k_abs
  32 |       DOM_REAL,DIMENSION(2)            :: SNBDATA
  33 |       DOM_REAL,DIMENSION(ngbands,2)    :: gasdata
  34 |       DOM_REAL,DIMENSION(nelmts)       :: K_SOOT, FSK_SOOT
  35 |       DOM_REAL,DIMENSION(nkabs)        :: k_absmel
  36 |       DOM_REAL,DIMENSION(ngbands)      :: F
  37 |       DOM_REAL                         :: blae, planck
  38 |       DOM_REAL                         :: WVNB,DWVNB,WVNB_SI,DWVNB_SI
  39 |       DOM_INT                          :: ielt, i, ierr
  40 |       DOM_INT                          :: i_bande, n_cl
  41 |       DOM_INT                          :: ICO,ICO2,IH2O
  42 |       LOGICAL                          :: LICO,LICO2,LIH2O
  43 | 
  44 |       local_all_k_abs = 0.
  45 |       all_k_abs       = 0.
  46 |       FSK_SOOT        = 0.
  47 | 
  48 | !     ---------------------------------------------!
  49 | !     Non-homogeneous system or homogeneous system !
  50 | !     ---------------------------------------------!
  51 | 
  52 |       IF (homosyst.eq.'NO') THEN
  53 |         n_cl=ieltf
  54 |       ELSEIF (homosyst.eq.'YES') THEN
  55 |         n_cl=ieltd
  56 |       ENDIF
  57 | 
  58 |       DO ielt=ieltd,n_cl
  59 | 
  60 |         k_absmel = 0.
  61 | 
  62 | !       -----------------------------------!
  63 | !       Seting spectral data for each band !
  64 | !       -----------------------------------!
  65 | 
  66 |         gasdata = 0.
  67 | 
  68 |         DO i_bande=1,ngbands
  69 | 
  70 | !         IF (pmm_rank.eq.0) WRITE(*,*) ">> Bande:",i_bande,"/",ngbands
  71 | 
  72 |           WVNB    = all_WVNB(i_bande)
  73 |           DWVNB   = all_DWVNB(i_bande)
  74 |           WVNB_SI = 100.*WVNB
  75 |           DWVNB_SI= 100.*DWVNB
  76 | 
  77 | !         ----------------------------------------!
  78 | !         Spectral index lecture for each species !
  79 | !         ----------------------------------------!
  80 | 
  81 |           IF (WVNB.le.9300.0) THEN
  82 | 
  83 | !           print*, pmm_rank, " >> Findi"
  84 |             CALL FINDI(LICO,LICO2,LIH2O,ICO,ICO2,IH2O,WVNB,DWVNB)
  85 | 
  86 | !           print*, pmm_rank, " >> kbarandphi"
  87 |             CALL KBARANDPHI(celldata(:,ielt),LICO,LICO2,LIH2O,ICO,      &
  88 |      &                      ICO2,IH2O,KCO,KC,KH,DCO,DC,DH,SNBDATA,      &
  89 |      &                      nallbandes)
  90 | 
  91 |             gasdata(i_bande,1:2)=SNBDATA(1:2)
  92 | 
  93 |           ENDIF
  94 | 
  95 | !         -------------------------------------!
  96 | !         Band groupment multiplicative factor !
  97 | !         -------------------------------------!
  98 | 
  99 | !         IF (pmm_rank.eq.0) print*, "soot"
 100 | 
 101 |           F(i_bande)   = blae(WVNB_SI,celldata(1,ielt))*DWVNB_SI
 102 |           K_SOOT(ielt) = 5.5*celldata(8,ielt)*WVNB_SI
 103 | 
 104 |           FSK_SOOT(ielt)=FSK_SOOT(ielt)+F(i_bande)*K_SOOT(ielt)
 105 | 
 106 |         ENDDO
 107 | 
 108 |         FSK_SOOT(ielt) = FSK_SOOT(ielt) / SUM(F)
 109 |         F              = F / SUM (F)
 110 | 
 111 | !       -------------------------------------------!
 112 | !       Quadrature calculation using spectral data !
 113 | !       -------------------------------------------!
 114 | 
 115 |         CALL k_distributeur(F, ngbands, gasdata, nkabs, k_absmel,w)
 116 | 
 117 |         local_all_k_abs(:,ielt)=k_absmel+FSK_SOOT(ielt)
 118 | 
 119 |         IF ((MOD(ielt,100).eq.0).and.(pmm_rank.eq.0)) THEN
 120 |           print*, ">> Node:",ielt-ieltd,"/",n_cl-ieltd
 121 |         ENDIF
 122 | 
 123 |       ENDDO
 124 | 
 125 |       IF (homosyst.eq.'YES') THEN
 126 |         DO i=ieltd+1,ieltf
 127 |           local_all_k_abs(:,i) = local_all_k_abs(:,ieltd)
 128 |         ENDDO
 129 |       ENDIF
 130 | 
 131 | !     ------------------------------------------------!
 132 | !     sending all_k_abs....change to a pmm subroutine !
 133 | !     ------------------------------------------------!
 134 | 
 135 | #ifdef USEPALM
 136 |        CALL MPI_ALLREDUCE(local_all_k_abs, all_k_abs, nkabs*nelmts,     &
 137 |      &                    MPI_DOUBLE_PRECISION, MPI_SUM, PL_COMM_EXEC  ,&
 138 |      &                    ierr)
 139 | #else
 140 |        CALL MPI_ALLREDUCE(local_all_k_abs, all_k_abs, nkabs*nelmts,     &
 141 |      &                    MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD,&
 142 |      &                    ierr)
 143 | #endif
 144 | 
 145 |       END SUBROUTINE FSCK_CASE
 146 |