Philippe 09/12/2016: replaced obsolete calls to math functions (DCOS->COS, DATAN...
[MNH-git_open_source-lfs.git] / src / MNH / ch_f77.fx90
index c59bb67..8f9ba7a 100644 (file)
@@ -5,7 +5,7 @@
 !-----------------------------------------------------------------
 !--------------- special set of characters for RCS information
 !-----------------------------------------------------------------
-! $Source$ $Revision$ $Date$
+! $Source: /home/cvsroot/MNH-VX-Y-Z/src/MNH/ch_f77.fx90,v $ $Revision: 1.2.2.1.2.2.2.1.8.2.2.3 $ $Date: 2014/06/19 15:18:13 $
 !-----------------------------------------------------------------
 C**FILE:     svode.f
 C**AUTHOR:   Karsten Suhre
@@ -18,6 +18,8 @@ C**MODIFIED:   01/12/03  (Gazen)   change Chemical scheme interface
 C**MODIFIED: 25/03/2008 (M.Leriche & J.P.Pinty):add "MIN(100.,...)" threshold
 C**          in exponential calculation --> problem with "ifort -O2" compiler
 C**MODIFIED: 22/02/2011 (J.Escobar) remove erroneous 'CALL ABORT'
+C**MODIFIED: 19/06/2014 (J.Escobar & M.Leriche) write(kout,...) to OUTPUT_LISTING file
+C                       & correct IN_LUN = 11 => IN_LUN = 78 to avoid fort.11 creation 
 C!
 C!
 C!
@@ -4461,7 +4463,8 @@ c
       subroutine tuvmain (asza, idate,
      +           albnew, dobnew,
      +           nlevel, zin, lwc,
-     +           njout, jout, jlabelout)
+     +           njout, jout, jlabelout,
+     +           kout )
 *-----------------------------------------------------------------------------*
 *=    Tropospheric Ultraviolet-Visible (TUV) radiation model                 =*
 *=    Version 5.0                                                            =*
@@ -4507,7 +4510,7 @@ c      INCLUDE 'params'
 * i/o file unit numbers
       INTEGER kout, kin 
 * output
-      PARAMETER(kout=6)
+*      PARAMETER(kout=6)
 * input
       PARAMETER(kin=78)
 *_________________________________________________
@@ -4785,6 +4788,7 @@ C
 *   alsurf = surface albedo, wavelength independent
 *   psurf = surface pressure, mbar.  Set to negative value to use
 *           US Standard Atmosphere, 1976 (USSA76)
+      psurf = -1.
 * Column amounts of absorbers (in Dobson Units, from surface to space):
 *          Vertical profile for O3 from USSA76.  For SO2 and NO2, vertical
 *          concentration profile is 2.69e10 molec cm-3 between 0 and 
@@ -4894,14 +4898,14 @@ c     $     nt, t, sza, esfact)
 ***** Temperature vertical profile, Kelvin 
 *   can overwrite temperature at altitude z(izout)
 
-      CALL vptmp(nz,z, tlev,tlay)
+      CALL vptmp(nz,z, tlev,tlay,kout)
 c      IF(ztemp .GT. nzero) tlev(izout) = ztemp
 
 *****  Air density (molec cm-3) vertical profile 
 *   can overwrite air density at altitude z(izout)
 
       CALL vpair(psurf, nz, z,
-     $     aircon, aircol)
+     $     aircon, aircol, kout)
 c      IF(zaird .GT. nzero) aircon(izout) = zaird
 
 ***** Correction for air-vacuum wavelength shift:
@@ -4982,13 +4986,13 @@ C      lrefr = .TRUE.
 
        o3_tc = dobnew
       CALL vpo3(ipbl, zpbl, o3pbl, 
-     $       o3_tc, nz, z, aircol, co3)
+     $       o3_tc, nz, z, aircol, co3, kout )
 
 * ___ SECTION 4: READ SPECTRAL DATA ____________________________
 
 * read (and grid) extra terrestrial flux data:
       
