source: trunk/libf/phytitan/optcv.v2 @ 53

      SUBROUTINE OPTCV(nmicro,IPRINT)


#include "dimensions.h"
#include "dimphy.h"
#include "microtab.h"
#include "clesphys.h"

c   Argument:
c   ---------
      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 /VISGAS/SOLARF(NSPECV),NTERM(NSPECV),PEXPON(NSPECV),
     &         ATERM(4,NSPECV),BTERM(4,NSPECV)

      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 /OPTICV/ DTAUV(klon,NLAYER,NSPECV,4)
     &               ,TAUV(klon,NLEVEL,NSPECV,4)
     &               ,WBARV(klon,NLAYER,NSPECV,4)
     &               ,COSBV(klon,NLAYER,NSPECV,4)

      COMMON /SPECTV/ BWNV(NSPC1V),WNOV(NSPECV) 
     &               ,DWNV(NSPECV),WLNV(NSPECV)

      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(klon,nlayer,nqmx)
      COMMON /part/ v(nqmx),r(nqmx),vrat,dr(nqmx),dv(nqmx)

      REAL xv1(klev,NSPECV)
      REAL xv2(klev,NSPECV)
      REAL xv3(klev,NSPECV)

      REAL QF1(nqmx,NSPECV),QF2(nqmx,NSPECV)
      REAL QF3(nqmx,NSPECV),QF4(nqmx,NSPECV)
      REAL QM1(nqmx,NSPECV),QM2(nqmx,NSPECV)
      REAL QM3(nqmx,NSPECV),QM4(nqmx,NSPECV)

      save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4
 
      integer ioptv,iwarning     ! ioptv: premier appel, une seule boucle sur les l.d'o.
      integer ig_,seulmtunpt
      save ioptv,iwarning,seulmtunpt
      data ioptv,iwarning,seulmtunpt/0,0,0/
      integer    nmicromax,nmicro1pt
      parameter (nmicromax=10)
      real   zqaer_1pt(NLAYER,nmicromax)
      real   TAUHVD_1pt(NLAYER,NSPECV)
      real   TAUGVD_1pt(NLAYER,NSPECV)
      real   TAUHV_1pt(NSPECV),TAUCV_1pt(NSPECV)
      real   TAURV_1pt(NSPECV),TAUGV_1pt(NSPECV)
      real   DTAUV_1pt(NLAYER,NSPECV,4),TAUV_1pt(NLEVEL,NSPECV,4)
      real   WBARV_1pt(NLAYER,NSPECV,4)
      real   COSBV_1pt(NLAYER,NSPECV,4)

C*
C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISIBLE
C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE VIS
C LAYER: WBAR, DTAU, COSBAR
C LEVEL: TAU
C
       sum=0.
       PRINT*,'OPTCV'
       print*,'ATTENTION, TAU UNIFORME DANS OPTCV'

c      do nng=2,klon
c       do i=1,klev           
c        do j=1,nqmx
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/OPTCV'

             
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c INITIALISATIONS UNE SEULE FOIS
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      if (ioptv.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 optcv !!"
          stop
       endif

      
      DO 130 K=1,NSPECV
C LETS USE THE OPTICAL CONSTANTS FOR THOLIN
      CALL THOLIN(WLNV(K),TNR,TNI)
      REALV(K)=TNR
      XIMGV(K)=TNI*FHVIS
C BUT WE NOW USE THE GEOMETRIC ALBEDO FITTED RESULTS
C      XIMGV(K)=FITEDT(WLNV(K))
C      XIMGV(K)=FITEDN(WLNV(K))
C THE CLOUD IS CLEAR IN THE VISIBLE
      RCLDV(K)=1.27
      XICLDV(K)=1.E-7
 130  CONTINUE
C
c      open (unit=1,file='xsetupv')
c       do j=1,nspecv
c        read(1,*) a
c        do i=1,klev
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******* DEBUT DES BOUCLE GRILLE ************************
c     PRINT*, 'AEROSOLS EN VISIBLE'

      DO 101 ig=1,klon       !c! BOUCLE SUR GRILLE HORIZONTALE

        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 optcv"
            stop
           nmicro1pt=nmicromax
        endif
        
        if (seulmtunpt.eq.0) then
           call optcv_1pt(zqaer_1pt,nmicro1pt,ioptv,
     .            COSBV_1pt,DTAUV_1pt,TAUHV_1pt,TAUHVD_1pt,TAUCV_1pt,
     .       TAURV_1pt,TAUGV_1pt,TAUGVD_1pt,WBARV_1pt,TAUV_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
        
        COSBV(ig,:,:,:)= COSBV_1pt(:,:,:) 
        WBARV(ig,:,:,:)= WBARV_1pt(:,:,:) 
        DTAUV(ig,:,:,:)= DTAUV_1pt(:,:,:) 
        TAUHV(ig,:)    = TAUHV_1pt(:) 
        TAUCV(ig,:)    = TAUCV_1pt(:) 
        TAURV(ig,:)    = TAURV_1pt(:) 
        TAUGV(ig,:)    = TAUGV_1pt(:) 
        TAUV(ig,:,:,:) = TAUV_1pt(:,:,:) 
        TAUHVD(ig,:,:) = TAUHVD_1pt(:,:) 
        TAUGVD(ig,:,:) = TAUGVD_1pt(:,:) 

 101  CONTINUE

c FIN BOUCLE GRILLE     *******
c******************************
         
           print*,"TAUV(1400,:,10,2)=",TAUV(1400,:,10,2)
           print*,"DTAUV(1400,:,10,2)=",DTAUV(1400,:,10,2)
       PRINT*, 'FIN OPTCV'
       stop
      RETURN
      END