	SUBROUTINE IM_UNHD ( imgfil, iret )
C************************************************************************
C* IM_UNHD								*
C*									*
C* This subroutine reads the header of a UNISYS NIDS composite image	*
C* file and sets the navigation.					*
C*									*
C* IM_UNHD ( IMGFIL, IRET )						*
C*									*
C* Input parameters:							*
C*	IMGFIL		CHAR*		Image file name			*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					 -2 = Error opening/reading file*
C*					 -4 = Invalid product		*
C*					 -5 = Invalid image navigation	*
C**									*
C* Log:									*
C* R. Lindsay/GSC	12/96	Initial version based on imnohd.f	*
C* S. Jacobs/NCEP	 2/97	Changed common variable names		*
C* S. Jacobs/NCEP	12/97	Changed voltim to ivltim		*
C* S. Jacobs/NCEP	12/97	Added imradf; removed immode, imraw	*
C* S. Jacobs/NCEP	12/97	Added TB_NIDS; Removed DATA statements	*
C* S. Jacobs/NCEP	11/98	Fixed calc of corners for regional image*
C* S. Jacobs/NCEP	 5/99	Added checks for byte swapping		*
C* T. Piper/GSC		 7/01	Fixed typo dlon[1-2] -> rlon[1-2]	*
C* D.W.Plummer/NCEP	 9/01	Set imbswp=0 when no byte swapping	*
C* T. Piper/SAIC	03/08	Added Alaska and Hawaii mosaics		*
C* T. Piper/SAIC	04/08	Corrected National Mosaic Projection	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'IMGDEF.CMN'
C*
	CHARACTER*(*)	imgfil
C
	REAL*8		dx, dy, rlat, rlon
	INTEGER		readbf (40), idtarr (3), idlvls (16)
	INTEGER*2	radbuf (80), itemp (2)
C
	CHARACTER	proj*3, prdnam*8, units*8, desc*20, tmpstr*8
C
	EQUIVALENCE	( readbf, radbuf )
	EQUIVALENCE	( itemp4, itemp )
C------------------------------------------------------------------------
C
C*  Open the file, read the header, and close the file.
C
	CALL FL_DOPN ( imgfil, 40, .false., lunmf, iret )
	IF  ( iret .ne. 0 ) THEN
	    iret = -2
	    RETURN
	END IF
C
	CALL FL_READ ( lunmf, 1, 40, readbf, iret )
	IF  ( iret .ne. 0 ) THEN
	    iret = -2
	    RETURN
	END IF
C
	CALL FL_CLOS ( lunmf, ier )

C
C*  Determine whether file needs bytes flipped.
C
	IF  ( ( radbuf(1) .gt. 255 ) .or.
     +	      ( radbuf(1) .le.   0 ) )  THEN
	    imbswp = 1
	    ier = MV_SWP2 ( 40, readbf, readbf )
	ELSE
	    imbswp = 0
	END IF
C
C*  Find the table information about this product.
C
C*  Product ID
	imtype = radbuf(1)
C*  Source ID
	isrc   = radbuf(7)
	CALL TB_NIDS  ( isrc, imtype, prdnam, nlev, units,
     +			 res, desc, ierr )
	IF  ( ierr .ne. 0 )  THEN
	    CALL ER_WMSG ( 'TB', ierr, ' ', ier )
	    iret = -4
	    RETURN
	END IF
	CALL ST_RNUL(prdnam, prdnam, lens, ier )
	CALL ST_RNUL(units, units, lens, ier )
	CALL ST_RNUL(desc, desc, lens, ier )
C
C*  Set values in IMGDEF.CMN...
C
C*  Radar image.
	imradf = 1
C*  Mosaic file.
	imrdfl = 0
C*  Number of data levels.
	imndlv = nlev
C*  Image data offset in bytes.
	imdoff = 154
C*  Pixel depth in bytes.
	imdpth = 1
C*  Color bar units.
	cmbunt = units
C*  Image calibration units.
	cmcalb = 'RAW '
C*  X-Y pixel resolution in KMs.
	rmxres = res
	rmyres = res
C*  X-Y image scaling factor.
	rmxysc = 1.0

C
C*  Determine date.  Date stored with the raw data is the number of
C*  days from 1/1/70.  Put it into YYYYMMDD form.
C
	jyear = ( radbuf ( 2 ) - 1 + .5 ) / 365.25
	iyear = 1970 + jyear
	iday  = radbuf ( 2 ) - INT ( jyear * 365.25 + .25 )
	CALL TI_JTOI ( iyear, iday, idtarr, ier )
	imdate = idtarr (1) * 10000 + idtarr (2) * 100 + idtarr (3)

C
C*  Determine time.  Time stored is number of seconds past UTC midnight.
C*  Put it into HHMMSS form.  Use volume scan time.  This is from
C*  halfwords 3 and 4 of header, equivalenced into variable voltime.
C
	IF  ( imbswp .eq. 1 )  THEN
	    itemp ( 2 ) = radbuf ( 3 )
	    itemp ( 1 ) = radbuf ( 4 )
	  ELSE
	    itemp ( 1 ) = radbuf ( 3 )
	    itemp ( 2 ) = radbuf ( 4 )
	END IF
	ivltim = itemp4
	imtime = ( 10000 *     ( ivltim / 3600   ) ) +
     +		 (   100 * MOD ( ivltim / 60, 60 ) ) +
     +		 MOD ( ivltim, 60 )

C
C*  Determine total length in bytes.
C
	IF  ( imbswp .eq. 1 )  THEN
	    itemp ( 2 ) = radbuf ( 5 )
	    itemp ( 1 ) = radbuf ( 6 )
	  ELSE
	    itemp ( 1 ) = radbuf ( 5 )
	    itemp ( 2 ) = radbuf ( 6 )
	END IF
	imldat = itemp4

C
C*  Get the image size from halfwords 53 and 78 of the header.
C
	imnpix = radbuf ( 53 )
	imnlin = radbuf ( 78 )

C
C*  Bounds of "zoomed" image.
C
	imleft = 1
	imtop  = 1
	imrght = imnpix
	imbot  = imnlin

C
C*  Set image source and projection.
C
C*  Set the corner points in the master image coordinates based upon
C*      the source number:
C*		CONUS		10000
C*		North East	10001
C*		South East	10002
C*		North Central	10003
C*		South Central	10004
C*		Central		10005
C*		North West	10006
C*		South West	10007
C*		Alaska		10051
C*		Hawaii		10052
C
	IF ( isrc .eq. 10000 )  THEN
C*  NATIONAL
	    imsorc = 8
C*  The projection for National mosaics is Lambert Conformal Conic
	    proj   = 'LCC'
C*  Set standard latitude #1, normal longitude and
C*	standard latitude #2.
	    angle1 =  33.00
	    angle2 = -98.00
	    angle3 =  45.00
C*  Calculate lower left lat/lon.
	    dx = (1.0 - imnpix/2.0) * rmxres
	    dy = (1.0 - imnlin/2.0) * rmyres
	    CALL LC_KM_TO_LATLON(dx,dy,rlat,rlon)
	    rlat1=rlat
	    rlon1=rlon
C*  Calculate upper right latlon.
	    dx = (imnpix - imnpix/2.0) * rmxres
	    dy = (imnlin - imnlin/2.0) * rmyres
	    CALL LC_KM_TO_LATLON(dx,dy,rlat,rlon)
	    rlat2=rlat
	    rlon2=rlon
	ELSE IF ( ( isrc .ge. 10001 ) .and.
     +		( isrc .le. 10007 ) )  THEN
C*  REGIONAL
	    imsorc = 9
C*  The projection for Regional mosaics is Lambert Conformal Conic
C*  Set standard latitude #1, normal longitude and
C*	standard latitude #2.
	    proj   = 'LCC'
	    angle1 =  33.00
	    angle2 = -98.00
	    angle3 =  45.00
	    IF  ( isrc .eq. 10001 )  THEN
		x_offset = 1284.30162
		y_offset = 892.590816
	    ELSE IF  ( isrc .eq. 10002 )  THEN
		x_offset = 1281.79283
		y_offset = -898.500043
	    ELSE IF  ( isrc .eq. 10003 )  THEN
		x_offset = 0.0
		y_offset = 899.013199
	    ELSE IF  ( isrc .eq. 10004 )  THEN
		x_offset = 0.0
		y_offset = -901.25054
	    ELSE IF  ( isrc .eq. 10005 )  THEN
		x_offset = 0.0
		y_offset = 0.0
	    ELSE IF  ( isrc .eq. 10006 )  THEN
		x_offset = -1284.30162
		y_offset = 892.590816
	    ELSE IF  ( isrc .eq. 10007 )  THEN
		x_offset = -1281.79283
		y_offset = -898.500043
	    END IF
C*  Calculate lower left lat/lon.
	    dx = (1.0 - imnpix/2.0) * rmxres + x_offset
	    dy = (1.0 - imnlin/2.0) * rmyres + y_offset
	    CALL LC_KM_TO_LATLON(dx,dy,rlat,rlon)
	    rlat1=rlat
	    rlon1=rlon
C*  Calculate upper right latlon.
	    dx = (imnpix - imnpix/2.0) * rmxres + x_offset
	    dy = (imnlin - imnlin/2.0) * rmyres + y_offset
	    CALL LC_KM_TO_LATLON(dx,dy,rlat,rlon)
	    rlat2=rlat
	    rlon2=rlon
	ELSE IF ( isrc .eq. 10051 )  THEN
C*  ALASKA
	    imsorc = 6
C*  The projection for Alaska mosaics is Polar Stereographic
	    proj   = 'STR'
C*  The projection center latitude for Alaska is 60.0
	    angle1 =  60.0
C*  The projection center longitude for Alaska is -155.0
	    angle2 = -155.0
	    angle3 =  0
	    x_offset = 153.982620
	    y_offset = -2938.163419
C*  Calculate lower left lat/lon.
	    dx = (1.0 - imnpix/2.0) * rmxres + x_offset
	    dy = (1.0 - imnlin/2.0) * rmyres + y_offset
	    CALL PSN_KM_TO_LATLON_ALASKA(dx,dy,rlat,rlon)
	    rlat1=rlat
	    rlon1=rlon
C*  Calculate upper right latlon.
	    dx = (imnpix - imnpix/2.0) * rmxres + x_offset
	    dy = (imnlin - imnlin/2.0) * rmyres + y_offset
	    CALL PSN_KM_TO_LATLON_ALASKA(dx,dy,rlat,rlon)
	    rlat2=rlat
	    rlon2=rlon
	ELSE IF ( isrc .eq. 10052 )  THEN
C*  HAWAII
	    imsorc = 5
C*  The projection for Hawaii mosaics is Polar Stereographic
	    proj   = 'STR'
C*  The projection center latitude for Hawaii is 90.0
	    angle1 =  90.0
C*  The projection center longitude for Hawaii is -157.5
	    angle2 = -157.5
	    angle3 =  0
	    y_offset = -8201.575703
C*  Calculate lower left lat/lon.
	    dx = (1.0 - imnpix/2.0) * rmxres
	    dy = (1.0 - imnlin/2.0) * rmyres + y_offset
	    CALL PSN_KM_TO_LATLON_HAWAII(dx,dy,rlat,rlon)
	    rlat1=rlat
	    rlon1=rlon
C*  Calculate upper right latlon.
	    dx = (imnpix - imnpix/2.0) * rmxres
	    dy = (imnlin - imnlin/2.0) * rmyres + y_offset
	    CALL PSN_KM_TO_LATLON_HAWAII(dx,dy,rlat,rlon)
	    rlat2=rlat
	    rlon2=rlon
	ELSE
	    iret = -4
	    RETURN
	END IF
	iret = 0

C
C*  Set navigation.
C
	CALL GSMPRJ ( proj, angle1, angle2, angle3,
     +		      rlat1, rlon1, rlat2, rlon2, ier )
	IF ( ier .ne. 0 ) iret = -5
C
C*  Build the data level values.
C
	DO  il = 1, 16
	    idlvls ( il ) = radbuf ( 30 + il )
	END DO
C
	DO  idl = 1, imndlv
C
C*  Data value (or flagged code) is in least signigicant byte.
C
	    ival = IAND ( idlvls (idl), X'FF' )
C
C*  High-order bit might be flag for one of these codes.
C
	    IF  ( BTEST ( idlvls (idl), 15 ) )  THEN
		IF ( ival .eq. 0 ) cmblev (idl) = 'BLANK'
		IF ( ival .eq. 1 ) cmblev (idl) = 'TH'
		IF ( ival .eq. 2 ) cmblev (idl) = 'ND'
		IF ( ival .eq. 3 ) cmblev (idl) = 'RF'
	      ELSE
C
C*  Check for scaled data.  If bit 13 is set, scale by .05,
C*  for bit 12, scale by 0.1.
C
		IF  ( BTEST ( idlvls (idl), 13 ) )  THEN
		    val = ival * .05
		    CALL ST_RLCH ( val, 1, cmblev (idl), ier )
		  ELSE IF  ( BTEST ( idlvls (idl), 12 ) )  THEN
		    val = ival * .1
		    CALL ST_RLCH ( val, 1, cmblev (idl), ier )
		  ELSE
		    CALL ST_INCH ( ival, cmblev (idl), ier )
		END IF
C
C*  Special character prefixes to data values.
C
		IF  ( BTEST ( idlvls (idl), 11 ) )  THEN
		    tmpstr = '>' // cmblev (idl)
		    cmblev (idl) = tmpstr
		END IF
C
		IF  ( BTEST ( idlvls (idl), 10 ) )  THEN
		    tmpstr = '<' // cmblev (idl)
		    cmblev (idl) = tmpstr
		END IF
C
		IF  ( BTEST ( idlvls (idl),  9 ) )  THEN
		    tmpstr = '+' // cmblev (idl)
		    cmblev (idl) = tmpstr
		END IF
C
		IF  ( BTEST ( idlvls (idl),  8 ) )  THEN
		    tmpstr = '+' // cmblev (idl)
		    cmblev (idl) = tmpstr
		END IF
	    END IF
	END DO