-      CALL rdetfl(nw,wl, f)
+      CALL rdetfl(nw,wl, f, kout )
 
 * read cross section data for 
 *    O2 (will overwrite at Lyman-alpha and SRB wavelengths
@@ -5102,13 +5106,13 @@ c       STOP
       CALL setaer(ipbl, zpbl, aod330,
      $     tauaer, ssaaer, alpha,
      $     nz, z, nw, wl,
-     $     dtaer, omaer, gaer)
+     $     dtaer, omaer, gaer, kout )
 
 * Snowpack physical and optical depths, single scattering albedo, asymmetry factor
 
       CALL setsnw(
      $     nz,z,nw,wl,
-     $     dtsnw,omsnw,gsnw)
+     $     dtsnw,omsnw,gsnw,kout)
 
        LFIRSTCALL = .FALSE.
       ENDIF
@@ -5324,7 +5328,7 @@ c 1001    FORMAT(A1)
 c         IF(again .EQ. 'y' .OR. again .EQ. 'Y') GO TO 1000
 c      ENDIF
 
-      CLOSE(iout)
+c     CLOSE(iout)
 C     CLOSE(kout)
       END
 
@@ -5825,7 +5829,7 @@ c      wlabel = 'isaksen.grid'
 
 * check grid for assorted improprieties:
 
-      CALL gridck(kw,nw,wl,ok)
+      CALL gridck(kw,nw,wl,ok,kout)
 
       IF (.NOT. ok) THEN
          WRITE(*,*)'STOP in GRIDW:  The w-grid does not make sense'
@@ -6139,7 +6143,7 @@ c 24   CONTINUE
 * check grid for assorted improprieties:
 
 c 99   CONTINUE
-      CALL gridck(kz,nz,z,ok)
+      CALL gridck(kz,nz,z,ok,kout)
 
       IF (.NOT. ok) THEN
          WRITE(*,*)'STOP in GRIDZ:  The z-grid does not make sense'
@@ -6379,7 +6383,7 @@ c       END
 
 *=============================================================================*
 
-      SUBROUTINE gridck(k,n,x,ok)
+      SUBROUTINE gridck(k,n,x,ok, kout)
 
 *-----------------------------------------------------------------------------*
 *=  PURPOSE:                                                                 =*
@@ -6408,7 +6412,7 @@ c      INCLUDE 'params'
 * i/o file unit numbers
       INTEGER kout, kin 
 * output
-      PARAMETER(kout=6)
+*      PARAMETER(kout=6)
 * input
       PARAMETER(kin=78)
 *_________________________________________________
@@ -6895,8 +6899,8 @@ c      c      INCLUDE 'params'
         rm(iz) = 0.D+00
         ro2(iz) = 0.D+00
         DO i = 1, 3
-          rm(iz) = rm(iz) + b(i) * DEXP(-c(i) * DBLE(o2col(iz)))
-          ro2(iz) = ro2(iz) + d(i) * DEXP(-e(i) * DBLE(o2col(iz)))
+          rm(iz) = rm(iz) + b(i) * EXP(-c(i) * DBLE(o2col(iz)))
+          ro2(iz) = ro2(iz) + d(i) * EXP(-e(i) * DBLE(o2col(iz)))
         ENDDO
       ENDDO
 
@@ -7251,7 +7255,8 @@ C       locals
        INTEGER  IOST           ! i/o status
        INTEGER  I, J
 
-        IN_LUN = 11
+        !IN_LUN = 11
+       IN_LUN = 78
 
        OPEN (UNIT=IN_LUN, FILE=
      $       'DATAE1/O2/effxstex.txt',FORM='FORMATTED')
@@ -8395,7 +8400,7 @@ C     srayl(iw) = 3.90e-28/(wmicrn)**xx
 
 c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 c RCS version control information:
