1 | include(dom.inc)
   2 | 
   3 |       SUBROUTINE BAND_INTEG(wkabs, kabs, kscat, Lb, Lo, DWVNB_SI,       &
   4 |      &                      Gtot, Lbtot,  Htot, Q_rtot, Q_ptot)
   5 | 
   6 |         USE mod_slave
   7 |         USE mod_inout
   8 |         USE mod_pmm
   9 | 
  10 |         IMPLICIT NONE
  11 | 
  12 |         include 'dom_constants.h'
  13 |         include 'pmm_constants.h'
  14 | 
  15 | !       IN
  16 |         DOM_REAL                              :: DWVNB_SI
  17 |         DOM_REAL,DIMENSION(is_nkabs)          :: wkabs
  18 |         DOM_REAL,DIMENSION(is_nkabs,is_ncells):: kabs
  19 |         DOM_REAL,DIMENSION(is_ncells)         :: Lb, kscat
  20 |         DOM_REAL,DIMENSION(is_nbfaces)        :: Lo
  21 | 
  22 | !       OUT
  23 |         DOM_REAL,DIMENSION(3,is_ncells)          :: Q_rtot
  24 |         DOM_REAL,DIMENSION(is_ncells)            :: Gtot, Lbtot
  25 |         DOM_REAL,DIMENSION(is_nbfaces)           :: Htot
  26 |         DOM_REAL,DIMENSION(3,is_nprobes)         :: Q_ptot
  27 | 
  28 | !       LOCAL
  29 |         DOM_INT                                  :: iquad, i
  30 |         DOM_INT                                  :: n_iter, maxiter
  31 |         DOM_INT                                  :: mloc(1)
  32 |         DOM_REAL                                 :: error
  33 |         DOM_REAL,ALLOCATABLE, DIMENSION(:,:)     :: WSGG_W_cell
  34 |         DOM_REAL,ALLOCATABLE, DIMENSION(:,:)     :: WSGG_W_face
  35 |         DOM_REAL,DIMENSION(is_nkabs,is_ncells)   :: Gi
  36 |         DOM_REAL,DIMENSION(is_ncells)            :: G
  37 |         DOM_REAL,DIMENSION(is_nbfaces)           :: H, Hitot
  38 |         DOM_REAL,DIMENSION(3,is_ncells)          :: Qr
  39 |         DOM_REAL,DIMENSION(3,is_nprobes)         :: Qp
  40 | 
  41 |         IF (.not.ALLOCATED(WSGG_W_cell))                                &
  42 |      &      ALLOCATE(WSGG_W_cell(is_nkabs, is_ncells))
  43 |         IF (.not.ALLOCATED(WSGG_W_face))                                &
  44 |      &      ALLOCATE(WSGG_W_face(is_nkabs, is_nbfaces))
  45 | 
  46 |         CALL GATHER(s_WSGG_W, WSGG_W_cell, is_nkabs)
  47 |         CALL GATHER_FACES(s_WSGG_W, WSGG_W_face, is_nkabs)
  48 | 
  49 | !       -----------------------------------------------------!
  50 | !       Initialisation values before reflection subiteration !
  51 | !       -----------------------------------------------------!
  52 |      
  53 |         error   = 1.
  54 |         n_iter  = 0
  55 |         maxiter = 500
  56 | 
  57 |         DO WHILE ((error.gt.critconv).and.(n_iter.lt.maxiter))
  58 | 
  59 | !         -------------------------------------------!
  60 | !         Update values for reflection sub iteration !
  61 | !         -------------------------------------------!
  62 | 
  63 |           Hitot = Htot
  64 | 
  65 |           Gtot    = 0.
  66 |           Lbtot   = 0. 
  67 |           Htot    = 0.
  68 |           Q_rtot  = 0. 
  69 |           Q_ptot  = 0.
  70 | 
  71 |           IF(SUM(s_epsil)/is_nbfaces.eq.1) n_iter = maxiter
  72 | 
  73 | !         print*, " (",pmm_rank,") Doing band integration"
  74 | 
  75 | !         --------------------------!
  76 | !         Integrate the narrow band !
  77 | !         --------------------------!
  78 | 
  79 |           DO iquad=1,is_nkabs
  80 | 
  81 |             is_dirbeg = 1
  82 |             is_dirend = 0
  83 | 
  84 |             IF(is_cd.le.is_cf) THEN
  85 |               IF((iquad.ge.is_cd).and.(iquad.le.is_cf)) THEN
  86 |                 is_dirend = is_ndir
  87 |               ENDIF
  88 |             ELSE
  89 |               IF (iquad.ge.is_cd) THEN
  90 |                 is_dirend = is_ndir -1
  91 |               ELSEIF (iquad.le.is_cf) THEN
  92 |                 is_dirbeg = 2
  93 |                 is_dirend = is_ndir
  94 |               ENDIF
  95 |             ENDIF
  96 | 
  97 | !           PRINT*, pmm_rank, iquad, is_dirbeg,is_dirend
  98 | 
  99 | !           -------------------------------------------!
 100 | !           Update values for reflection sub iteration !
 101 | !           -------------------------------------------!
 102 | 
 103 |             Gi(iquad,:) = G(:)
 104 | 
 105 | !           --------------------------------------------------!
 106 | !           SPATIAL SCHEME                                    !
 107 | !           WSGG: Le traitement de chaque gaz se fait sur une !
 108 | !                 fraction du corps noir A*Lb (avec sum(A)=1) !
 109 | !           --------------------------------------------------!
 110 | 
 111 |             CALL SPATIAL_SCHEME(I_SCHEME, Lb*WSGG_W_cell(iquad,:),      &
 112 |      &                          Gi(iquad,:), G, kabs(iquad,:), kscat,   &
 113 |      &                          Qr, H, alpha, Qp,                       &
 114 |      &                          WSGG_W_face(iquad,:)*Lo(:))
 115 | 
 116 | !           Special case for FSCK model
 117 | !           WSGG_W_face(iquad,:)*Lo(:) -> s_WSGG_Wb(iquad,:)*Lo(:)
 118 | 
 119 | !           -------------------------------------------------------------!
 120 | !           Sum over slave quadrature point/directions for global models !
 121 | !           -------------------------------------------------------------!
 122 | 
 123 |             Gtot(:)  = Gtot(:)  + G(:)      *kabs(iquad,:)*wkabs(iquad) &
 124 |      &                 *DWVNB_SI
 125 |             Lbtot(:) = Lbtot(:) + Lb(:)*4*pi*kabs(iquad,:)*wkabs(iquad) &
 126 |      &                 *DWVNB_SI*WSGG_W_cell(iquad,:)
 127 |             Htot(:)  = Htot(:)  + H(:)                    *wkabs(iquad) &
 128 |                        *DWVNB_SI
 129 |             DO i=1,3
 130 |               Q_rtot(i,:) = Q_rtot(i,:) + Qr(i,:)*wkabs(iquad)*DWVNB_SI
 131 |               Q_ptot(i,:) = Q_ptot(i,:) + Qp(i,:)*wkabs(iquad)*DWVNB_SI
 132 |             ENDDO
 133 |           ENDDO
 134 | 
 135 | !         --------------------------------!
 136 | !         Convergence test for reflection !
 137 | !         --------------------------------!
 138 | 
 139 |           mloc  = MAXLOC(abs(Htot-Hitot))
 140 |           IF ((n_iter.ne.0).and.((abs(Hitot(mloc(1)))).ne.0.)) THEN
 141 |             error = (abs(Htot(mloc(1))-Hitot(mloc(1))))/                &
 142 |      &              abs(Hitot(mloc(1)))
 143 |           ELSE
 144 |             error = 1.
 145 |           ENDIF
 146 | 
 147 |           n_iter = n_iter + 1
 148 | 
 149 |  !        IF (pmm_rank.eq.0) print*, "n_iter=",n_iter,"- err=", error
 150 |  !        IF (pmm_rank.eq.0) print*, "mloc=",mloc(1),"- Htot=",          &
 151 |  !   &                           Htot(mloc(1)),"- Hitot=",Gitot(mloc(1))
 152 | 
 153 |         ENDDO
 154 | 
 155 |       END SUBROUTINE BAND_INTEG