C
	RETURN
	END


C
C       $Id: vvdrwb.f,v 1.8 2008-07-27 00:17:35 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE VVDRWB (XB,YB,XE,YE,VLN,LBL,NC,IAM,VVUDMV,IDA)
C
      DIMENSION IAM(*)
C
      EXTERNAL VVUDMV
C
C This routine is called to draw a single wind barb. Its
C arguments are the same as the line-based arrow drawing routine
C VVDRAW. However it uses other parameters from the VVARO common block
C
C XB,YB    -  Coordinate of arrow base, fractional coordinate
C XE,YE    -  Coordinate of arrow head, fractional coordinate
C VLN      -  Length of the vector (arrow)
C          -  (if negative does not draw the vector, but just
C          -  calculates the vector's height and width)
C LBL      -  Character label to be put above arrow.
C NC       -  Number of characters in label.
C IAM      -  Area map (optional) for masking vectors
C VVUDMV   -  User-supplied function for drawing masked vectors
C IDA      -  Do area masking flag
C
C ---------------------------------------------------------------------
C
C NOTE:
C Since implicit typing is used for all real and integer variables
C a consistent length convention has been adopted to help clarify the
C significance of the variables encountered in the code for this
C utility. All local variable and subroutine parameter identifiers
C are limited to 1,2,or 3 characters. Four character names identify
C members of common blocks. Five and 6 character variable names
C denote PARAMETER constants or subroutine or function names.
C
C Declare the VV common blocks.
C
C IPLVLS - Maximum number of color threshold level values
C IPAGMX - Maximum number of area groups allowed in the area map
C
      PARAMETER (IPLVLS = 256, IPAGMX = 64)
C
C Integer and real common block variables
C
C
      COMMON /VVCOM/
     +                IUD1       ,IVD1       ,IPD1       ,IXDM       ,
     +                IYDN       ,VLOM       ,VHIM       ,ISET       ,
     +                VRMG       ,VRLN       ,VFRC       ,IXIN       ,
     +                IYIN       ,ISVF       ,UUSV       ,UVSV       ,
     +                UPSV       ,IMSK       ,ICPM       ,UVPS       ,
     +                UVPL       ,UVPR       ,UVPB       ,UVPT       ,
     +                UWDL       ,UWDR       ,UWDB       ,UWDT       ,
     +                UXC1       ,UXCM       ,UYC1       ,UYCN       ,
     +                NLVL       ,IPAI       ,ICTV       ,WDLV       ,
     +                UVMN       ,UVMX       ,PMIN       ,PMAX       ,
     +                RVMN       ,RVMX       ,RDMN       ,RDMX       ,
     +                ISPC       ,RVMD       ,IPLR       ,IVST       ,
     +                IVPO       ,ILBL       ,IDPF       ,IMSG       ,
     +                ICLR(IPLVLS)           ,TVLU(IPLVLS)
C
C Arrow size/shape parameters
C
        COMMON / VVARO /
     +                HDSZ       ,HINF       ,HANG       ,IAST       ,
     +                HSIN       ,HCOS       ,FAMN       ,FAMX       ,
     +                UVMG       ,FAIR       ,FAWR       ,FAWF       ,
     +                FAXR       ,FAXF       ,FAYR       ,FAYF       ,
     +                AROX(8)    ,AROY(8)    ,FXSZ       ,FYSZ       ,
     +                FXRF       ,FXMN       ,FYRF       ,FYMN       ,
     +                FWRF       ,FWMN       ,FIRF       ,FIMN       ,
     +                AXMN       ,AXMX       ,AYMN       ,AYMX       ,
     +                IACM       ,IAFO       ,WBAD       ,WBTF       ,
     +                WBCF       ,WBDF       ,WBSC
C
C
C Text related parameters
C
        COMMON /VVTXP /
     +                FCWM    ,ICSZ    ,
     +                FMNS    ,FMNX    ,FMNY    ,IMNP    ,IMNC  ,
     +                FMXS    ,FMXX    ,FMXY    ,IMXP    ,IMXC  ,
     +                FZFS    ,FZFX    ,FZFY    ,IZFP    ,IZFC  ,
     +                FILS    ,FILX    ,FILY    ,IILP    ,IILC  ,
     +                FLBS    ,ILBC

C
C Character variable declartions
C
      CHARACTER*160 CSTR
      PARAMETER (IPCHSZ=36)
      CHARACTER*(IPCHSZ)  CMNT,CMXT,CZFT,CLBT,CILT
C
C Text string parameters
C
      COMMON /VVCHAR/ CSTR,CMNT,CMXT,CZFT,CLBT,CILT
C
      SAVE /VVCOM/, /VVARO/, /VVTXP/, /VVCHAR/
C
C The mapping common block: made available to user mapping routines
C
      COMMON /VVMAP/
     +                IMAP       ,
     +                XVPL       ,XVPR       ,YVPB       ,YVPT       ,
     +                WXMN       ,WXMX       ,WYMN       ,WYMX       ,
     +                XLOV       ,XHIV       ,YLOV       ,YHIV       ,
     +                SXDC       ,SYDC       ,NXCT       ,NYCT       ,
     +                RLEN       ,LNLG       ,INVX       ,INVY       ,
     +                ITRT       ,IWCT       ,FW2W       ,FH2H       ,
     +                DVMN       ,DVMX       ,RBIG       ,IBIG
C
      SAVE /VVMAP/
C
C Math constants
C
      PARAMETER (PDTOR  = 0.017453292519943,
     +           PRTOD  = 57.2957795130823,
     +           P1XPI  = 3.14159265358979,
     +           P2XPI  = 6.28318530717959,
     +           P1D2PI = 1.57079632679489,
     +           P5D2PI = 7.85398163397448)
C
C --------------------------------------------------------------------
C
C Local parameters
C
C  PENINC - Increment for which triangles are drawn.
C  BRBINC - Increment for which a full tic is drawn.
C
      PARAMETER (IADIM=6,PENINC=50.0,BRBINC=10.0)
      DIMENSION XO(IADIM),YO(IADIM)
      DIMENSION WIN(4),VPT(4)
C
      CHARACTER*10 LBL
C
      CALL GQCNTN(IER,NTR)
      CALL GQNT(NTR,IER,WIN,VPT)
      CALL GSWN(NTR,VPT(1),VPT(2),VPT(3),VPT(4))
C
C ABS(VLN) is constant and equal to DVMX for wind barbs.
C
      IF (VLN.LT.0.0) THEN
         ISZ=1
         VLL=-VLN
      ELSE
         ISZ=0
         VLL=VLN
      END IF
C
      SPD = UVMG * WBSC
C
C If low speed just draw a circle
C
      ICR = 0
      IF (SPD .LT. 0.5) THEN
         CALL GQPLCI(IER,IC)
         IF (ISZ .EQ. 0) THEN
            CALL NGDOTS(XB,YB,1,WBCF*VLL,IC)
         ELSE
            AXMN = XB - 0.5 * WBCF*VLL
            AXMX = XB + 0.5 * WBCF*VLL
            AYMN = YB - 0.5 * WBCF*VLL
            AYMX = YB + 0.5 * WBCF*VLL
         END IF
         ICR = 1
         GO TO 999
      END IF
C
C X and Y components of the vector.
C Note that direction is XB to XE. The barbs go at the XB end.
C
      DX=XE-XB
      DY=YE-YB
C
C Determinc sine and cosine of the shaft angle, and scaled speed
C
      CSA = DX / VLL
      SNA = DY / VLL
C
C Figure out how many pennants are required.
C If speed great enough to require a pennant then determine pennant
C extent along shaft and extend shaft length to accommodate top
C pennant.
C
      NPN = INT((SPD + 2.5) / PENINC)
      XPI=-AROX(1)*CSA
      YPI=-AROX(1)*SNA
      IF (NPN .EQ. 0) THEN
         AXE = XE - XPI
         AYE = YE - YPI
         DX=AXE-XB
         DY=AYE-YB
      END IF
C
C Adjust the coordinates of the vector endpoints as implied by the
C vector positioning option.
C
      IF (IVPO .LT. 0) THEN
         AXB = XB - DX
         AYB = YB - DY
         AXE = XB
         AYE = YB
      ELSE IF (IVPO .EQ. 0) THEN
         AXB = XB - 0.5*DX
         AYB = YB - 0.5*DY
         AXE = XB + 0.5*DX
         AYE = YB + 0.5*DY
      ELSE
         AXB = XB
         AYB = YB
         AXE = XB + DX
         AYE = YB + DY
      END IF
C
C Initial position and distance between barbs
C
      XPS = AXB
      YPS = AYB
      XIN = WBDF*DVMX*CSA
      YIN = WBDF*DVMX*SNA
C
C Draw the shaft
C
      XO(1) = AXB
      XO(2) = AXE
      YO(1) = AYB
      YO(2) = AYE
C
      IF (ISZ .EQ. 0) THEN
         CALL GPL(2,XO,YO)
      ELSE
         AXMN = MIN(XO(1),XO(2))
         AXMX = MAX(XO(1),XO(2))
         AYMN = MIN(YO(1),YO(2))
         AYMX = MAX(YO(1),YO(2))
      END IF
C
C For speed between 0.5 and 2.5 the shaft is unadorned
C
      IF (SPD .LT. 2.5) THEN
         GO TO 999
      END IF
C
C If speed is less than 7.5 then draw a half barb one increment down
C
      IF (SPD .LT. 7.5) THEN
         XO(1) = XPS+XIN
         YO(1) = YPS+YIN
         XO(2) = XO(1) + AROX(5)*CSA-AROY(5)*SNA
         YO(2) = YO(1) + AROX(5)*SNA+AROY(5)*CSA
         IF (ISZ .EQ. 0) THEN
            CALL GPL(2,XO,YO)
         ELSE
            AXMN = MIN(AXMN,XO(2))
            AXMX = MAX(AXMX,XO(2))
            AYMN = MIN(AYMN,YO(2))
            AYMX = MAX(AYMX,YO(2))
         END IF
         GO TO 999
      END IF
C
C Now draw the pennants if any
C
      DO 10 I = 1,NPN
         XO(1) = XPS + XPI
         YO(1) = YPS + YPI
         XO(2) = XO(1) + AROX(2)*CSA-AROY(2)*SNA
         YO(2) = YO(1) + AROX(2)*SNA+AROY(2)*CSA
         XO(3) = XPS
         YO(3) = YPS
         XO(4) = XO(1)
         YO(4) = YO(1)
         IF (ISZ .EQ. 0) THEN
            CALL GFA(4,XO,YO)
         ELSE
            AXMN = MIN(AXMN,XO(2))
            AXMX = MAX(AXMX,XO(2))
            AYMN = MIN(AYMN,YO(2))
            AYMX = MAX(AYMX,YO(2))
         END IF
         IF (I.EQ.NPN) THEN
            XPS = XO(1) + XIN
            YPS = YO(1) + YIN
         ELSE
            XPS = XO(1)+0.5*XIN
            YPS = YO(1)+0.5*YIN
         END IF
 10   CONTINUE
C
      SPD = SPD - NPN * PENINC
      NBR = INT((SPD + 2.5) / BRBINC)
C
C Draw the barbs
C
      DO 20 I = 1, NBR
         XO(1) = XPS
         YO(1) = YPS
         XO(2) = XO(1) + AROX(2)*CSA-AROY(2)*SNA
         YO(2) = YO(1) + AROX(2)*SNA+AROY(2)*CSA
         IF (ISZ .EQ. 0) THEN
            CALL GPL(2,XO,YO)
         ELSE
            AXMN = MIN(AXMN,XO(2))
            AXMX = MAX(AXMX,XO(2))
            AYMN = MIN(AYMN,YO(2))
            AYMX = MAX(AYMX,YO(2))
         END IF
         XPS = XPS + XIN
         YPS = YPS + YIN
 20   CONTINUE
C
C Draw a half barb if required
C
      IF (SPD - NBR * BRBINC .GT. 2.5) THEN
         XO(1) = XPS
         YO(1) = YPS
         XO(2) = XO(1) + AROX(5)*CSA-AROY(5)*SNA
         YO(2) = YO(1) + AROX(5)*SNA+AROY(5)*CSA
         IF (ISZ .EQ. 0) THEN
            CALL GPL(2,XO,YO)
         ELSE
            AXMN = MIN(AXMN,XO(2))
            AXMX = MAX(AXMX,XO(2))
            AYMN = MIN(AYMN,YO(2))
            AYMX = MAX(AYMX,YO(2))
         END IF
      END IF

 999  CONTINUE

      FXSZ = AXMX-AXMN
      FYSZ = AYMX-AYMN
C
C If requested, put the vector magnitude above the arrow.
C
      IF (NC .GT. 0 .AND. ISZ .EQ. 0) THEN
C
C Figure circle location differently
C
         IF (ICR .EQ. 1) THEN
            RMG = 0.5 * WBCF*VLL
            PHI = 0.0
            IF (NC .EQ. 1) THEN
               XC = XB
            ELSE
               XC = XB - FLBS*FW2W
            END IF
            YC = YB - RMG - 1.25*FLBS*FW2W
         ELSE
            RMG = 0.001
            PHI = ATAN2(DY,DX)
            ISN = -1
            IF (MOD(PHI+P5D2PI,P2XPI) .GT. P1XPI) THEN
               PHI = PHI+P1XPI
               ISN = 1
            END IF
            IF (WBAD .LT. 0.0) THEN
               ISN = -ISN
            END IF
            XC = AXB+0.33*(AXE-AXB) + ISN *
     +           (1.25*FLBS*FW2W+RMG)*COS(PHI+P1D2PI)
            YC = AYB+0.33*(AYE-AYB) + ISN *
     +           (1.25*FLBS*FW2W+RMG)*SIN(PHI+P1D2PI)
         END IF
C
         CALL PLCHLQ(XC,YC,LBL(1:NC),FLBS*FW2W,PRTOD*PHI,0.0)
C
      END IF
C
C Restore original transformation
C
      CALL GSWN(NTR,WIN(1),WIN(2),WIN(3),WIN(4))
C
      RETURN
      END
C
      SUBROUTINE VVINWB (IHM)
C
C IHM      -  Hemisphere (1 - North, -1 - South)
C
C Initializes wind barb specific common block values.
C
C ---------------------------------------------------------------------
C
C NOTE:
C Since implicit typing is used for all real and integer variables
C a consistent length convention has been adopted to help clarify the
C significance of the variables encountered in the code for this
C utility. All local variable and subroutine parameter identifiers
C are limited to 1,2,or 3 characters. Four character names identify
C members of common blocks. Five and 6 character variable names
C denote PARAMETER constants or subroutine or function names.
C
C Declare the VV common blocks.
C
C IPLVLS - Maximum number of color threshold level values
C IPAGMX - Maximum number of area groups allowed in the area map
C
      PARAMETER (IPLVLS = 256, IPAGMX = 64)
C
C Integer and real common block variables
C
C
      COMMON /VVCOM/
     +                IUD1       ,IVD1       ,IPD1       ,IXDM       ,
     +                IYDN       ,VLOM       ,VHIM       ,ISET       ,
     +                VRMG       ,VRLN       ,VFRC       ,IXIN       ,
     +                IYIN       ,ISVF       ,UUSV       ,UVSV       ,
     +                UPSV       ,IMSK       ,ICPM       ,UVPS       ,
     +                UVPL       ,UVPR       ,UVPB       ,UVPT       ,
     +                UWDL       ,UWDR       ,UWDB       ,UWDT       ,
     +                UXC1       ,UXCM       ,UYC1       ,UYCN       ,
     +                NLVL       ,IPAI       ,ICTV       ,WDLV       ,
     +                UVMN       ,UVMX       ,PMIN       ,PMAX       ,
     +                RVMN       ,RVMX       ,RDMN       ,RDMX       ,
     +                ISPC       ,RVMD       ,IPLR       ,IVST       ,
     +                IVPO       ,ILBL       ,IDPF       ,IMSG       ,
     +                ICLR(IPLVLS)           ,TVLU(IPLVLS)
C
C Arrow size/shape parameters
C
        COMMON / VVARO /
     +                HDSZ       ,HINF       ,HANG       ,IAST       ,
     +                HSIN       ,HCOS       ,FAMN       ,FAMX       ,
     +                UVMG       ,FAIR       ,FAWR       ,FAWF       ,
     +                FAXR       ,FAXF       ,FAYR       ,FAYF       ,
     +                AROX(8)    ,AROY(8)    ,FXSZ       ,FYSZ       ,
     +                FXRF       ,FXMN       ,FYRF       ,FYMN       ,
     +                FWRF       ,FWMN       ,FIRF       ,FIMN       ,
     +                AXMN       ,AXMX       ,AYMN       ,AYMX       ,
     +                IACM       ,IAFO       ,WBAD       ,WBTF       ,
     +                WBCF       ,WBDF       ,WBSC
C
C
C Text related parameters
C
        COMMON /VVTXP /
     +                FCWM    ,ICSZ    ,
     +                FMNS    ,FMNX    ,FMNY    ,IMNP    ,IMNC  ,
     +                FMXS    ,FMXX    ,FMXY    ,IMXP    ,IMXC  ,
     +                FZFS    ,FZFX    ,FZFY    ,IZFP    ,IZFC  ,
     +                FILS    ,FILX    ,FILY    ,IILP    ,IILC  ,
     +                FLBS    ,ILBC

C
C Character variable declartions
C
      CHARACTER*160 CSTR
      PARAMETER (IPCHSZ=36)
      CHARACTER*(IPCHSZ)  CMNT,CMXT,CZFT,CLBT,CILT
C
C Text string parameters
C
      COMMON /VVCHAR/ CSTR,CMNT,CMXT,CZFT,CLBT,CILT
C
      SAVE /VVCOM/, /VVARO/, /VVTXP/, /VVCHAR/
C
C The mapping common block: made available to user mapping routines
C
      COMMON /VVMAP/
     +                IMAP       ,
     +                XVPL       ,XVPR       ,YVPB       ,YVPT       ,
     +                WXMN       ,WXMX       ,WYMN       ,WYMX       ,
     +                XLOV       ,XHIV       ,YLOV       ,YHIV       ,
     +                SXDC       ,SYDC       ,NXCT       ,NYCT       ,
     +                RLEN       ,LNLG       ,INVX       ,INVY       ,
     +                ITRT       ,IWCT       ,FW2W       ,FH2H       ,
     +                DVMN       ,DVMX       ,RBIG       ,IBIG
C
      SAVE /VVMAP/
C
C Math constants
C
      PARAMETER (PDTOR  = 0.017453292519943,
     +           PRTOD  = 57.2957795130823,
     +           P1XPI  = 3.14159265358979,
     +           P2XPI  = 6.28318530717959,
     +           P1D2PI = 1.57079632679489,
     +           P5D2PI = 7.85398163397448)
C
C --------------------------------------------------------------------
      PARAMETER (D2RAD=.017453293)
C
C
C Fill in the reference arrow data
C
c$$$C     parameter WBA wind barb angle
c$$$      WBAD = 62.0
c$$$C     parameter WBS wind barb tic size (fraction of barb length)
c$$$      WBTF = 0.33
c$$$C     parameter WBR wind barb radius (fraction of bl)
c$$$      WBCF = 0.25
c$$$C     parameter WBD wind barb distance between ticks (fraction of bl)
c$$$      WBDF = 0.1
c$$$C     parameter WBC wind barb scale factor
c$$$      WBSC = 1.0
C
C Make sure this does nothing if the style is not wind barb.
C
      IF (IAST .LT. 2) THEN
         RETURN
      END IF

      RAG = IHM * WBAD * D2RAD
C
C Use the first four elements of the fill arrow array to store the
C pennant triangle. Elements 2 and 3 work for the barb line.
C Four and five are used for the half barb line.
C
      AROX(1) = -COS(RAG) * WBTF * DVMX
      AROY(1) = 0.0
      AROX(2) = AROX(1)
      AROY(2) = SIN(RAG) * WBTF * DVMX
      AROX(3) = 0.0
      AROY(3) = 0.0
      AROX(4) = 0.0
      AROY(4) = AROX(1)
      AROX(5) = -0.5 * COS(RAG) * WBTF * DVMX
      AROY(5) = 0.5 * SIN(RAG) * WBTF * DVMX
      AROX(6) = 0.0
      AROY(6) = 0.0
C
      RETURN
      END


C
C
      SUBROUTINE ANEOSS (IGK,ITAPE)
C
C***********************************************************************
C
C     PART OF SET UP FOR ANEOS PACKAGE
C
C     THIS ROUTINE WAS PART OF ANEOS2 - SEPARATED TO MINIMIZE STORAGE
C     WHEN ONLY RESET WRITE OR READ IS NEEDED - ALSO RAD TURN OFF.
C
C     INPUTS
C
C       IGK = 1
C           = 2   WRITE RESTART FILE ITAPE
C           = 3   READ RESTART FILE ITAPE
C           = 4   TURN RADIATION OPACITY CALCULATION OFF
C
C************************************** 8/87 version slt ***************
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /FILEOS/ KLST, KINP
C     maximum number of aneos eos - must be 10 for csq
      PARAMETER (MAXMAT=10)
      COMMON /ANES/  ACK(99*MAXMAT),ZZS(30*MAXMAT),COT(30*MAXMAT)
     1 ,FNI(30*MAXMAT),RCT(MAXMAT+1),TCT(MAXMAT+1),RSOL(100*MAXMAT)
     2 ,RVAP(100*MAXMAT),TTWO(100*MAXMAT),SAVER(92),BOLTS,EIP(4370)
     3 ,LOCSV(MAXMAT+1),LOCKP(MAXMAT+1),LOCKPL(MAXMAT+1),NOTRAD
      COMMON /ANZB/ ZB(92), ZRAT
C     vector buffer size
      PARAMETER (MATBUF=64)
C     the following contains sqrt(t(i)) for vector aneos entry
C     ipsqts points to current value
      COMMON /ANESQT/ SQTS(MATBUF),IPSQTS
      COMMON /MIXCON/  RHOMPH(MAXMAT),RHOMPL(MAXMAT),IPEOS
      COMMON /ANZLTF/ ZLTOMF
      SAVE   /FILEOS/,/MIXCON/,/ANES/,/ANZB/
      IF(IGK.NE.2) CALL ANZRTR
      ZRAT=0.000045D0
      IPSQTS=1
C
      IF(IGK.EQ.4) THEN
C       RADIATION OPACITY FLAG
        NOTRAD=0
        GO TO 130
C
      ELSEIF(IGK.EQ.2) THEN
C       write restart data
        WRITE (ITAPE) ACK,ZZS,COT,FNI,RCT,TCT,RSOL,RVAP,TTWO,SAVER
     1      ,BOLTS,EIP,LOCSV,LOCKP,LOCKPL,NOTRAD
C
      ELSE
C       read restart data
        READ (ITAPE,ERR=120,END=120)
     1       ACK,ZZS,COT,FNI,RCT,TCT,RSOL,RVAP,TTWO,SAVER
     2      ,BOLTS,EIP,LOCSV,LOCKP,LOCKPL,NOTRAD
        IPEOS=1
        ZLTOMF=-1.
      END IF
      GO TO 130
C
  120 CONTINUE
      CALL ANMARK('eof or error reading aneos restart')
      STOP
  130 CONTINUE
      RETURN
      END


*dk,flip1to0
      subroutine flip1to0(it1,npoints,ntets)
C
C ######################################################################
C
C     PURPOSE -
C
C        This routine flips removes boundary tets that have exactly
C        two boundary faces.
C
C     INPUT ARGUMENTS -
C
C        it1      - the tet to remove
C
C     OUTPUT ARGUMENTS -
C
C        None
C
C     CHANGE HISTORY -
C
C        $Log: flip1to0.f,v $
C        Revision 2.00  2007/11/05 19:45:55  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.7   Wed Feb 03 15:30:02 1999   dcg
CPVCS    remove calls to fluxing routines and associated memory.
CPVCS
CPVCS       Rev 1.6   Mon Apr 14 16:48:20 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.5   Mon Jun 03 15:13:58 1996   dcg
CPVCS    hp changes
CPVCS
CPVCS       Rev 1.4   Mon May 06 12:28:48 1996   dcg
CPVCS    use itsttp to test for point types
CPVCS
CPVCS       Rev 1.3   12/02/94 15:05:10   het
CPVCS    Added an option for the "cmo" access functions
CPVCS
CPVCS
CPVCS       Rev 1.2   12/01/94 18:46:52   het
CPVCS    Added a data type to the "cmo" calles
CPVCS       and added the "cmo.h" include file.
CPVCS
CPVCS       Rev 1.1   11/17/94 21:51:10   het
CPVCS    Added include files for chydro, neibor, cmerge, comdict. Added calles and
CPVCS    pointer statements for current_mesh_object database access.
CPVCS
CPVCS       Rev 1.0   11/10/94 12:12:28   pvcs
CPVCS    Original version.
C
C ######################################################################
      implicit none
C
      include "cmo.h"
      include "chydro.h"
      include "neibor.h"

C arguments (it1,npoints,ntets)
      integer it1,npoints,ntets

C variables
      integer i,j,k,i1,i2,i3,i4
      integer ierror,length,icmotype,lenitp1,lenxic,lenyic,lenzic,
     *        lenitet,lenjtet,iepos,ip1,ip2,ip3,ip4,itsum,
     *        ierrdum,ione
C
      logical itsttp
      character*4 if1,if2,if3,if4

      real*8 volit

C MACROS statement functions
      real*8 crosx1,crosy1,crosz1,volume
      crosx1(i,j,k)=(yic(j)-yic(i))*(zic(k)-zic(i))-
     *              (yic(k)-yic(i))*(zic(j)-zic(i))
      crosy1(i,j,k)=(xic(k)-xic(i))*(zic(j)-zic(i))-
     *              (xic(j)-xic(i))*(zic(k)-zic(i))
      crosz1(i,j,k)=(xic(j)-xic(i))*(yic(k)-yic(i))-
     *              (xic(k)-xic(i))*(yic(j)-yic(i))
      volume(i1,i2,i3,i4)=(xic(i4)-xic(i1))*crosx1(i1,i2,i3)+
     *                    (yic(i4)-yic(i1))*crosy1(i1,i2,i3)+
     *                    (zic(i4)-zic(i1))*crosz1(i1,i2,i3)

C ######################################################################
C BEGIN begin
C
C     ******************************************************************
C     FETCH MESH OBJECT NAME AND POINTER INFORMATION.
C
      if(icmoget.eq.1) then
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_info('mbndry',cmo,mbndry,length,icmotype,ierror)
      call cmo_get_info('itp1',cmo,ipitp1,lenitp1,icmotype,ierror)
      call cmo_get_info('xic',cmo,ipxic,lenxic,icmotype,ierror)
      call cmo_get_info('yic',cmo,ipyic,lenyic,icmotype,ierror)
      call cmo_get_info('zic',cmo,ipzic,lenzic,icmotype,ierror)
      call cmo_get_info('itet',cmo,ipitet,lenitet,icmotype,ierror)
      call cmo_get_info('jtet',cmo,ipjtet,lenjtet,icmotype,ierror)
C
      endif
C
C     ******************************************************************
C
C
      iepos=0
      do 10 i=1,6
         i1=ielist(4*(i-1)+3)
         i2=ielist(4*(i-1)+4)
         if(jtet(i1,it1).ge.mbndry.and.jtet(i2,it1).ge.mbndry) then
            iepos=i
            goto 11
         endif
 10   continue
      if(iepos.eq.0) goto 9999
      ip1=itet(1,it1)
      ip2=itet(2,it1)
      ip3=itet(3,it1)
      ip4=itet(4,it1)
      if (.not.(itsttp('inteintf',itp1(ip1))).or.
     *    .not.(itsttp('inteintf',itp1(ip2))).or.
     *    .not.(itsttp('inteintf',itp1(ip3))).or.
     *    .not.(itsttp('inteintf',itp1(ip4)))) go to 9999
C
 11   jtet1(jtet(ielist(4*(i-1)+1),it1))=mbndry
      jtet1(jtet(ielist(4*(i-1)+2),it1))=mbndry
C
C     ..................................................................
C     IF THE DEBUG FLAG IS TURNED ON THEN PRINT A SUMMARY OF THE FLIP.
C
      if(idebug.gt.1) then
        itsum=itet(1,it1)+itet(2,it1)+itet(3,it1)+itet(4,it1)
        volit=volume(itet(1,it1),itet(2,it1),itet(3,it1),itet(4,it1))
        i1=itet(1,it1)
        i2=itet(2,it1)
        i3=itet(3,it1)
        i4=itet(4,it1)
        if1=' '
        if(jtet(1,it1).ge.mbndry) if1='*'
        if2=' '
        if(jtet(2,it1).ge.mbndry) if2='*'
        if3=' '
        if(jtet(3,it1).ge.mbndry) if3='*'
        if4=' '
        if(jtet(4,it1).ge.mbndry) if4='*'
        write(logdan,9000) 'flip1to0',it1,'old=',
     *                     i1,if1,i2,if2,i3,if3,i4,if4,
     *                     itsum,volit
 9000   format(a8,' it1=',i8,1x,a4,4(i7,a1),i8,1x,1pe10.3)
        call writloga('bat',0,logdan,0,ierrdum)
      endif
C
      itet(1,it1)=-itet(1,it1)
C
      nvacnt=nvacnt+1
      if(nvacnt.ge.lenvacnt) then
         ione=1
         lenvacnt=lenvacnt+100
         call mflip(ione,lenvacnt,'ivacnt')
      endif
      ivacnt(nvacnt)=it1
C
      goto 9999
 9999 continue
      return
      end


!
! CRTM_AtmAbsorption
!
! Module containing routines to compute the optical depth profile
! due to gaseous absorption.
!
!
! CREATION HISTORY:
!       Modifed by:     Yong Han, NESDIS/STAR 25-June-2008
!                       yong.han@noaa.gov

MODULE CRTM_AtmAbsorption

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds,                 ONLY: fp
  USE Message_Handler,            ONLY: SUCCESS, FAILURE, Display_Message
  USE CRTM_Parameters,            ONLY: ZERO, &
                                        ODAS_ALGORITHM,  ODPS_ALGORITHM, ODSSU_ALGORITHM
  USE CRTM_Atmosphere_Define,     ONLY: CRTM_Atmosphere_type
  USE CRTM_TauCoeff,              ONLY: TC
  USE CRTM_AncillaryInput_Define, ONLY: CRTM_AncillaryInput_type
  USE CRTM_GeometryInfo_Define,   ONLY: CRTM_GeometryInfo_type, &
                                        CRTM_GeometryInfo_GetValue
  USE CRTM_AtmOptics_Define,      ONLY: CRTM_AtmOptics_type
  USE CRTM_Predictor_Define,      ONLY: CRTM_Predictor_type
  ! ODAS modules
  USE ODAS_AtmAbsorption,         ONLY: ODAS_AAVar_type => iVar_type , &
                                        ODAS_Compute_AtmAbsorption   , &
                                        ODAS_Compute_AtmAbsorption_TL, &
                                        ODAS_Compute_AtmAbsorption_AD
  ! ODPS modules
  USE ODPS_AtmAbsorption,         ONLY: ODPS_AAVar_type => iVar_type , &
                                        ODPS_Compute_AtmAbsorption   , &
                                        ODPS_Compute_AtmAbsorption_TL, &
                                        ODPS_Compute_AtmAbsorption_AD
  ! ODSSU modules
  USE ODSSU_AtmAbsorption,        ONLY: ODSSU_AAVar_type => iVar_type , &
                                        ODSSU_Compute_Weights         , &
                                        ODSSU_Compute_AtmAbsorption   , &
                                        ODSSU_Compute_AtmAbsorption_TL, &
                                        ODSSU_Compute_AtmAbsorption_AD
  ! ODZeeman modules
  USE ODZeeman_AtmAbsorption,     ONLY: Zeeman_Compute_AtmAbsorption,    &
                                        Zeeman_Compute_AtmAbsorption_TL, &
                                        Zeeman_Compute_AtmAbsorption_AD, &
                                        Is_Zeeman_Channel

  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Datatypes
  PUBLIC :: iVar_type
  ! Procedures
  PUBLIC :: CRTM_Compute_AtmAbsorption
  PUBLIC :: CRTM_Compute_AtmAbsorption_TL
  PUBLIC :: CRTM_Compute_AtmAbsorption_AD

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  '$Id: CRTM_AtmAbsorption.f90 99117 2017-11-27 18:37:14Z tong.zhu@noaa.gov $'
  ! Message string length
  INTEGER, PARAMETER :: ML = 256

  ! ---------------------------------------------
  ! Structure to hold AtmAbsorption forward model
  ! variables across FWD, TL, and AD calls
  ! ---------------------------------------------
  !:tdoc+:
  TYPE :: iVar_type
    PRIVATE
    TYPE(ODAS_AAVar_type)   :: ODAS
    TYPE(ODPS_AAVar_type)   :: ODPS
    TYPE(ODSSU_AAVar_type)  :: ODSSU
  END TYPE iVar_type
  !:tdoc-:

CONTAINS

!################################################################################
!################################################################################
!##                                                                            ##
!##                         ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_Compute_AtmAbsorption
!
! PURPOSE:
!       Subroutine to calculate the layer optical depths due to gaseous
!       absorption for a given sensor and channel and atmospheric profile.
!       It is a wrapper which calls the algorithm-specific routine.
!
! CALLING SEQUENCE:
!       CALL CRTM_Compute_AtmAbsorption( &
!              SensorIndex   , &  ! Input
!              ChannelIndex  , &  ! Input
!              AncillaryInput, &  ! Input
!              Predictor     , &  ! Input
!              AtmOptics     , &  ! Output
!              iVar            )  ! Internal variable output
!
! INPUTS:
!       SensorIndex:
!         Sensor index id. This is a unique index associated
!         with a (supported) sensor used to access the
!         shared coefficient data for a particular sensor.
!         See the ChannelIndex argument.
!         UNITS:      N/A
!         TYPE:       INTEGER
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN)
!
!       ChannelIndex:
!         Channel index id. This is a unique index associated
!         with a (supported) sensor channel used to access the
!         shared coefficient data for a particular sensor's
!         channel.
!         See the SensorIndex argument.
!         UNITS:      N/A
!         TYPE:       INTEGER
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN)
!
!       AncillaryInput:
!         Structure holding ancillary inputs
!         UNITS:      N/A
!         TYPE:       AncillaryInput_type
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN)
!
!       Predictor:
!         Structure containing the integrated absorber and
!         predictor profile data.
!         UNITS:      N/A
!         TYPE:       CRTM_Predictor_type
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       AtmOptics:
!         Structure containing computed optical depth profile data.
!         UNITS:      N/A
!         TYPE:       CRTM_AtmOptics_type
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN OUT)
!
!       iVar:
!         Structure containing internal variables required for
!         subsequent tangent-linear or adjoint model calls.
!         The contents of this structure are NOT accessible
!         outside of this module.
!         UNITS:      N/A
!         TYPE:       iVar_type
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!------------------------------------------------------------------------------

  SUBROUTINE CRTM_Compute_AtmAbsorption( &
    SensorIndex   , &  ! Input
    ChannelIndex  , &  ! Input
    AncillaryInput, &  ! Input
    Predictor     , &  ! Input
    AtmOptics     , &  ! Output
    iVar            )  ! Internal variable output
    ! Arguments
    INTEGER                       , INTENT(IN)     :: SensorIndex
    INTEGER                       , INTENT(IN)     :: ChannelIndex
    TYPE(CRTM_AncillaryInput_type), INTENT(IN)     :: AncillaryInput
    TYPE(CRTM_Predictor_type)     , INTENT(IN OUT) :: Predictor
    TYPE(CRTM_AtmOptics_type)     , INTENT(IN OUT) :: AtmOptics
    TYPE(iVar_type)               , INTENT(IN OUT) :: iVar
    ! Local variables
    INTEGER :: idx

    ! Is this a Zeeman channel?
    idx = TC%ZSensor_LoIndex(SensorIndex)
    IF( idx > 0 )THEN
      IF( Is_Zeeman_Channel(TC%ODZeeman(idx), ChannelIndex) )THEN
        CALL Zeeman_Compute_AtmAbsorption( &
               TC%ODZeeman(idx)  , &  ! Input
               ChannelIndex      , &  ! Input
               Predictor%ODZeeman, &  ! Input
               AtmOptics           )  ! Output
        RETURN
      END IF
    END IF

    ! Call required model
    idx = TC%Sensor_LoIndex(SensorIndex)
    SELECT CASE( TC%Algorithm_ID(SensorIndex) )

      ! ODAS transmittance model
      CASE( ODAS_ALGORITHM )
        CALL ODAS_Compute_AtmAbsorption( &
               TC%ODAS(idx)  , &  ! Input
               ChannelIndex  , &  ! Input
               Predictor%ODAS, &  ! Input
               AtmOptics     , &  ! Output
               iVar%ODAS       )  ! Internal variable output

      ! ODPS transmittance model
      CASE( ODPS_ALGORITHM )
        CALL ODPS_Compute_AtmAbsorption( &
               TC%ODPS(idx)  , &  ! Input
               ChannelIndex  , &  ! Input
               Predictor%ODPS, &  ! Input
               AtmOptics       )  ! Output

      ! SSU instrument specific
      CASE( ODSSU_ALGORITHM )
        CALL ODSSU_Compute_Weights( &
               AncillaryInput%SSU, &  ! Input
               SensorIndex       , &  ! Input
               ChannelIndex      , &  ! Input
               iVar%ODSSU          )  ! Internal variable output

        ! ...Select particular transmittance algorithm for this instrument
        SELECT CASE( TC%ODSSU(idx)%subAlgorithm )
          CASE( ODAS_ALGORITHM )
            CALL ODSSU_Compute_AtmAbsorption( &
                   TC%Sensor_LoIndex(SensorIndex), &  ! Input
                   ChannelIndex                  , &  ! Input
                   Predictor%ODAS                , &  ! Input
                   AtmOptics                     , &  ! Output
                   iVar%ODSSU                      )  ! Internal variable output
          CASE( ODPS_ALGORITHM )
            CALL ODSSU_Compute_AtmAbsorption( &
                   TC%Sensor_LoIndex(SensorIndex), &  ! Input
                   ChannelIndex                  , &  ! Input
                   Predictor%ODPS                , &  ! Input
                   AtmOptics                     , &  ! Output
                   iVar%ODSSU                      )  ! Internal variable output
        END SELECT
    END SELECT

  END SUBROUTINE CRTM_Compute_AtmAbsorption

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CRTM_Compute_AtmAbsorption_TL
!
! PURPOSE:
!       Subroutine to calculate the tangent-linear layer optical depths due
!       to gaseous absorption for a given sensor and channel and atmospheric
!       profile. It is a wrapper which calls the algorithm specific routine.
!
! CALLING SEQUENCE:
!       CALL CRTM_Compute_AtmAbsorption_TL( &
!              SensorIndex   , &  ! Input
!              ChannelIndex  , &  ! Input
!              Predictor     , &  ! FWD Input
!              Predictor_TL  , &  ! TL Input
!              AtmOptics_TL  , &  ! TL Output
!              iVar            )  ! Internal variable input
!
! INPUTS:
!       SensorIndex:
!         Sensor index id. This is a unique index associated
!         with a (supported) sensor used to access the
!         shared coefficient data for a particular sensor.
!         See the ChannelIndex argument.
!         UNITS:      N/A
!         TYPE:       INTEGER
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN)
!
!       ChannelIndex:
!         Channel index id. This is a unique index associated
!         with a (supported) sensor channel used to access the
!         shared coefficient data for a particular sensor's
!         channel.
!         See the SensorIndex argument.
!         UNITS:      N/A
!         TYPE:       INTEGER
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN)
!
!       Predictor:
!         Structure containing the integrated absorber and
!         predictor profile data.
!         UNITS:      N/A
!         TYPE:       CRTM_Predictor_type
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN)
!
!       Predictor_TL:
!         Structure containing the tangent-linearintegrated absorber and
!         predictor profile data.
!         UNITS:      N/A
!         TYPE:       CRTM_Predictor_type
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN)
!
!       iVar:
!         Structure containing internal variables required for
!         subsequent tangent-linear or adjoint model calls.
!         The contents of this structure are NOT accessible
!         outside of this module.
!         UNITS:      N/A
!         TYPE:       iVar_type
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       AtmOptics_TL:
!         Structure containing the computed tangent-linear
!         optical depth profile data.
!         UNITS:      N/A
!         TYPE:       CRTM_AtmOptics_type
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN OUT)
!
! :sdoc-:
!------------------------------------------------------------------------------

  SUBROUTINE CRTM_Compute_AtmAbsorption_TL( &
    SensorIndex   , &  ! Input
    ChannelIndex  , &  ! Input
    Predictor     , &  ! Input
    Predictor_TL  , &  ! Input
    AtmOptics_TL  , &  ! Output
    iVar            )  ! Internal variable input
    ! Arguments
    INTEGER                  , INTENT(IN)     :: SensorIndex
    INTEGER                  , INTENT(IN)     :: ChannelIndex
    TYPE(CRTM_Predictor_type), INTENT(IN)     :: Predictor
    TYPE(CRTM_Predictor_type), INTENT(IN OUT) :: Predictor_TL
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics_TL
    TYPE(iVar_type)          , INTENT(IN)     :: iVar
    ! Local variables
    INTEGER :: idx

    ! Is this a Zeeman channel?
    idx = TC%ZSensor_LoIndex(SensorIndex)
    IF( idx > 0 )THEN
      IF( Is_Zeeman_Channel(TC%ODZeeman(idx), ChannelIndex) )THEN
        CALL Zeeman_Compute_AtmAbsorption_TL( &
               TC%ODZeeman(idx)     , &  ! Input
               ChannelIndex         , &  ! Input
               Predictor%ODZeeman   , &  ! Input
               Predictor_TL%ODZeeman, &  ! Input
               AtmOptics_TL           )  ! Output
        RETURN
      END IF
    END IF

    ! Call required model
    idx = TC%Sensor_LoIndex(SensorIndex)
    SELECT CASE( TC%Algorithm_ID(SensorIndex) )

      ! ODAS transmittance model
      CASE( ODAS_ALGORITHM )
        CALL ODAS_Compute_AtmAbsorption_TL( &
               TC%ODAS(idx)     , &  ! Input
               ChannelIndex     , &  ! Input
               Predictor%ODAS   , &  ! Input
               Predictor_TL%ODAS, &  ! Input
               AtmOptics_TL     , &  ! Output
               iVar%ODAS          )  ! Internal variable input

      ! ODPS transmittance model
      CASE( ODPS_ALGORITHM )
        CALL ODPS_Compute_AtmAbsorption_TL( &
               TC%ODPS(idx)     , &  ! Input
               ChannelIndex     , &  ! Input
               Predictor%ODPS   , &  ! Input
               Predictor_TL%ODPS, &  ! Input
               AtmOptics_TL       )  ! Output

      ! SSU instrument specific
      CASE( ODSSU_ALGORITHM )

        ! ...Select particular transmittance algorithm for this instrument
        SELECT CASE( TC%ODSSU(idx)%subAlgorithm )
          CASE( ODAS_ALGORITHM )
            CALL ODSSU_Compute_AtmAbsorption_TL( &
                   TC%Sensor_LoIndex(SensorIndex), &  ! Input
                   ChannelIndex                  , &  ! Input
                   Predictor%ODAS                , &  ! Input
                   Predictor_TL%ODAS             , &  ! Input
                   AtmOptics_TL                  , &  ! Output
                   iVar%ODSSU                      )  ! Internal variable input
          CASE( ODPS_ALGORITHM )
            CALL ODSSU_Compute_AtmAbsorption_TL( &
                   TC%Sensor_LoIndex(SensorIndex), &  ! Input
                   ChannelIndex                  , &  ! Input
                   Predictor%ODPS                , &  ! Input
                   Predictor_TL%ODPS             , &  ! Input
                   AtmOptics_TL                  , &  ! Output
                   iVar%ODSSU                      )  ! Internal variable input
        END SELECT
    END SELECT

  END SUBROUTINE CRTM_Compute_AtmAbsorption_TL

