source: trunk/libf/phytitan/optci.v2 @ 21

      SUBROUTINE OPTCI(ykim,nmicro,IPRINT)
#include "dimensions.h"
#include "dimphy.h"
#include "microtab.h"
#include "numchimrad.h"
#include "clesphys.h"

c   Arguments:
c   ---------
      REAL    ykim(klon,klev,nqmx)
      integer nmicro
c   ---------

      PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1)
      PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25)

      COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL)

      COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL)
     & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER)

      COMMON /STRATO/ C2H2(NLAYER),C2H6(NLAYER)
      COMMON /STRAT2/ HCN(NLAYER)

      COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER)
     & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV)

      COMMON /CLOUD/ RADCLD(NLAYER), XNCLD(NLAYER)
     & , RCLDI(NSPECI), XICLDI(NSPECI), RCLDV(NSPECV), XICLDV(NSPECV)

      COMMON /TAUS/   TAUHI(klon,NSPECI),TAUCI(klon,NSPECI),
     &                TAUGI(klon,NSPECI),TAURV(klon,NSPECV),
     &                TAUHV(klon,NSPECV),TAUCV(klon,NSPECV),
     &                TAUGV(klon,NSPECV)

      COMMON /TAUD/   TAUHID(klon,NLAYER,NSPECI)
     &               ,TAUGID(klon,NLAYER,NSPECI)
     &               ,TAUHVD(klon,NLAYER,NSPECV)
     &               ,TAUGVD(klon,NLAYER,NSPECV)


      COMMON /OPTICI/ DTAUI(klon,NLAYER,NSPECI)
     &               ,TAUI (klon,NLEVEL,NSPECI)
     &               ,WBARI(klon,NLAYER,NSPECI)
     &               ,COSBI(klon,NLAYER,NSPECI)

      COMMON /SPECTI/ BWNI(NSPC1I), WNOI(NSPECI),
     &                DWNI(NSPECI), WLNI(NSPECI)

      COMMON /PLANT/ CSUBP,RSFI,RSFV,F0PI
      COMMON /ADJUST/ RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC,RCLOUD,FARGON
      COMMON /CONST/RGAS,RHOP,PI,SIGMA
      COMMON /traceurs/qaer
      COMMON /part/v,r,vrat,dr,dv

      DIMENSION PROD(NLEVEL)
      real qaer(klon,nlayer,nqmx)
      real v(nqmx),r(nqmx),vrat,dr(nqmx),dv(nqmx)
      real xv1(klev,nspeci),xv2(klev,nspeci)
      real xv3(klev,nspeci)
      REAL QF1(nqmx,NSPECI),QF2(nqmx,NSPECI)
      REAL QF3(nqmx,NSPECI),QF4(nqmx,NSPECI)
      REAL QM1(nqmx,NSPECI),QM2(nqmx,NSPECI)
      REAL QM3(nqmx,NSPECI),QM4(nqmx,NSPECI)
      real emu
      REAL TAEROSM1(NSPECI),TAEROSCATM1(NSPECI),DELTAZM1(NSPECI)
      
      save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4

      integer iopti,iwarning     ! iopti: premier appel, une seule boucle sur les l.d'o.
      integer ig_,seulmtunpt
      save iopti,iwarning,seulmtunpt
      data iopti,iwarning,seulmtunpt/0,0,0/
      integer    nmicromax,nmicro1pt
      parameter (nmicromax=10)
      real   zqaer_1pt(NLAYER,nmicromax)
      real   TAUHID_1pt(NLAYER,NSPECI)
      real   TAUGID_1pt(NLAYER,NSPECI)
      real   TAUHI_1pt(NSPECI),TAUCI_1pt(NSPECI)
      real   TAUGI_1pt(NSPECI)
      real   DTAUI_1pt(NLAYER,NSPECI),TAUI_1pt(NLEVEL,NSPECI)
      real   WBARI_1pt(NLAYER,NSPECI)
      real   COSBI_1pt(NLAYER,NSPECI)

C THE PRESSURE INDUCED TRANSITIONS ARE FROM REGIS
C THE LAST SEVENTEEN INTERVALS ARE THE BANDS FROM GNF.
C
C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE INFRARED
C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE IR
C LAYER: WBAR, DTAU, COSBAR
C LEVEL: TAU
C
       print*,'START OPTCI'

c Diagnostic eventuellement:
c      if (nmicro.gt.0) then
c      sum=0.
c      do nng=2,klon
c        do i=1,klev
c         do j=1,nmicro
c          print*,'j,rj',j,r(j)
c          print*,'paer',qaer(nng,i,j)
c           sum=sum+qaer(nng,i,j)*r(j)**3.*1.3333*3.1415*1000.
c         enddo
c        enddo
c        enddo
c      print*,sum/(klon-1),'SOMME COLONNE/OPTCI'
c      endif


c      do inq=1,nqmx
c          print*,inq,r(inq),vrat,qaer(12,25,inq)
c      enddo
             
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c INITIALISATIONS UNE SEULE FOIS
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      if (iopti.eq.0) then

