!     path:      $Source: /project/rc/rc1/cvsroot/rc/cntnm/src/cntnm_progr.f,v $
!     author:    $Author: jdelamer $
!     revision:  $Revision: 1.2 $
!     created:   $Date: 2011/03/29 20:16:57 $
! 
!
!  --------------------------------------------------------------------------
! |  Copyright ©, Atmospheric and Environmental Research, Inc., 2011         |
! |                                                                          |
! |  All rights reserved. This source code is part of the MT_CKD continuum   |
! |  software and is designed for scientific and research purposes.          |
! |  Atmospheric and Environmental Research, Inc. (AER) grants USER          |
! |  the right to download, install, use and copy this software              |
! |  for scientific and research purposes only. This software may be         |
! |  redistributed as long as this copyright notice is reproduced on any     |
! |  copy made and appropriate acknowledgment is given to AER. This          |
! |  software or any modified version of this software may not be            |
! |  incorporated into proprietary software or commercial software           |
! |  offered for sale.                                                       |
! |                                                                          |
! |  This software is provided as is without any express or implied          |
! |  warranties.                                                             |
! |                       (http://www.rtweb.aer.com/)                        |
!  --------------------------------------------------------------------------
!
                  PROGRAM DRCNTNM
!
!
!
!     The mt_ckd water vapor continuum is a completely new continuum  
!     formulation based on a collision induced  component and a sub-Lorentzian 
!     line wing component.  Both the water vapor continuum coefficients and 
!     those for other molecules are constrained to agree with accurate
!     measurements of continuum absorption in the spectral regions where such
!     measurements exist.
!
!     This is an updated version of the continuum program:
!     this version provides optical depths on file CNTNM.OPTDPT as before:
!     it also provides the continuum coefficients on file  WATER.COEF
!
!     the length of the header records may vary by version:
!         in this version the WATER.COEF header information is 47 records 
!         in this version the CNTNM.OPTDT header information is 34 records 
!
!     presumably the user will want to create an input file to address
!     individual requirements
!
!
      IMPLICIT REAL*8           (V)                                     
!
      COMMON /ABSORB/ V1ABS,V2ABS,DVABS,NPTABS,ABSRB(5050)                
!
      COMMON /CVRCNT/ HNAMCNT,HVRCNT
!
      COMMON /FILHDR/ XID(10),SECANT,PAVE,TAVE,HMOLID(60),XALTZ(4),&
                      WK(60),PZL,PZU,TZL,TZU,WBROAD,DV ,V1 ,V2 ,TBOUND,&
                      EMISIV,FSCDID(17),NMOL,LAYER ,YI1,YID(10),LSTWDF    
!
      Common /share/ HOLN2
!
      COMMON /CONSTS/ PI,PLANCK,BOLTZ,CLIGHT,AVOGAD,ALOSMT,GASCON,&
                      RADCN1,RADCN2,GRAV,CPDAIR,AIRMWT,SECDY
      COMMON /LAMCHN/ ONEPL,ONEMI,EXPMIN,ARGMIN                           
      COMMON /XCONT/  V1C,V2C,DVC,NPTC,C(6000)
!
!********************************************
      COMMON /cnth2o/ V1h,V2h,DVh,NPTh,Ch(5050),csh2o(5050),cfh2o(5050)
!********************************************
!
      COMMON /IFIL/ IRD,IPRcnt,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,&
                    NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,&
                    NLTEFL,LNFIL4,LNGTH4                                  

      common /cntscl/ XSELF,XFRGN,XCO2C,XO3CN,XO2CN,XN2CN,XRAYL

!------------------------------------
! for analytic derivative calculation
! note: ipts  = same dimension as ABSRB
!       ipts2 = same dimension as C
      parameter (ipts=5050,ipts2=6000)
      common /CDERIV/ icflg,iuf,v1absc,v2absc,dvabsc,nptabsc,&
          dqh2oC(ipts),dTh2oC(ipts),dUh2o,&
          dqco2C(ipts),dTco2C(ipts),&
          dqo3C(ipts),dTo3C(ipts),&
          dqo2C(ipts),dTo2C(ipts),&
          dqn2C(ipts),dTn2C(ipts)

      real ctmp(ipts2),cself(ipts),cforeign(ipts),ch2o(ipts2)
      real ctmp2(ipts2),ctmp3(ipts2),ctmp4(ipts),ctmp5(ipts)

!------------------------------------
!
      dimension xcnt(7)
!
      equivalence (xself,xcnt(1))
!
      CHARACTER*18 HNAMCNT,HVRCNT
!                                                                         F00100
      CHARACTER*8      XID,       HMOLID,      YID
      REAL*8               SECANT,       XALTZ
!
      character*8 holn2
!                                                                         F00120
      DATA XLOSMT/2.68675E+19/                                            
!
      RADCN1=2.*PLANCK*CLIGHT*CLIGHT*1.E-07                                 
      RADCN2=PLANCK*CLIGHT/BOLTZ                                            
!
      icflg = -999
!
      do 1, i=1,7
         xcnt(i)=1.
 1    continue

      do 2, i=1,5050
         absrb(i)=0.
 2    continue

      do 3, i=1,60
         wk(i)=0.
 3    continue
!
      ird = 55
      ipr = 66
      ipu = 7
!
      OPEN (ipr,FILE='CNTNM.OPTDPT')
      OPEN (ipu,FILE='WATER.COEF')
!
      print *
      print *, '  This version is limited to 5000 values  '
!
!   THIS PROGRAM CALCULATES THE CONTINUUM OPTICAL DEPTH
!         FOR AN HOMOGENEOUS LAYER
!
!   THE FOLLOWING QUANTITIES MUST BE SPECIFIED: 
!
!          PRESSURE                   PAVE (MB)
!
!          TEMPERATURE                TAVE ( K)
!
!          COLUMN AMOUNT
!            NITROGEN                 WN2    (MOLEC/CM**2)
!            OXYGEN                   WK(7)  (MOLEC/CM**2)
!            CARBON DIOXIDE           WK(2)  (MOLEC/CM**2)
!            WATER VAPOR              WK(1)  (MOLEC/CM**2)
!
!          NUMBER OF MOLECULES        NMOL
!
!          BEGINNING WAVENUMBER       V1ABS (CM-1)
!
!          ENDING WAVENUMBER          V2ABS (CM-1)
!
!          SAMPLING INTERVAL          DVABS (CM-1)
!
!          NUMBER OF VALUES           NPTABS
!
!
!   THE RESULTS ARE IN ARRAY ABSORB
!
!   NOTE THAT FOR AN ATMOSPHERIC LAYER: 
!
!            WTOT   = XLOSMT * (PAVE/1013) * (273/TAVE) * (PATH LENGTH)
!
!            WBROAD = the column amount for all species not explicitly provided
!
!            WK(M)  = (VOLUME MIXING RATIO) * (COLUMN OF DRY AIR)
!
!
      iprcnt = ipr
                   CALL PRCNTM
      iprcnt = ipu
                   CALL PRCNTM
!
!   THE FOLLOWING IS AN EXAMPLE FOR A ONE CM PATH (SEE CNTNM.OPTDPT FOR RESULTS)
!

      PAVE = 1013.
      TAVE =  296.
!
      VMRH2O = 0.01
!
      xlength = 1.
!
      print *
      print *,' *** For this program, vmr_h2o is taken ',&
       'with respect to the total column ***'

      print *
      print *,' read: pressure (mb)  if negative use default values'
      read *, press_rd

      if (press_rd .gt. 0.) then
         pave = press_rd
         print *,' read:   temperature (K)'
         read *, tave
         print *,' read:   path length (cm)'
         read *, xlength
         print *,' read:   vmr h2o '
         read *, vmrh2o
      endif
      print *,&
       'Pressure (mb), Temperature (K), Path Length (cm),    VMR H2O'

      print 911, pave,tave,xlength,vmrh2o
 911  format(1x,f13.6,f17.4,f18.4,f12.8)
!
!     It may be preferable to specifiy the water column directly!
!
      WTOT = XLOSMT*(PAVE/1013.)*(273./TAVE)* xlength
!
      W_dry = WTOT * (1.-VMRH2O)
!
!     ww is column of dry air;  vol. mix. ratios are based on dry air
!
! argon:
      WA     = 0.009     * W_dry
! nitrogen:
      WN2    = 0.78      * W_dry
! oxygen:
      WK(7)  = 0.21      * W_dry

! carbon dioxide:
      WK(2)  = 345.E-06  * W_dry

!      WK(2) = 0.

! water vapor:
      if (abs(vmrh2o-1.) .lt. 1.e-05) then
         wk(1) = wtot
      else
         WK(1) = VMRH2O * W_dry
      endif
!
      WBROAD=WN2+WA
!
      NMOL = 7
!
      V1ABS =    0.
      V2ABS = 10000.

      DVABS =    2.
! ..........................................................
!      write (*,*) '  v1abs,  v2abs,  dvabs  '
!      read  (*,*)    v1abs,  v2abs,  dvabs
! ..........................................................

      NPTABS =  1. + (v2abs-v1abs)/dvabs

      do 85 i=1,nptabs
         absrb(i) =0.
 85   continue

!c
      WRITE (IPR,970) PAVE,TAVE
      WRITE (IPR,975) (HMOLID(I),I=1,7),HOLN2                             
      WRITE (IPR,980) (WK(M),M=1,7),WBROAD
!
      WRITE (IPu,970) PAVE,TAVE
      WRITE (IPu,975) (HMOLID(I),I=1,7),HOLN2                             
      WRITE (IPu,980) (WK(M),M=1,7),WBROAD
!
  970 FORMAT (/,29x, 'P(MB)',7X,'T(K)', //,23x,0P,F12.3,F9.2)
  975 FORMAT (/, 9X,'MOLECULAR AMOUNTS (MOL/CM**2) BY LAYER ',//,&
               8(1X,A6,3X))
  980 FORMAT (/,1P,8E10.3,//)
!
      jrad=1
!
      v1 = v1abs
      v2 = v2abs
!
      CALL CONTNM(JRAD)
!
      DO 100 I=1,NPTABS
      VI=V1ABS+FLOAT(I-1)*DVABS
100   WRITE (ipr, 910) VI, ABSRB(I)
910   FORMAT(F10.3,1P,E12.3)
!
      WRITE (7,920) tave
  920 FORMAT(//,' self and foreign water vapor continuum coefficients ',/,&
             'for  ',f8.2,'K - ',   //,&
             ' the self-continuum scales as ( Rself/Ro ) ',/,&
             ' the foreign continuum scales as ( (Rtot-Rself)/Ro ) ',/,&
             ' where R is the density rho [ R = (P/Po)*(To/T) ]. ',//,&
         10x,'     without radiation field:  ',&
         10x,'       with radiation field:   ',      /,&
         10x,'      self         foreign     ',&
         10x,'      self         foreign     ',      /,&
             '    cm-1  ',&
             '       1/(cm-1 molec/cm**2)    ',&
         10x,'       1/(molec/cm**2) '        ,//)
!
      xkt=tave/radcn2

      do 200 i=1,npth
      vi=v1h+float(i-1)*dvh
      if (vi.ge.v1abs .and. vi.le.v2abs) then
         radfld=radfn(vi,xkt)
         csh2or=csh2o(i) * radfld
         cfh2or=cfh2o(i) * radfld
         write (ipu,930) vi, csh2o(i), cfh2o(i), csh2or, cfh2or
  930    format(f10.2, 1p, 2e15.4,10x, 1p, 2e15.4)
      endif
  200 continue
!
      END
!**********************************************************************
      Include 'cntnm_progr_procedures.f90'