!--------------------------------------------------------------------------------
!
! NAME:
!       CRTM_Compute_AtmAbsorption_AD
!
! PURPOSE:
!       Subroutine to calculate the layer optical depth adjoints due to
!       gaseous absorption for a given sensor and channel and atmospheric
!       profile. It is a wrapper which calls the algorithm specific routine.
!
! CALLING SEQUENCE:
!       CALL CRTM_Compute_AtmAbsorption_AD( &
!              SensorIndex , &  ! Input
!              ChannelIndex, &  ! Input
!              Predictor   , &  ! FWD Input
!              AtmOptics_AD, &  ! AD  Input
!              Predictor_AD, &  ! AD  Output
!              iVar          )  ! Internal variable input
!
! INPUT ARGUMENTS:
!       SensorIndex:
!         Sensor index id. This is a unique index associated
!         with a (supported) sensor used to access the
!         shared coefficient data for a particular sensor.
!         See the ChannelIndex argument.
!         UNITS:      N/A
!         TYPE:       INTEGER
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN)
!
!       ChannelIndex:
!         Channel index id. This is a unique index associated
!         with a (supported) sensor channel used to access the
!         shared coefficient data for a particular sensor's
!         channel.
!         See the SensorIndex argument.
!         UNITS:      N/A
!         TYPE:       INTEGER
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN)
!
!       Predictor:
!         Structure containing the integrated absorber and
!         predictor profile data.
!         UNITS:      N/A
!         TYPE:       CRTM_Predictor_type
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN)
!
!       AtmOptics_AD:
!         Structure containing the computed adjoint optical depth profile data.
!         UNITS:      N/A
!         TYPE:       CRTM_AtmOptics_type
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN OUT)
!
!       iVar:
!         Structure containing internal variables required for
!         subsequent tangent-linear or adjoint model calls.
!         The contents of this structure are NOT accessible
!         outside of this module.
!         UNITS:      N/A
!         TYPE:       iVar_type
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN)
!
! OUTPUT ARGUMENTS:
!       Predictor_AD:
!         Structure containing the adjoint integrated absorber and
!         predictor profile data.
!         UNITS:      N/A
!         TYPE:       CRTM_Predictor_type
!         DIMENSION:  Scalar
!         ATTRIBUTES: INTENT(IN OUT)
!
! SIDE EFFECTS:
!       Components of the AtmOptics_AD structure argument are modified
!       in this function.
!
!:sdoc-:
!------------------------------------------------------------------------------

  SUBROUTINE CRTM_Compute_AtmAbsorption_AD( &
    SensorIndex , &  ! Input
    ChannelIndex, &  ! Input
    Predictor   , &  ! FWD Input
    AtmOptics_AD, &  ! AD  Input
    Predictor_AD, &  ! AD  Output
    iVar          )  ! Internal variable input
    ! Arguments
    INTEGER                  , INTENT(IN)     :: SensorIndex
    INTEGER                  , INTENT(IN)     :: ChannelIndex
    TYPE(CRTM_Predictor_type), INTENT(IN)     :: Predictor
    TYPE(CRTM_AtmOptics_type), INTENT(IN OUT) :: AtmOptics_AD
    TYPE(CRTM_Predictor_type), INTENT(IN OUT) :: Predictor_AD
    TYPE(iVar_type)          , INTENT(IN)     :: iVar
    ! Local variables
    INTEGER :: idx

    ! Is this a Zeeman channel?
    idx = TC%ZSensor_LoIndex(SensorIndex)
    IF( idx > 0 )THEN
      IF( Is_Zeeman_Channel(TC%ODZeeman(idx), ChannelIndex) )THEN
        CALL Zeeman_Compute_AtmAbsorption_AD( &
               TC%ODZeeman(idx)     , &  ! Input
               ChannelIndex         , &  ! Input
               Predictor%ODZeeman   , &  ! Input
               AtmOptics_AD         , &  ! AD Input
               Predictor_AD%ODZeeman  )  ! AD Output
        RETURN
      END IF
    END IF

    ! Call required model
    idx = TC%Sensor_LoIndex(SensorIndex)
    SELECT CASE( TC%Algorithm_ID(SensorIndex) )

      ! ODAS transmittance model
      CASE( ODAS_ALGORITHM )
        CALL ODAS_Compute_AtmAbsorption_AD( &
               TC%ODAS(idx)     , &  ! Input
               ChannelIndex     , &  ! Input
               Predictor%ODAS   , &  ! FWD Input
               AtmOptics_AD     , &  ! AD Input
               Predictor_AD%ODAS, &  ! AD Output
               iVar%ODAS          )  ! Internal variable input

      ! ODPS transmittance model
      CASE( ODPS_ALGORITHM )
        CALL ODPS_Compute_AtmAbsorption_AD( &
               TC%ODPS(idx)     , &  ! Input
               ChannelIndex     , &  ! Input
               Predictor%ODPS   , &  ! FWD Input
               AtmOptics_AD     , &  ! AD Input
               Predictor_AD%ODPS  )  ! AD Output

      ! SSU instrument specific
      CASE( ODSSU_ALGORITHM )

        ! Select particular transmittance algorithm for this instrument
        SELECT CASE( TC%ODSSU(idx)%subAlgorithm )
          CASE( ODAS_ALGORITHM )
            CALL ODSSU_Compute_AtmAbsorption_AD( &
                   TC%Sensor_LoIndex(SensorIndex), &  ! Input
                   ChannelIndex                  , &  ! Input
                   Predictor%ODAS                , &  ! FWD Input
                   AtmOptics_AD                  , &  ! AD Input
                   Predictor_AD%ODAS             , &  ! AD Output
                   iVar%ODSSU                      )  ! Internal variable input
          CASE( ODPS_ALGORITHM )
            CALL ODSSU_Compute_AtmAbsorption_AD( &
                   TC%Sensor_LoIndex(SensorIndex), &  ! Input
                   ChannelIndex                  , &  ! Input
                   Predictor%ODPS                , &  ! FWD Input
                   AtmOptics_AD                  , &  ! AD Input
                   Predictor_AD%ODPS             , &  ! AD Output
                   iVar%ODSSU                      )  ! Internal variable input
        END SELECT
    END SELECT

  END SUBROUTINE CRTM_Compute_AtmAbsorption_AD