c verif pour taille zqaer_1pt, sachant que si microfi=0 et nqmx=1, 
c il faut quand meme qu'on lise la look-up table de dim nq=10
       if (nmicro.gt.nmicromax) then
          print*,"nmicro.gt.nmicromax",nmicro,nmicromax
          print*,"PROBLEME pour zqaer_1pt dans optci !!"
          stop
       endif

      
      DO 420 K=1,NSPECI
C LETS USE THE THOLIN OPTICAL CONSTANTS FOR THE HAZE.
          CALL THOLIN(WLNI(K),TNR,TNI)
          REALI(K)=TNR
          XIMGI(K)=TNI*FHIR
C SET UP THE OPTICAL CONSTANTS FOR THE CLOUD
          RCLDI(K)=1.27
          XICLDI(K)=REFLIQ(WNOI(K))
 420  CONTINUE

C
C ZERO ALL OPTICAL DEPTHS.
C ??FLAG? FOR SOME APPLCIATIONS THE TOP OPACITY MAY NOT VANISH

c      open  (unit=1,file='xsetupi')
c      do i=1,klev
c       read(1,*) a
c        do j=1,nspeci
c            read(1,*) xv1(i,j),xv2(i,j),xv3(i,j)
c        enddo
c       enddo
c       close(1)

      endif    ! fin initialisations premier appel

c************************************************************************
c************************************************************************
      DO 79 ig=1,klon      ! BOUCLE SUR GRILLE HORIZONTALE    
c      print*,'ig NEW optci',ig
c************************************************************************
c************************************************************************

        if (.not.ylellouch) then
        
            XN2(1) = ykim(ig,1,iradn2)
            CH4(1) = ykim(ig,1,iradch4)
             H2(1) = ykim(ig,1,iradh2)
            do j=2,nlayer
               XN2(j) = (ykim(ig,j,iradn2)+ykim(ig,j-1,iradn2))/2.
               CH4(j) = (ykim(ig,j,iradch4)+ykim(ig,j-1,iradch4))/2.
                H2(j) = (ykim(ig,j,iradh2)+ykim(ig,j-1,iradh2))/2.
            enddo
            XN2(nlevel) = ykim(ig,nlayer,iradn2)
            CH4(nlevel) = ykim(ig,nlayer,iradch4)
             H2(nlevel) = ykim(ig,nlayer,iradh2)     

            do j=1,nlayer
               emu = ( xmu(j) + xmu(j+1) )/2.
               C2H2(j) = ykim(ig,j,iradc2h2) * 26./emu
               C2H6(j) = ykim(ig,j,iradc2h6) * 30./emu
                HCN(j) = ykim(ig,j,iradhcn ) * 27./emu
            enddo
                  
        endif

        if (microfi.eq.1) then
           do iq=1,nmicro
              do j=1,NLAYER
                 zqaer_1pt(j,iq)=qaer(ig,j,iq)
              enddo
           enddo
           nmicro1pt=nmicro
        else
c initialisation zqaer_1pt a partir d'une look-up table
c boucle sur nmicromax=10
            print*,"LOOK-UP TABLE A FAIRE!!  dans optci"
            stop
           nmicro1pt=nmicromax
        endif
        
        if (seulmtunpt.eq.0) then
           call optci_1pt(zqaer_1pt,nmicro1pt,iopti,
     .            COSBI_1pt,DTAUI_1pt,TAUHI_1pt,TAUHID_1pt,TAUCI_1pt,
     .            TAUGI_1pt,TAUGID_1pt,WBARI_1pt,TAUI_1pt,IPRINT)
        endif

c Pas de microphysique, ni de composition variable: un seul passage
c dans optci_1pt.
        if ((microfi.eq.0).and.(ylellouch)) then
           seulmtunpt = 1
        endif
        
        COSBI(ig,:,:)  = COSBI_1pt(:,:) 
        WBARI(ig,:,:)  = WBARI_1pt(:,:) 
        DTAUI(ig,:,:)  = DTAUI_1pt(:,:) 
        TAUHI(ig,:)    = TAUHI_1pt(:) 
        TAUCI(ig,:)    = TAUCI_1pt(:) 
        TAUGI(ig,:)    = TAUGI_1pt(:) 
        TAUI(ig,:,:)   = TAUI_1pt(:,:) 
        TAUHID(ig,:,:) = TAUHID_1pt(:,:) 
        TAUGID(ig,:,:) = TAUGID_1pt(:,:) 

c************************************************************************
c************************************************************************
  79  CONTINUE   ! FIN BOUCLE GRILLE HORIZONTALE
c************************************************************************
c************************************************************************

           print*,"TAUI(1400,:,10)=",TAUI(1400,:,10)
           print*,"DTAUI(1400,:,10)=",DTAUI(1400,:,10)
      print*, 'FIN OPTCI'
      stop
      RETURN
      END