-c $Header$
+c $Header: /home/cvsroot/MNH-VX-Y-Z/src/MNH/ch_f77.fx90,v 1.2.2.1.2.2.2.1.8.2.2.3 2014/06/19 15:18:13 escj Exp $
 c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
       SUBROUTINE SUNAE( YEAR, DAY, HOUR, LAT, LONG, lrefr,
@@ -8880,7 +8885,7 @@ c                   ** distance to sun in A.U. & diameter in degs
 *     read2
 *=============================================================================*
 
-      SUBROUTINE rdetfl(nw,wl,f)
+      SUBROUTINE rdetfl(nw,wl,f, kout)
 
 *-----------------------------------------------------------------------------*
 *=  PURPOSE:                                                                 =*
@@ -8919,7 +8924,7 @@ c      c      INCLUDE 'params'
 * i/o file unit numbers
       INTEGER kout, kin 
 * output
-      PARAMETER(kout=6)
+*      PARAMETER(kout=6)
 * input
       PARAMETER(kin=78)
 *_________________________________________________
@@ -34612,7 +34617,7 @@ c      INCLUDE 'params'
       SUBROUTINE setaer(ipbl, zpbl, aod330,
      $     tau550, ssaaer, alpha,
      $     nz, z, nw, wl, 
-     $     dtaer, omaer, gaer)
+     $     dtaer, omaer, gaer, kout )
 
 *-----------------------------------------------------------------------------*
 *=  PURPOSE:                                                                 =*
@@ -34646,7 +34651,7 @@ c      INCLUDE 'params'
 * i/o file unit numbers
       INTEGER kout, kin 
 * output
-      PARAMETER(kout=6)
+*      PARAMETER(kout=6)
 * input
       PARAMETER(kin=78)
 *_________________________________________________
@@ -35524,7 +35529,7 @@ c      INCLUDE 'params'
 
       RETURN
       END
-      SUBROUTINE setsnw(nz,z,nw,wl,dtsnw,omsnw,gsnw)
+      SUBROUTINE setsnw(nz,z,nw,wl,dtsnw,omsnw,gsnw,kout)
 
 *-----------------------------------------------------------------------------*
 *=  PURPOSE:                                                                 =*
@@ -35586,7 +35591,7 @@ c      INCLUDE 'params'
 * i/o file unit numbers
       INTEGER kout, kin 
 * output
-      PARAMETER(kout=6)
+*      PARAMETER(kout=6)
 * input
       PARAMETER(kin=78)
 *_________________________________________________
@@ -37749,7 +37754,7 @@ c      INCLUDE 'params'
 *=============================================================================*
 
       SUBROUTINE vpair(psurf, nz, z,
-     $     con, col)
+     $     con, col,kout)
 
 *-----------------------------------------------------------------------------*
 *=  NAME:  Vertial Profile of AIR
@@ -37778,7 +37783,7 @@ c      INCLUDE 'params'
 * i/o file unit numbers
       INTEGER kout, kin 
 * output
-      PARAMETER(kout=6)
+*      PARAMETER(kout=6)
 * input
       PARAMETER(kin=78)
 *_________________________________________________
@@ -37959,7 +37964,7 @@ c      INCLUDE 'params'
 *=============================================================================*
 
       SUBROUTINE vpo3(ipbl, zpbl, mr_pbl, 
-     $     to3new, nz, z, aircol, col)
+     $     to3new, nz, z, aircol, col, kout)
 
 *-----------------------------------------------------------------------------*
 *=  NAME:  Vertical Profiles of Ozone = vpo3                                 =*
@@ -38000,7 +38005,7 @@ c      INCLUDE 'params'
 * i/o file unit numbers
       INTEGER kout, kin 
 * output
-      PARAMETER(kout=6)
+*      PARAMETER(kout=6)
 * input
       PARAMETER(kin=78)
 *_________________________________________________
@@ -38193,7 +38198,7 @@ c      INCLUDE 'params'
       END
 *=============================================================================*
 
-      SUBROUTINE vptmp(nz,z,tlev,tlay)
+      SUBROUTINE vptmp(nz,z,tlev,tlay,kout)
 
 *-----------------------------------------------------------------------------*
 *   NAME: Vertical Profile of TeMPerature
@@ -38218,7 +38223,7 @@ c      INCLUDE 'params'
 * i/o file unit numbers
       INTEGER kout, kin 
 * output
-      PARAMETER(kout=6)
+*      PARAMETER(kout=6)
 * input
       PARAMETER(kin=78)
 *_________________________________________________