END MODULE CRTM_AtmAbsorption


      SUBROUTINE PRTDRC(ESCF,DELTT,XPARAM,REF,EKIN,GTOT,ETOT,VELO0,NVAR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION XPARAM(*), VELO0(*), REF(*)
*********************************************************************
*
*    PRTDRC PREPARES TO PRINT THE GEOMETRY ETC. FOR POINTS IN A DRC
*    OR IRC
*    CALCULATION.
*    ON INPUT  ESCF   = HEAT OF FORMATION FOR THE CURRENT POINT
*              DELTT  = CHANGE IN TIME, PREVIOUS TO CURRENT POINT
*              XPARAM = CURRENT CARTESIAN GEOMETRY
*              EKIN   = CURRENT KINETIC ENERGY
*              GTOT   = TOTAL GRADIENT NORM IN IRC CALC'N.
*              VELO0  = CURRENT VELOCITY
*              NVAR   = NUMBER OF VARIABLES = 3 * NUMBER OF ATOMS.
*
********************************************************************
      INCLUDE 'SIZES'
      COMMON /KEYWRD/ KEYWRD
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,XRACT
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM)
      COMMON /DRCCOM/  MCOPRT(2,MAXPAR), NCOPRT, PARMAX
      COMMON /CORE  / CORE(107)
      COMMON /ATMASS/ ATMASS(NUMATM)
      COMMON /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK)
      COMMON /FMATRX/ ALLXYZ(3,MAXPAR),ALLVEL(3,MAXPAR),PARREF(MAXPAR),
     1XYZ3(3,MAXPAR),VEL3(3,MAXPAR), ALLGEO(3,MAXPAR), GEO3(3,MAXPAR),
     2 DUMMY(MAXHES-19*MAXPAR)
      DIMENSION ESCF3(3),EKIN3(3), GTOT3(3), CHARGE(NUMATM), XOLD3(3),
     1GEO(3*NUMATM), VREF(MAXPAR), VREF0(MAXPAR), TSTEPS(100), ETOT3(3),
     2XTOT3(3)
      LOGICAL FIRST, FIRST1, TURN, PARMAX, LDRC, GOTURN
      CHARACTER*80 KEYWRD, TEXT1*3, TEXT2*2,  COTYPE(3)*2
      DATA FIRST1,FIRST/2*.TRUE./,REFSCF/0.D0/
      DATA COTYPE/'BL','BA','DI'/
      IF (FIRST) THEN
         SQRT2=SQRT(2.D0)
         DO 10 I=1,NVAR
   10    PARREF(I)=XPARAM(I)
         ETOT=ESCF+EKIN
         TLAST=0.D0
         GOTURN=.FALSE.
         SUM=0.D0
         DO 20 I=1,NVAR
            SUM=SUM+VELO0(I)**2
            VREF0(I)=VELO0(I)
   20    VREF(I)=VELO0(I)
         IONE=1
         LDRC=(SUM.GT.1.D0)
         FIRST=.FALSE.
         ILOOP=1
         OLDT=-100.D0
         TOLD1=0.0D0
C
C       DETERMINE TYPE OF PRINT: TIME, ENERGY OR GEOMETRY PRIORITY
C       OR PRINT ALL POINTS
C
         STEPT=0.D0
         STEPH=0.D0
         STEPX=0.D0
         IF(INDEX(KEYWRD,' T-PRIO').NE.0)THEN
            IF(INDEX(KEYWRD,' T-PRIORITY=').NE.0)THEN
               STEPT=READA(KEYWRD,INDEX(KEYWRD,'T-PRIO')+5)
            ELSE
               STEPT=0.1D0
            ENDIF
            TREF=-1.D-6
            WRITE(6,'(/,'' TIME PRIORITY, INTERVAL ='',F4.1,
     1'' FEMTOSECONDS'',/)')STEPT
         ELSEIF(INDEX(KEYWRD,' H-PRIO').NE.0)THEN
            IF(INDEX(KEYWRD,' H-PRIORITY=').NE.0)THEN
               STEPH=READA(KEYWRD,INDEX(KEYWRD,'H-PRIO')+5)
            ELSE
               STEPH=0.1D0
            ENDIF
            WRITE(6,'(/,'' KINETIC ENERGY PRIORITY, STEP ='',F5.2,
     1'' KCAL/MOLE'',/)')STEPH
         ELSEIF(INDEX(KEYWRD,' X-PRIO').NE.0)THEN
            IF(INDEX(KEYWRD,' X-PRIORITY=').NE.0)THEN
               STEPX=READA(KEYWRD,INDEX(KEYWRD,'X-PRIO')+5)
            ELSE
               STEPX=0.05D0
            ENDIF
            WRITE(6,'(/,'' GEOMETRY PRIORITY, STEP ='',F5.2,
     1'' ANGSTROMS'',/)')STEPX
         ENDIF
         IF(INDEX(KEYWRD,' REST').NE.0.AND.INDEX(KEYWRD,'IRC=').EQ.0) TH
     1EN
            READ(9,*)(PARREF(I),I=1,NVAR)
            READ(9,*)(VREF0(I),I=1,NVAR)
            READ(9,*)(VREF(I),I=1,NVAR)
            READ(9,*)(ALLGEO(3,I),I=1,NVAR)
            READ(9,*)(ALLGEO(2,I),I=1,NVAR)
            READ(9,*)(ALLGEO(1,I),I=1,NVAR)
            READ(9,*)(ALLVEL(3,I),I=1,NVAR)
            READ(9,*)(ALLVEL(2,I),I=1,NVAR)
            READ(9,*)(ALLVEL(1,I),I=1,NVAR)
            READ(9,*)(ALLXYZ(3,I),I=1,NVAR)
            READ(9,*)(ALLXYZ(2,I),I=1,NVAR)
            READ(9,*)(ALLXYZ(1,I),I=1,NVAR)
            READ(9,*)ILOOP,LDRC,IONE,ETOT1,ETOT0,ESCF1,ESCF0,EKIN1,EKIN0
     1,TOLD2,TOLD1,GTOT1,GTOT0,XOLD2,XOLD1,XOLD0,TOTIME,JLOOP,ETOT,REFX
         ENDIF
      ENDIF
      IF(ESCF.LT.-1.D8) THEN
         WRITE(9,*)(PARREF(I),I=1,NVAR)
         WRITE(9,*)(VREF0(I),I=1,NVAR)
         WRITE(9,*)(VREF(I),I=1,NVAR)
         WRITE(9,*)(ALLGEO(3,I),I=1,NVAR)
         WRITE(9,*)(ALLGEO(2,I),I=1,NVAR)
         WRITE(9,*)(ALLGEO(1,I),I=1,NVAR)
         WRITE(9,*)(ALLVEL(3,I),I=1,NVAR)
         WRITE(9,*)(ALLVEL(2,I),I=1,NVAR)
         WRITE(9,*)(ALLVEL(1,I),I=1,NVAR)
         WRITE(9,*)(ALLXYZ(3,I),I=1,NVAR)
         WRITE(9,*)(ALLXYZ(2,I),I=1,NVAR)
         WRITE(9,*)(ALLXYZ(1,I),I=1,NVAR)
         WRITE(9,*)ILOOP,LDRC,IONE,ETOT1,ETOT0,ESCF1,ESCF0,EKIN1,EKIN0,
     1TOLD2,TOLD1,GTOT1,GTOT0,XOLD2,XOLD1,XOLD0,TOTIME,JLOOP,ETOT,REFX
         RETURN
      ENDIF
      CALL CHRGE(P,CHARGE)
      DO 30 I=1,NUMAT
         L=NAT(I)
   30 CHARGE(I)=CORE(L) - CHARGE(I)
      DELTAT=DELTT*1.D15
      NA(2)=-1
      CALL XYZINT(XPARAM,NUMAT,NA,NB,NC,57.29577951D0,GEO)
      NA(1)=99
      IF(ILOOP.EQ.1)THEN
         ETOT1=ETOT0
         ETOT0=ETOT
         ESCF1=ESCF
         ESCF0=ESCF
         EKIN1=EKIN
         EKIN0=EKIN
         DO 40 J=1,3
            DO 40 I=1,NVAR
               ALLGEO(J,I)=GEO(I)
               ALLXYZ(J,I)=XPARAM(I)
   40    ALLVEL(J,I)=VELO0(I)
      ELSE
         DO 50 I=1,NVAR
            ALLGEO(3,I)=ALLGEO(2,I)
            ALLGEO(2,I)=ALLGEO(1,I)
            ALLGEO(1,I)=GEO(I)
            ALLXYZ(3,I)=ALLXYZ(2,I)
            ALLXYZ(2,I)=ALLXYZ(1,I)
            ALLXYZ(1,I)=XPARAM(I)
            ALLVEL(3,I)=ALLVEL(2,I)
            ALLVEL(2,I)=ALLVEL(1,I)
   50    ALLVEL(1,I)=VELO0(I)
      ENDIF
C
C  FORM QUADRATIC EXPRESSION FOR POSITION AND VELOCITY W.R.T. TIME.
C
      T1=MAX(TOLD2,0.02D0)
      T2=MAX(TOLD1,0.02D0)+T1
      DO 60 I=1,NVAR
         CALL QUADR(ALLGEO(3,I),ALLGEO(2,I),ALLGEO(1,I),T1,T2,
     1GEO3(1,I),GEO3(2,I),GEO3(3,I))
C
****************************************************
*                                                  *
*    QUADR CALCULATES THE A, B AND C IN THE EQUNS. *
*                                                  *
*     A                   =   F0                   *
*     A + B.X0 + C.X0**2  =   F1                   *
*     A + B.X2 + C.X2**2  =   F2                   *
* GIVEN THE ARGUMENT LIST (F0,F1,F2, X1,X2, A,B,C) *
*                                                  *
****************************************************
         CALL QUADR(ALLXYZ(3,I),ALLXYZ(2,I),ALLXYZ(1,I),T1,T2,
     1XYZ3(1,I),XYZ3(2,I),XYZ3(3,I))
         CALL QUADR(ALLVEL(3,I),ALLVEL(2,I),ALLVEL(1,I),T1,T2,
     1VEL3(1,I),VEL3(2,I),VEL3(3,I))
   60 CONTINUE
      ETOT2=ETOT1
      ETOT1=ETOT0
      ETOT0=ETOT
      CALL QUADR(ETOT2,ETOT1,ETOT0,T1,T2,ETOT3(1),ETOT3(2),
     1ETOT3(3))
      EKIN2=EKIN1
      EKIN1=EKIN0
      EKIN0=EKIN
      CALL QUADR(EKIN2,EKIN1,EKIN0,T1,T2,EKIN3(1),EKIN3(2),
     1EKIN3(3))
      ESCF2=ESCF1
      ESCF1=ESCF0
      ESCF0=ESCF
      CALL QUADR(ESCF2,ESCF1,ESCF0,T1,T2,ESCF3(1),ESCF3(2),
     1ESCF3(3))
      GTOT2=GTOT1
      GTOT1=GTOT0
      GTOT0=GTOT
      CALL QUADR(GTOT2,GTOT1,GTOT0,T1,T2,GTOT3(1),GTOT3(2),
     1GTOT3(3))
      XTOT2=XTOT1
      XTOT1=XTOT0
      XOLD2=XOLD2+XOLD1
      XOLD1=XOLD0
C
C   CALCULATE CHANGE IN GEOMETRY
C
      XOLD0=0.D0
      L=0
      XTOT0=0.D0
      SUM1=0.D0
      DO 80 I=1,NUMAT
         SUM=0.D0
         DO 70 J=1,3
            L=L+1
            SUM1=SUM1+(ALLXYZ(1,L)-REF(L))**2*ATMASS(I)
   70    SUM=SUM+(ALLXYZ(2,L)-ALLXYZ(1,L))**2
   80 XOLD0=XOLD0+SQRT(SUM)
      XTOT0=XTOT0+SQRT(SUM1)/SQRT2
      CALL QUADR(XTOT2,XTOT1,XTOT0,T1,T2,
     1XTOT3(1),XTOT3(2),XTOT3(3))
      CALL QUADR(XOLD2,XOLD2+XOLD1,XOLD2+XOLD1+XOLD0,T1,T2,
     1XOLD3(1),XOLD3(2),XOLD3(3))
***********************************************************************
*   GO THROUGH THE CRITERIA FOR DECIDING WHETHER OR NOT TO PRINT THIS *
*   POINT.  IF YES, THEN ALSO CALCULATE THE EXACT POINT AS A FRACTION *
*   BETWEEN THE LAST POINT AND THE CURRENT POINT                      *
***********************************************************************
C   NFRACT IS THE NUMBER OF POINTS TO BE PRINTED IN THE CURRENT DOMAIN
***********************************************************************
      IF(ILOOP.LT.3) GOTO 170
      FRACT=-10
      NFRACT=1
      IF(STEPH.NE.0) THEN
C
C   CRITERION FOR PRINTING RESULTS  IS A CHANGE IN HEAT OF FORMATION =
C   -CHANGE IN KINETIC ENERGY
C
         IF(REFSCF.EQ.0.D0) THEN
            I=ESCF2/STEPH
            REFSCF=I*STEPH
         ENDIF
         DH=ABS(ESCF1-REFSCF)
         IF(DH.GT.STEPH)THEN
            STEPH=SIGN(STEPH,ESCF1-REFSCF)
            NFRACT=ABS(DH/STEPH)
            CC=ESCF3(1)
            BB=ESCF3(2)
            AA=ESCF3(3)
************************************************
* PROGRAMMERS! - BE VERY CAREFUL IF YOU CHANGE *
* THIS FOLLOWING SECTION.  THERE IS NUMERICAL  *
* INSTABILITY IF ABS(BB/AA) IS VERY LARGE. NEAR*
* INFLECTION POINTS AA CHANGES SIGN.       JJPS*
************************************************
            IF(ABS(BB/AA).GT.30)THEN
C
C   USE LINEAR INTERPOLATION
C
               DO 90 I=1,NFRACT
   90          TSTEPS(I)=-(CC-(REFSCF+I*STEPH))/BB
            ELSE
C
C  USE QUADRATIC INTERPOLATION
C
               DO 100 I=1,NFRACT
                  C1=CC-(REFSCF+I*STEPH)
  100          TSTEPS(I)=(-BB+SIGN(SQRT(BB*BB-4.D0*(AA*C1)),BB))/(2.D0*A
     1A)
            ENDIF
            FRACT=-.1
            REFSCF=REFSCF+NFRACT*STEPH
         ENDIF
      ELSEIF(STEPT.NE.0.D0) THEN
C
C   CRITERION FOR PRINTING RESULTS IS A CHANGE IN TIME.
C
         IF(ABS(TOTIME+TOLD2-TREF).GT.STEPT)THEN
            FINCR=STEPT
            I=TOTIME/STEPT
            FRACT=I*STEPT-TOTIME
            I=(TOLD2+TOTIME)/STEPT
            J=TOTIME/STEPT
            NFRACT=I-J+ IONE
            IONE=0
            DO 110 I=1,NFRACT
  110       TSTEPS(I)=FRACT+I*STEPT
            TREF=TREF+NFRACT*STEPT
         ENDIF
      ELSEIF(STEPX.NE.0.D0) THEN
C
C   CRITERION FOR PRINTING RESULTS IS A CHANGE IN GEOMETRY.
C
         IF(XOLD2+XOLD1-REFX.GT.STEPX)THEN
            NFRACT=(XOLD2+XOLD1-REFX)/STEPX
            CC=XOLD3(1)
            BB=XOLD3(2)
            AA=XOLD3(3)
            IF(ABS(BB/AA).GT.30)THEN
C
C   USE LINEAR INTERPOLATION
C
               DO 120 I=1,NFRACT
  120          TSTEPS(I)=-(CC-(REFX+I*STEPX))/BB
            ELSE
C
C  USE QUADRATIC INTERPOLATION
C
               DO 130 I=1,NFRACT
                  C1=CC-(REFX+I*STEPX)
  130          TSTEPS(I)=(-BB+SIGN(SQRT(BB*BB-4.D0*(AA*C1)),BB))/(2.D0*A
     1A)
            ENDIF
            REFX=REFX+NFRACT*STEPX
            FRACT=-.1
         ENDIF
      ELSE
C
C   PRINT EVERY POINT.
C
         FRACT=0.0
      ENDIF
      IF(FRACT.LT.-9.D0)GOTO 170
      TURN=(TURN.OR.ABS(FRACT-1.D0).GT.1.D-6)
C
C  LOOP OVER ALL POINTS IN CURRENT DOMAIN
C
      IF(FRACT.EQ.0.D0.AND.NFRACT.EQ.1)THEN
         TEXT1=' '
         TEXT2=' '
         II=0
         CALL DRCOUT(XYZ3,GEO3,VEL3,NVAR,TOTIME,ESCF3,EKIN3,
     1GTOT3,ETOT3,XTOT3,ILOOP,CHARGE,FRACT,TEXT1,TEXT2,II,JLOOP)
         N=0
         DO 140 I=1,NCOPRT
            K=MCOPRT(1,I)
            J=MCOPRT(2,I)
            L=K*3-3+J
            IF(ABS(GEO3(3,L)).GT.1.D-20)FRACT=-GEO3(2,L)/(GEO3(3,L)*2.D0
     1)
            IF(FRACT.GT.0.D0.AND.FRACT.LT.TOLD2) THEN
               IF(GEO3(3,L).GT.0.D0)TEXT1='MIN'
               IF(GEO3(3,L).LT.0.D0)TEXT1='MAX'
               TEXT2=COTYPE(J)
               IF(N.EQ.0)THEN
                  N=N+1
                  WRITE(6,'(/,20(''****''))')
               ENDIF
               TIME=TOTIME+FRACT
               CALL DRCOUT(XYZ3,GEO3,VEL3,NVAR,TIME,ESCF3,EKIN3,
     1GTOT3,ETOT3,XTOT3,ILOOP,CHARGE,FRACT,TEXT1,TEXT2,K,JLOOP)
            ENDIF
  140    CONTINUE
         IF(N.NE.0)WRITE(6,'(/,20(''****''))')
         IF(ABS(ESCF3(3)).GT.1.D-20)FRACT=-ESCF3(2)/(ESCF3(3)*2.D0)
         IF(.NOT.GOTURN.AND.FRACT.GT.0.D0.AND.FRACT.LT.TOLD2*1.04D0
     1.AND. PARMAX) THEN
            GOTURN=.TRUE.
            TIME=FRACT+TOTIME
            IF(ESCF3(3).GT.0.D0) THEN
               TEXT1='MIN'
               IF(LDRC) THEN
                  SUM=DOT(VELO0,VREF,NVAR)**2/(DOT(VELO0,VELO0,NVAR)*
     1DOT(VREF,VREF,NVAR)+1.D-10)
                  SUM1=DOT(VELO0,VREF0,NVAR)**2/(DOT(VELO0,VELO0,NVAR)*
     1DOT(VREF0,VREF0,NVAR)+1.D-10)
                  IF(SUM1.GT.0.1D0)
     1WRITE(6,'(/,A,F8.5,A,F8.5,A,F8.1,A)')' COEF. OF V(0)
     2=',SUM1,'   LAST V(0)',SUM,'   HALF-LIFE =',
     3-0.6931472D0*TIME/LOG(SUM1),' FEMTOSECS'
               ENDIF
               WRITE(6,'(//,A,F11.3,A)')' HALF-CYCLE TIME ='
     1,TIME-TLAST,' FEMTOSECONDS'
               TLAST=TIME
               DO 150 I=1,NVAR
  150          VREF(I)=VELO0(I)
            ENDIF
            IF(ESCF3(3).LT.0.D0)TEXT1='MAX'
            TEXT2=' '
            CALL DRCOUT(XYZ3,GEO3,VEL3,NVAR,TIME,ESCF3,EKIN3,
     1GTOT3,ETOT3,XTOT3,ILOOP,CHARGE,FRACT,TEXT1,TEXT2,0,JLOOP)
         ELSE
            GOTURN=.FALSE.
         ENDIF
      ELSE
         DO 160 I=1,NFRACT
            TIME=TOTIME+TSTEPS(I)
            TEXT1=' '
            TEXT2=' '
C#           WRITE(6,'(A,4F12.4)')' KINETIC ENERGY, POINT',EKIN3,TSTEPS(
            CALL DRCOUT(XYZ3,GEO3,VEL3,NVAR,TIME,ESCF3,EKIN3,
     1GTOT3,ETOT3,XTOT3,ILOOP,CHARGE,TSTEPS(I),TEXT1,TEXT2,0,JLOOP)
  160    CONTINUE
      ENDIF
  170 CONTINUE
C
C BUFFER TOTAL TIME TO 3 POINTS BACK!
C
      TOTIME=TOTIME+TOLD2
      TOLD2=TOLD1
      TOLD1=DELTAT
      ILOOP=ILOOP+1
      RETURN
      END


(* Code to test for busy channels and nRF24 range checks

    CHECK   = Test all avialable 2.4GHz channels
    CARRIER = Test only given channel
    WAVE    = Send carrier on channel with a given power
    PULSE   = Idem but also a 50/100 pulse length in millisec.

Extra words: MS

*)

                            ( nRF24L01 RF test )

: ?LED      ( f -- )    if  led-on  else  led-off  then ;

: CARRIER?      ( -- 0|1 )  \ Check for carrier
    flush-rx  read-mode     \ Free receiver, receive mode on
    9 read-reg  write-mode ; \ Test for carrier on used frequency

\ The program puts the led on & prints a number sign '#'
\ when a carrier is detected and a dash '-' otherwise.
: CHECK)        ( -- )  \ Check for carrier on selected channel
    [char] -  carrier?  \ Test for carrier on used frequency
    dup ?led            \ Led on when a carrier is seen
    if  A -  then  emit \ Show dash or sharp
    write-mode ;        \ Back to write mode

\ Test if other 2.4GHz transmitters are active on selected frequency
\ Busy channels at my place: 0D, 30 to 4C at night there are more
: CHECK         ( -- )
    setup24L01  get-status . \ Init.
    7E 0 do
        i >channel          \ Select channel number 0 to 7D
        cr  i 2 .r space    \ Show tested channel
        40 0 do             \ Test #64 times
            key? if leave then
            check)
        loop
        key? if leave then  \ Ready when a key is pressed
    loop  setup24l01  read-mode ; \ Restore chosen channel

\ Show carriers on the channel number from the stack
: CARRIER   ( channel -- )  \ #CH = default channel
    setup24L01  get-status . \ Initialise
    >channel                \ Set channel to be checked
    begin check) key? until \ Check carrier on 'channel'
                            \ Show presence
    setup24l01  read-mode ; \ Restore chosen channel

: WAVE      ( channel power -- ) \ #CH = default channel
    2E and >r               \ Keep power & bitrate settings in range
    spi-setup  ." on "      \ Init SPI
    2 0 write-reg  15 /ms   \ Power up for constant carrier
    r> 90 or  6 write-reg   \ Activate carrier, bitrate & power
    >channel  8 29 *bis     \ Set channel
    begin  key? until       \ Wait for key
    setup24l01  read-mode ; \ Then stop carrier

value PL                    \ Pulselength for on/off rhythm
: PULSE     ( channel power pulselength -- ) \ #CH = default channel
    to pl  2E and >r        \ Keep power & bitrate settings in range
    begin
        spi-setup           \ Init SPI
        2 0 write-reg  15 /ms   \ Power up for constant carrier
        r@ 90 or  6 write-reg   \ Activate carrier, bitrate & power
        dup >channel  8 29 *bis \ Set channel
        pl ms               \ Carrier for PL ms
        setup24l01  pl ms   \ Then stop carrier for PL ms
    key? until              \ Wait for key
    r> 2drop  read-mode ;

\ End ;;;

Communication-Protocols/Wireless-Communication/nRf24L01+/MSP430/noForth-G2553 & F149/Range checker.f


! SUMMA - Structure for Unifying Multiple Modeling Alternatives
! Copyright (C) 2014-2015 NCAR/RAL
!
! This file is part of SUMMA
!
! For more information see: http://www.ral.ucar.edu/projects/summa
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.

module snowAlbedo_module

! data types
USE nrtype                        ! numerical recipes data types

! physical constants
USE multiconst,only:Tfreeze       ! freezing point of pure water (K)

! look-up values for the choice of snow albedo options
USE mDecisions_module,only:  &
 constantDecay,              &    ! constant decay in snow albedo (e.g., VIC, CLASS)
 variableDecay                    ! variable decay in snow albedo (e.g., BATS approach, with destructive metamorphism + soot content)

! look-up values for the choice of canopy shortwave radiation method
USE mDecisions_module,only:  &
 noah_mp,                    &    ! full Noah-MP implementation (including albedo)
 CLM_2stream,                &    ! CLM 2-stream model (see CLM documentation)
 UEB_2stream,                &    ! UEB 2-stream model (Mahat and Tarboton, WRR 2011)
 NL_scatter,                 &    ! Simplified method Nijssen and Lettenmaier (JGR 1999)
 BeersLaw                         ! Beer's Law (as implemented in VIC)

! -------------------------------------------------------------------------------------------------
implicit none
private
public::snowAlbedo
! dimensions
integer(i4b),parameter        :: nBands=2      ! number of spectral bands for shortwave radiation
contains

 ! *******************************************************************************************************
 ! public subroutine snowAlbedo: muster program to compute energy fluxes at vegetation and ground surfaces
 ! *******************************************************************************************************
 subroutine snowAlbedo(&
                       ! input: model control
                       dt,                                    & ! intent(in): model time step (s)
                       snowPresence,                          & ! intent(in): logical flag to denote if snow is present
                       ! input/output: data structures
                       model_decisions,                       & ! intent(in):    model decisions
                       mpar_data,                             & ! intent(in):    model parameters
                       flux_data,                             & ! intent(in):    model flux variables
                       diag_data,                             & ! intent(inout): model diagnostic variables for a local HRU
                       prog_data,                             & ! intent(inout): model prognostic variables for a local HRU
                       ! output: error control
                       err,message)                             ! intent(out): error control
 ! --------------------------------------------------------------------------------------------------------------------------------------
 ! provide access to the derived types to define the data structures
 USE data_types,only:&
                     var_i,            & ! data vector (i4b)
                     var_d,            & ! data vector (dp)
                     var_dlength,      & ! data vector with variable length dimension (dp)
                     model_options       ! defines the model decisions
 ! provide access to named variables defining elements in the data structures
 USE var_lookup,only:iLookPARAM,iLookFLUX,iLookDIAG,iLookPROG   ! named variables for structure elements
 USE var_lookup,only:iLookDECISIONS                             ! named variables for elements of the decision structure
 ! provide access to desired modules
 USE snow_utils_module,only:fracliquid                          ! compute fraction of liquid water at a given temperature
 ! --------------------------------------------------------------------------------------------------------------------------------------
 ! input: model control
 real(dp),intent(in)             :: dt                          ! model time step
 logical(lgt),intent(in)         :: snowPresence                ! logical flag to denote if snow is present
 ! input/output: data structures
 type(model_options),intent(in)  :: model_decisions(:)          ! model decisions
 type(var_dlength),intent(in)    :: mpar_data                   ! model parameters
 type(var_dlength),intent(in)    :: flux_data                   ! model flux variables
 type(var_dlength),intent(inout) :: diag_data                   ! model diagnostic variables for a local HRU
 type(var_dlength),intent(inout) :: prog_data                   ! model prognostic variables for a local HRU
 ! output: error control
 integer(i4b),intent(out)        :: err                         ! error code
 character(*),intent(out)        :: message                     ! error message
 ! local variables
 integer(i4b),parameter          :: ixVisible=1                  ! named variable to define index in array of visible part of the spectrum
 integer(i4b),parameter          :: ixNearIR=2                   ! named variable to define index in array of near IR part of the spectrum
 real(dp),parameter              :: valueMissing=-9999._dp       ! missing value -- will cause problems if snow albedo is ever used for the non-snow case
 real(dp),parameter              :: slushExp=10._dp              ! "slush" exponent, to increase decay when snow is near Tfreeze
 real(dp),parameter              :: fractionLiqThresh=0.001_dp   ! threshold for the fraction of liquid water to switch to spring albedo minimum
 real(dp)                        :: fractionLiq                  ! fraction of liquid water (-)
 real(dp)                        :: age1,age2,age3               ! aging factors (-)
 real(dp)                        :: decayFactor                  ! albedo decay factor (-)
 real(dp)                        :: refreshFactor                ! albedo refreshment factor, representing albedo increase due to snowfall (-)
 real(dp)                        :: albedoMin                    ! minimum albedo -- depends if in winter or spring conditions (-)
 real(dp)                        :: fZen                         ! factor to modify albedo at low zenith angles (-)
 real(dp),parameter              :: bPar=2._dp                   ! empirical parameter in fZen
 ! initialize error control
 err=0; message='snowAlbedo/'
 ! --------------------------------------------------------------------------------------------------------------------------------------
 ! associate variables in the data structure
 associate(&
 ! input: model decisions
 ixCanopySrad              => model_decisions(iLookDECISIONS%canopySrad)%iDecision,   & ! intent(in): index of method used for canopy sw radiation
 ixAlbedoMethod            => model_decisions(iLookDECISIONS%alb_method)%iDecision,   & ! intent(in): index of method used for snow albedo
 ! input: model parameters
 Frad_vis                  => mpar_data%var(iLookPARAM%Frad_vis)%dat(1),              & ! intent(in): fraction of radiation in visible part of spectrum (-)
 Frad_direct               => mpar_data%var(iLookPARAM%Frad_direct)%dat(1),           & ! intent(in): fraction direct solar radiation (-)
 albedoMax                 => mpar_data%var(iLookPARAM%albedoMax)%dat(1),             & ! intent(in): maximum snow albedo for a single spectral band (-)
 albedoMinWinter           => mpar_data%var(iLookPARAM%albedoMinWinter)%dat(1),       & ! intent(in): minimum snow albedo during winter for a single spectral band (-)
 albedoMinSpring           => mpar_data%var(iLookPARAM%albedoMinSpring)%dat(1),       & ! intent(in): minimum snow albedo during spring for a single spectral band (-)
 albedoMaxVisible          => mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1),      & ! intent(in): maximum snow albedo in the visible part of the spectrum (-)
 albedoMinVisible          => mpar_data%var(iLookPARAM%albedoMinVisible)%dat(1),      & ! intent(in): minimum snow albedo in the visible part of the spectrum (-)
 albedoMaxNearIR           => mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1),       & ! intent(in): maximum snow albedo in the near infra-red part of the spectrum (-)
 albedoMinNearIR           => mpar_data%var(iLookPARAM%albedoMinNearIR)%dat(1),       & ! intent(in): minimum snow albedo in the near infra-red part of the spectrum (-)
 albedoDecayRate           => mpar_data%var(iLookPARAM%albedoDecayRate)%dat(1),       & ! intent(in): albedo decay rate (s)
 tempScalGrowth            => mpar_data%var(iLookPARAM%tempScalGrowth)%dat(1),        & ! intent(in): temperature scaling factor for grain growth (K-1)
 albedoSootLoad            => mpar_data%var(iLookPARAM%albedoSootLoad)%dat(1),        & ! intent(in): soot load factor (-)
 albedoRefresh             => mpar_data%var(iLookPARAM%albedoRefresh)%dat(1),         & ! intent(in): critical mass necessary for albedo refreshment (kg m-2)
 snowfrz_scale             => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1),         & ! intent(in): scaling parameter for the freezing curve for snow (K-1)
 ! input: model variables
 surfaceTemp               => prog_data%var(iLookPROG%mLayerTemp)%dat(1),             & ! intent(in): surface temperature
 snowfallRate              => flux_data%var(iLookFLUX%scalarSnowfall)%dat(1),         & ! intent(in): snowfall rate (kg m-2 s-1)
 cosZenith                 => diag_data%var(iLookDIAG%scalarCosZenith)%dat(1),        & ! intent(in): cosine of the zenith angle (-)
 ! input/output: model variables
 scalarSnowAlbedo          => prog_data%var(iLookPROG%scalarSnowAlbedo)%dat(1),       & ! intent(inout): snow albedo for the entire spectral band (-)
 spectralSnowAlbedoDirect  => diag_data%var(iLookDIAG%spectralSnowAlbedoDirect)%dat,  & ! intent(inout): direct snow albedo in each spectral band (-)
 spectralSnowAlbedoDiffuse => prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat  & ! intent(inout): diffuse snow albedo in each spectral band (-)
 ) ! end associate statement
 ! --------------------------------------------------------------------------------------------------------------------------------------

 ! return early if computing radiation in noah-MP
 if(ixCanopySrad==noah_mp) return

 ! return early if no snow
 if(.not. snowPresence)then
  scalarSnowAlbedo             = valueMissing
  spectralSnowAlbedoDirect(:)  = valueMissing
  spectralSnowAlbedoDiffuse(:) = valueMissing
  return
 end if

 ! compute fractional increase in albedo associated with snowfall
 refreshFactor = dt*snowfallRate/albedoRefresh

 ! identify option for snow albedo
 select case(ixAlbedoMethod)

  ! *** constant decay rate
  case(constantDecay)
   ! compute decay rate
   decayFactor = dt/albedoDecayRate
   ! compute minimum albedo
   fractionLiq = fracliquid(surfaceTemp,snowfrz_scale) ! fraction of liquid water
   if(scalarSnowAlbedo < albedoMinWinter .or. fractionLiq > fractionLiqThresh)then
    albedoMin = albedoMinSpring
   else
    albedoMin = albedoMinWinter
   end if
   ! compute average albedo
   call computeAlbedo(scalarSnowAlbedo,refreshFactor,decayFactor,albedoMax,albedoMin)
   ! assume albedo is the same in visible and near infra-red bands, and for direct and diffuse radiation
   spectralSnowAlbedoDiffuse(ixVisible) = scalarSnowAlbedo
   spectralSnowAlbedoDiffuse(ixNearIR)  = scalarSnowAlbedo
   spectralSnowAlbedoDirect(ixVisible)  = scalarSnowAlbedo
   spectralSnowAlbedoDirect(ixNearIR)   = scalarSnowAlbedo

  ! *** variable decay rate
  case(variableDecay)
   ! compute decay factor
   age1 = exp(-tempScalGrowth*(Tfreeze - surfaceTemp ))  ! temperature dependence
   age2 = age1**slushExp                                 ! increase with liquid water
   age3 = albedoSootLoad                                 ! soot loading
   decayFactor = dt*(age1 + age2 + age3)/albedoDecayRate
   ! compute diffuse albedo for the different spectral bands
   call computeAlbedo(spectralSnowAlbedoDiffuse(ixVisible),refreshFactor,decayFactor,albedoMaxVisible,albedoMinVisible)
   call computeAlbedo(spectralSnowAlbedoDiffuse(ixNearIR), refreshFactor,decayFactor,albedoMaxNearIR, albedoMinNearIR)
   ! compute factor to modify direct albedo at low zenith angles
   if(cosZenith < 0.5_dp)then
    fZen = (1._dp/bPar)*( ((1._dp + bPar)/(1._dp + 2._dp*bPar*cosZenith)) - 1._dp)
   else
    fZen = 0._dp
   end if
   ! compute direct albedo
   spectralSnowAlbedoDirect(ixVisible) = spectralSnowAlbedoDiffuse(ixVisible) + 0.4_dp*fZen*(1._dp - spectralSnowAlbedoDiffuse(ixVisible))
   spectralSnowAlbedoDirect(ixNearIR)  = spectralSnowAlbedoDiffuse(ixNearIR)  + 0.4_dp*fZen*(1._dp - spectralSnowAlbedoDiffuse(ixNearIR))

   ! compute average albedo
   scalarSnowAlbedo = (        Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._dp - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) ) + &
                      (1._dp - Frad_direct)*(Frad_vis*spectralSnowAlbedoDirect(ixVisible) + (1._dp - Frad_vis)*spectralSnowAlbedoDirect(ixNearIR) )

  ! check that we identified the albedo option
  case default; err=20; message=trim(message)//'unable to identify option for snow albedo'; return

 end select  ! identify option for snow albedo

 ! check
 if(scalarSnowAlbedo < 0._dp)then; err=20; message=trim(message)//'unable to identify option for snow albedo'; return; end if

 ! end association to data structures
 end associate

 end subroutine snowAlbedo

 ! *******************************************************************************************************
 ! private subroutine computeAlbedo: compute change in albedo -- implicit solution
 ! *******************************************************************************************************
 subroutine computeAlbedo(snowAlbedo,refreshFactor,decayFactor,albedoMax,albedoMin)
 implicit none
 ! dummy variables
 real(dp),intent(inout)   :: snowAlbedo    ! snow albedo (-)
 real(dp),intent(in)      :: refreshFactor ! albedo refreshment factor (-)
 real(dp),intent(in)      :: decayFactor   ! albedo decay factor (-)
 real(dp),intent(in)      :: albedoMax     ! maximum albedo (-)
 real(dp),intent(in)      :: albedoMin     ! minimum albedo (-)
 ! local variables
 real(dp)                 :: albedoChange ! change in albedo over the time step (-)
 ! compute change in albedo
 albedoChange = refreshFactor*(albedoMax - snowAlbedo) - (decayFactor*(snowAlbedo - albedoMin)) / (1._dp + decayFactor)
 snowAlbedo   = snowAlbedo + albedoChange
 if(snowAlbedo > albedoMax) snowAlbedo = albedoMax
 end subroutine computeAlbedo

end module snowAlbedo_module


subroutine writing_coal
    use paracluster
    use cluster
    use potential
    use enforce
    use distance
    use substrate
!    use output

    implicit none

    integer :: i, j, k, unitp, unitc
    integer :: icolor
    integer :: nbond, nbond2, nbond3
    real :: xuar, yvar, zwar, x2cdm, y2cdm, z2cdm, x1cdm, y1cdm, z1cdm, vzsum, vz2sum
    real :: emedia, distcom

    !unit numbers
    unitp = 50
    unitc = 70

    !energy.out contains the energy output
    !coalescing.out contains variables relating coalescence
    !movie.xyz/hdf5 contains positions

        open(unite,file = 'energy.out',status = 'unknown',position = 'append')
        open(unitm, file = 'movie.xyz', status = 'unknown', access = 'append')
        open(unitc, file = 'coalescing.out', status = 'unknown', access = 'append')
        if(ipas == 1) then
           if(mgo_substrate) then
                write(unite, *) '## time[ps]  epot[ev]  etot[ev]  ekin[ev]  <edelta>  <etot>  <t[k]>   esub[ev]'
                write(unitc, *) '## time[ps] comd[a] #bimbonds[a] #monbonds[a] #intclustbond driftv1 driftv2'
            else
                write(unite, *) '## time[ps]  epot[ev]  etot[ev]  ekin[ev]  <edelta>  <etot>  <t[k]>'
                write(unitc, *) '## time[ps] comd[a] #bimbonds[a] #monbonds[a] #intclustbond driftv1 driftv2'
            end if
        end if

    !average quantities
    tpar = tpar + temp
    edelta = edelta + etot
    !emedia = emedia + etot !modified by lp: emedia is not initialized and this value is not used.

    !====================================
    ! writing each scrivo-step
    !====================================
    if(mod(ipas, scrivo) == 0) then
        ! average energy
        emedia = edelta / scrivo !at this point edelta is the sum of etot over a growing number of time steps
        !now emedia is etot averaged over the number of scrivo steps
        !edelta calculation
        edelta = edelta / scrivo ! now edelta becomes etot averaged over the number of scrivo steps
        if(sys == 'mon') then
            !now edelta is really edelta averaged over scrivo
            edelta = (edelta + natom * ecoh(1)) / (natom**(2.d0 / 3.d0))
        else
            edelta = (edelta + ntipo1 * ecoh(1) + ntipo2 * ecoh(2)) / ((natom)**(2.d0 / 3.d0))
        end if

        !average temperature calculation
        tpar = tpar / (scrivo)
        if(mgo_substrate) then
            write(unite, '(1f15.4,1x,3f14.5,1x,4f14.5)') &
            tempo, ener, etot, ecin, edelta, emedia, tpar, ener_sub
            write(*, '(1f15.4,1x,3f14.5,1x,4f14.5)') & !writing on terminal
            tempo, ener, etot, ecin, edelta, emedia, tpar, ener_sub
        else
            write(unite, '(1f15.4,1x,3f14.5,1x,3f14.5)')&
            tempo, ener, etot, ecin, edelta, emedia, tpar
            write(*, '(1f15.4,1x,3f14.5,1x,3f14.5)') & !writing on terminal
            tempo, ener, etot, ecin, edelta, emedia, tpar
        end if

        emedia = 0.d0
        edelta = 0.d0
        tpar = 0.d0

        write(unitm, *) natom
        write(unitm, '(i8, 2(a3,i4), 1x, 1f14.5, 1f7.3, a4)') &
            ipas, elem1, ntipo1, elem2, ntipo2, etot, temp

        do i = 1, natom
            icolor = itype(i)
            xuar = (x(i) + u(i)) * aretebim * fattor
            yvar = (y(i) + v(i)) * aretebim * fattor
            zwar = (z(i) + w(i)) * aretebim * fattor
            !bufferpos(1, i, 1) = xuar
            !bufferpos(2, i, 1) = yvar
            !bufferpos(3, i, 1) = zwar
            !!if (output_xyz) then
                write(unitm,'(a3,1x,3f16.5,i4)') elem(i), xuar, yvar, zwar, icolor
            !!end if
        end do

        !call write_movie

        !=============start of coalescing.out===============!
        !checking hetero bonds
        nbond = 0
        nbond2 = 0
        nbond3 = 0

        !here we check how many nn of target cluster atoms belonged to bullet clusters
        do i = 1, natom - natom2
            do j = 1, nvois(i)
                k = ivois(j, i)
                if ( k > (natom - natom2) ) then
                    nbond = nbond + 1
                end if
            end do
        end do

        do i = 1, natom !monometallic and bimeticallic, counting twice
            do j = 1, nvois(i)
                k = ivois(j, i)
                if (elem(k) /= elem(i)) then
                    nbond2 = nbond2 + 1
                else if (elem(k) == elem(i)) then
                    nbond3 = nbond3 + 1
                end if
            end do
        end do

        nbond2 = nbond2 / 2
        nbond3 = nbond3 / 2

        !COM calculations
        x1cdm = (aretebim * fattor / float(natom - natom2)) * &
            sum(x(1:natom - natom2) + u(1:natom - natom2))
        y1cdm = (aretebim * fattor / float(natom - natom2)) * &
            sum(y(1:natom - natom2) + v(1:natom - natom2))
        z1cdm = (aretebim * fattor / float(natom - natom2)) * &
            sum(z(1:natom - natom2) + w(1:natom - natom2))
        x2cdm = (aretebim * fattor / float(natom2)) * &
            sum(x(natom - natom2 + 1:natom) + u(natom - natom2 + 1:natom))
        y2cdm = (aretebim * fattor / float(natom2)) * &
            sum(y(natom - natom2 + 1:natom) + v(natom - natom2 + 1:natom))
        z2cdm = (aretebim * fattor / float(natom2)) * &
            sum(z(natom - natom2 + 1:natom) + w(natom - natom2 + 1:natom))

        distcom = sqrt((x1cdm - x2cdm)**2 + (y1cdm - y2cdm)**2 + (z1cdm - z2cdm)**2)

        !Drift Velocity
        vzsum = (sum(vz(1:natom - natom2)) / float(natom - natom2)) * (aretebim * fattor * 1.0d-10 / tstep)
        vz2sum = (sum(vz(natom - natom2 + 1:natom)) / float(natom2)) * (aretebim * fattor * 1.0d-10 / tstep)

        write(unitc,*)tempo, distcom, nbond2, nbond3, nbond, vzsum, vz2sum
    end if

    if(ipas == npas) then
        close(unite)
        !!if(output_xyz)
        close(unitm)
    end if

end subroutine


      subroutine uread
     x  (history,cfgname,atmnam,iflg,imcon,keytrj,natms,nstep,tstep,
     x   cell,chge,weight,xxx,yyy,zzz,vxx,vyy,vzz,fxx,fyy,fzz)

c
c***********************************************************************
c
c     dl_poly subroutine for reading unformatted history files
c
c     double precision, single processor version
c
c     copyright - daresbury laboratory 1996
c     author    - w. smith jan 1996.
c
c***********************************************************************
c

      implicit real*8(a-h,o-z)

      logical new

      character*80 cfgname
      character*40 history
      character*8 atmnam(*)

      dimension cell(9)
      dimension chge(*),weight(*)
      dimension xxx(*),yyy(*),zzz(*)
      dimension vxx(*),vyy(*),vzz(*)
      dimension fxx(*),fyy(*),fzz(*)

      save new

      data new/.true./,nhist/77/

      iflg=0

c     open the history file if new job

      if(new)then

        open(nhist,file=history,form='unformatted',
     x       status='old',err=100)

        read(nhist,err=200) cfgname
        write(*,'(a,a)')'# History file header: ',cfgname
        read(nhist,end=200) datms
        if(natms.ne.nint(datms))then

          matms=nint(datms)
          write(*,'(a)')'# error - incorrect number of atoms in file'
          write(*,'(a,i6,a)')'# file contains',matms,' atoms'
          stop

        endif
        read(nhist,end=200) (atmnam(i),i=1,natms)
        read(nhist,end=200) (weight(i),i=1,natms)
        read(nhist,end=200) (chge(i),i=1,natms)

        new=.false.

      endif

      read(nhist,end=200)dstep,datms,trjkey,dimcon,tstep
      nstep=nint(dstep)
      ktrj=nint(trjkey)
      imcon=nint(dimcon)
      if(keytrj.gt.ktrj)then

        if(ktrj.eq.0)write(*,'(a)')'# error - no velocities in file'
        if(keytrj.gt.1)write(*,'(a)')'# error - no forces in file'
        stop

      endif

      if(imcon.gt.0) read(nhist,end=200) cell

      read(nhist,end=200) (xxx(i),i = 1,natms)
      read(nhist,end=200) (yyy(i),i = 1,natms)
      read(nhist,end=200) (zzz(i),i = 1,natms)

      if(keytrj.ge.1)then
        read(nhist,end=200) (vxx(i),i = 1,natms)
        read(nhist,end=200) (vyy(i),i = 1,natms)
        read(nhist,end=200) (vzz(i),i = 1,natms)
      else if(ktrj.ge.1)then
        read(nhist,end=200)
        read(nhist,end=200)
        read(nhist,end=200)
      endif
      if(keytrj.ge.2)then
        read(nhist,end=200) (fxx(i),i = 1,natms)
        read(nhist,end=200) (fyy(i),i = 1,natms)
        read(nhist,end=200) (fzz(i),i = 1,natms)
      else if(ktrj.ge.2)then
        read(nhist,end=200)
        read(nhist,end=200)
        read(nhist,end=200)
      endif

      iflg=1

      return

  100 continue

      write(*,'(a)')'# error - History file not found'
      stop

  200 continue
      write(*,'(a)')'# warning - end of History file encountered'
      close (nhist)
      iflg=-1

      return
      end