MODULE maskinfo_

!   Simulate a mask for lensing data including
!
!    bright stars
!       circles with the radius ranging from "hmin" to "hmax"

  real, parameter :: hmin=0.2, hmax=2. ! in unit of arcmin

!    saturation spike
!       rectangles with xrec*radius by yrec*radius
!       for bright stars with radius > rsmin

  real, parameter :: xrec=0.2, yrec=5.
  real, parameter :: rsmin=0.3  ! in unit of arcmin

!    fmask: mask fraction by bright stars and saturation spike

  real, parameter :: fmask=0.2

!    other mask
!       zero padding in y direction with a probability of zfrac
!       width of zero paddign is given by zwidth

  real, parameter :: zfrac=0.05, zwidth=1./2048.

END MODULE maskinfo_


SUBROUTINE UpdateGhostLayerECurvilinear(var,Sx,Sy,NNx,NNy,NNz,CompGrid,alpha,beta,GhostGridX,GhostGridY)
USE Precision
USE DataTypes
IMPLICIT NONE
TYPE (Level_def) :: CompGrid
INTEGER :: NNx, NNy, NNz, rank, alpha, beta, i,j,k, GhostGridX, GhostGridY, diffb
REAL(KIND=long), DIMENSION(NNx,NNy) :: var, Sx, Sy
REAL(KIND=long), DIMENSION(2*alpha+1) :: Stencile
REAL(KIND=long) :: xe, ye, Source, NormalX, NormalY, ex, ey
IF (alpha/=beta) THEN
	print*,'ERROR: alpha/=beta. (UpdateGhostLayerECurvilinear)'
	STOP
END IF
rank = 2*alpha+1
! On the free surface
k = NNz
! two boundaries
i=1
DO j = 1+GhostGridY, NNy-GhostGridY
  	Stencile = CompGrid%CurvilinearStuff%DiffStencils%StencilG(1:rank,1+GhostGridX,1)
    !! Source terms on the boundary! FIXME: check the formula...
    !xe = CompGrid%CurvilinearStuff%xe(i+GhostGridX,j)
    !ye = CompGrid%CurvilinearStuff%ye(i+GhostGridX,j)
    ! use geometric factors for wall boundary
	ex = CompGrid%CurvilinearStuff%ex(i+GhostGridX,j)
	ey = CompGrid%CurvilinearStuff%ey(i+GhostGridX,j)
    !Source = xe*Sx(i+GhostGridX,j) + ye*Sy(i+GhostGridX,j)
    NormalX = CompGrid%CurvilinearStuff%NormalX(k,i,j)
	NormalY = CompGrid%CurvilinearStuff%NormalY(k,i,j)
    Source = (NormalX*Sx(i+GhostGridX,j) + NormalY*Sy(i+GhostGridX,j))/(NormalX*ex+NormalY*ey)
    !
    var(i,j) = (Source-DOT_PRODUCT(Stencile(2:rank),var(2:rank,j))) / Stencile(1)
END DO
i = NNx
DO j = 1+GhostGridY, NNy-GhostGridY
   	Stencile = CompGrid%CurvilinearStuff%DiffStencils%StencilG(1:rank,rank-GhostGridX,1)
    !! Source terms on the boundary! FIXME: check the formula...
    !xe = CompGrid%CurvilinearStuff%xe(i-GhostGridX,j)
    !ye = CompGrid%CurvilinearStuff%ye(i-GhostGridX,j)
    ! use geometric factors for wall boundary
	ex = CompGrid%CurvilinearStuff%ex(i-GhostGridX,j)
	ey = CompGrid%CurvilinearStuff%ey(i-GhostGridX,j)
    !Source = xe*Sx(i-GhostGridX,j) + ye*Sy(i-GhostGridX,j)
    NormalX = CompGrid%CurvilinearStuff%NormalX(k,i,j)
	NormalY = CompGrid%CurvilinearStuff%NormalY(k,i,j)
    Source = (NormalX*Sx(i-GhostGridX,j) + NormalY*Sy(i-GhostGridX,j))/(NormalX*ex+NormalY*ey)
    !
    var(i,j) = (Source-DOT_PRODUCT(Stencile(1:rank-1),var(i-rank+1:i-1,j))) / Stencile(rank)
END DO

END SUBROUTINE UpdateGhostLayerECurvilinear


 MODULE GDSWZD_ROT_EQUID_CYLIND_EGRID_MOD
!$$$  MODULE DOCUMENTATION BLOCK
!
! $Revision: 74917 $
!
! MODULE:  GDSWZD_ROT_EQUID_CYLIND_EGRID_MOD  GDS WIZARD MODULE
!                                             FOR ROTATED EQUIDISTANT
!                                             CYLINDRICAL GRIDS
!                                             ("E" STAGGER).
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: - CONVERT FROM EARTH TO GRID COORDINATES OR VICE VERSA.
!           - COMPUTE VECTOR ROTATION SINES AND COSINES.
!           - COMPUTE MAP JACOBIANS.
!           - COMPUTE GRID BOX AREA.
!
! PROGRAM HISTORY LOG:
!   2015-01-21  GAYNO   INITIAL VERSION FROM A MERGER OF
!                       ROUTINES GDSWIZCB AND GDSWZDCB.
!   2015-09-17  GAYNO   RENAME AS "GDSWZD_ROT_EQUID_CYLIND_EGRID_MOD"
!
! USAGE:  "USE GDSWZD_ROT_EQUID_CYLIND_EGRID_MOD", THEN CALL THE
!         PUBLIC DRIVER ROUTINE "GDSWZD_ROT_EQUID_CYLIND_EGRID"
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 PRIVATE

 PUBLIC                          :: GDSWZD_ROT_EQUID_CYLIND_EGRID

 INTEGER,         PARAMETER      :: KD=SELECTED_REAL_KIND(15,45)

 REAL(KIND=KD),   PARAMETER      :: PI=3.14159265358979_KD
 REAL(KIND=KD),   PARAMETER      :: DPR=180._KD/PI

 INTEGER                         :: IROT

 REAL(KIND=KD)                   :: CLAT, CLAT0, CLATR
 REAL(KIND=KD)                   :: CLON, DLATS, DLONS, RERTH
 REAL(KIND=KD)                   :: RLON0, SLAT, SLAT0, SLATR

 CONTAINS

 SUBROUTINE GDSWZD_ROT_EQUID_CYLIND_EGRID(IGDTNUM,IGDTMPL,IGDTLEN,IOPT,NPTS,&
                                          FILL,XPTS,YPTS,RLON,RLAT,NRET, &
                                          CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD_ROT_EQUID_CYLIND_EGRID   GDS WIZARD FOR ROTATED
!                                              EQUIDISTANT CYLINDRICAL
!
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM DECODES THE GRIB 2 GRID DEFINITION
!           TEMPLATE (PASSED IN INTEGER FORM AS DECODED BY THE
!           NCEP G2 LIBRARY) AND RETURNS ONE OF THE FOLLOWING:
!             (IOPT=+1) EARTH COORDINATES OF SELECTED GRID COORDINATES
!             (IOPT=-1) GRID COORDINATES OF SELECTED EARTH COORDINATES
!           WORKS FOR E-STAGGERED ROTATED EQUIDISTANT CYLINDRICAL PROJECTIONS.
!           THE SCAN MODE (SECTION 3, OCTET 72, BITS 5-6) DETERMINE
!           WHETHER THIS IS AN "H" OR "V" GRID.  IF THE SELECTED
!           COORDINATES ARE MORE THAN ONE GRIDPOINT BEYOND THE
!           EDGES OF THE GRID DOMAIN, THEN THE RELEVANT OUTPUT ELEMENTS
!           ARE SET TO FILL VALUES. THE ACTUAL NUMBER OF VALID POINTS
!           COMPUTED IS RETURNED TOO. OPTIONALLY, THE VECTOR ROTATIONS,
!           THE MAP JACOBIANS AND THE GRID BOX AREAS MAY BE RETURNED.
!           TO COMPUTE THE VECTOR ROTATIONS, THE OPTIONAL ARGUMENTS
!           'SROT' AND 'CROT'  MUST BE PRESENT.  TO COMPUTE THE MAP
!           JACOBIANS, THE OPTIONAL ARGUMENTS 'XLON', 'XLAT',
!           'YLON', 'YLAT' MUST BE PRESENT. TO COMPUTE THE GRID BOX
!           AREAS, THE OPTIONAL ARGUMENT 'AREA' MUST BE PRESENT.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
!   97-10-20  IREDELL  INCLUDE MAP OPTIONS
!   98-08-19  BALDWIN  MODIFY GDSWZDC9 FOR TYPE 203 ETA GRIDS
! 2003-06-11  IREDEL   INCREASE PRECISION
! 2012-08-02  GAYNO    INCREASE XMAX SO ON-GRID POINTS ARE NOT
!                      TAGGED AS OFF-GRID.
! 2015-01-21  GAYNO    MERGER OF GDSWIZCB AND GDSWZDCB.  MAKE
!                      CROT,SORT,XLON,XLAT,YLON,YLAT AND AREA
!                      OPTIONAL ARGUMENTS.  MAKE PART OF A MODULE.
!                      MOVE VECTOR ROTATION, MAP JACOBIAN AND GRID
!                      BOX AREA COMPUTATIONS TO SEPARATE SUBROUTINES.
! 2015-07-14  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAY
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAY.
!                      RENAME AS "GDSWZD_ROT_EQUID_CYLIND_EGRID".
!                      USE CORNER POINT (1,1) AS THE "ANCHOR POINT"
!                      SO ROUTINE WILL WORK WITH NESTS.
!
! USAGE:    CALL GDSWZD_ROT_EQUID_CYLIND_EGRID(IGDTNUM,IGDTMPL,IGDTLEN,IOPT,
!    &                 NPTS,FILL,XPTS,YPTS,RLON,RLAT,NRET,
!    &                 CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!
!   INPUT ARGUMENT LIST:
!     IGDTNUM  - INTEGER GRID DEFINITION TEMPLATE NUMBER.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTMPL  - INTEGER (IGDTLEN) GRID DEFINITION TEMPLATE ARRAY.
!                CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE FOR SECTION
!                THREE:
!                 (1):  SHAPE OF EARTH, OCTET 15
!                 (2):  SCALE FACTOR OF SPHERICAL EARTH RADIUS,
!                       OCTET 16
!                 (3):  SCALED VALUE OF RADIUS OF SPHERICAL EARTH,
!                       OCTETS 17-20
!                 (4):  SCALE FACTOR OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 21
!                 (5):  SCALED VALUE OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 22-25
!                 (6):  SCALE FACTOR OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 26
!                 (7):  SCALED VALUE OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 27-30
!                 (8):  NUMBER OF POINTS ALONG A PARALLEL, OCTS 31-34
!                 (9):  NUMBER OF POINTS ALONG A MERIDIAN, OCTS 35-38
!                 (10): BASIC ANGLE OF INITIAL PRODUCTION DOMAIN,
!                       OCTETS 39-42
!                 (11): SUBDIVISIONS OF BASIC ANGLE, OCTETS 43-46
!                 (12): LATITUDE OF FIRST GRID POINT, OCTETS 47-50
!                 (13): LONGITUDE OF FIRST GRID POINT, OCTETS 51-54
!                 (14): RESOLUTION AND COMPONENT FLAGS, OCTET 55
!                 (15): LATITUDE OF LAST GRID POINT, OCTETS 56-59
!                 (16): LONGITUDE OF LAST GRID POINT, OCTETS 60-63
!                 (17): I-DIRECTION INCREMENT, OCTETS 64-67
!                 (18): J-DIRECTION INCREMENT, OCTETS 68-71
!                 (19): SCANNING MODE, OCTET 72
!                 (20): LATITUDE OF SOUTHERN POLE OF PROJECTION,
!                       OCTETS 73-76
!                 (21): LONGITUDE OF SOUTHERN POLE OF PROJECTION,
!                       OCTETS 77-80
!                 (22): ANGLE OF ROTATION OF PROJECTION, OCTS 81-84
!     IGDTLEN  - INTEGER NUMBER OF ELEMENTS (22) OF THE GRID DEFINITION
!                TEMPLATE ARRAY.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IOPT     - INTEGER OPTION FLAG
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
!                (ACCEPTABLE RANGE: -360. TO 360.)
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
!                (ACCEPTABLE RANGE: -90. TO 90.)
!
!   OUTPUT ARGUMENT LIST:
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT<0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT<0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT>0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT>0
!     NRET     - INTEGER NUMBER OF VALID POINTS COMPUTED
!     CROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION COSINES
!     SROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION SINES
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!     XLON     - REAL, OPTIONAL (NPTS) DX/DLON IN 1/DEGREES
!     XLAT     - REAL, OPTIONAL (NPTS) DX/DLAT IN 1/DEGREES
!     YLON     - REAL, OPTIONAL (NPTS) DY/DLON IN 1/DEGREES
!     YLAT     - REAL, OPTIONAL (NPTS) DY/DLAT IN 1/DEGREES
!     AREA     - REAL, OPTIONAL (NPTS) AREA WEIGHTS IN M**2
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,         INTENT(IN   ) :: IGDTNUM, IGDTLEN
 INTEGER,         INTENT(IN   ) :: IGDTMPL(IGDTLEN)
 INTEGER,         INTENT(IN   ) :: IOPT, NPTS
 INTEGER,         INTENT(  OUT) :: NRET
!
 REAL,            INTENT(IN   ) :: FILL
 REAL,            INTENT(INOUT) :: RLON(NPTS),RLAT(NPTS)
 REAL,            INTENT(INOUT) :: XPTS(NPTS),YPTS(NPTS)
 REAL, OPTIONAL,  INTENT(  OUT) :: CROT(NPTS),SROT(NPTS)
 REAL, OPTIONAL,  INTENT(  OUT) :: XLON(NPTS),XLAT(NPTS)
 REAL, OPTIONAL,  INTENT(  OUT) :: YLON(NPTS),YLAT(NPTS),AREA(NPTS)
!
 INTEGER                        :: IM, JM, IS1, N
 INTEGER                        :: ISCALE, ISCAN, KSCAN
 INTEGER                        :: I_OFFSET_ODD, I_OFFSET_EVEN
!
 LOGICAL                        :: LROT, LMAP, LAREA
!
 REAL(KIND=KD)                  :: RLAT0, RLAT1, RLON1
 REAL(KIND=KD)                  :: CLAT1, CLON1, CLONR, SLAT1
 REAL(KIND=KD)                  :: RLATR, RLONR, SBD, WBD, HS
 REAL                           :: DUM1, DUM2, HI
 REAL                           :: XMAX, XMIN, YMAX, YMIN, XPTF, YPTF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(PRESENT(CROT)) CROT=FILL
 IF(PRESENT(SROT)) SROT=FILL
 IF(PRESENT(XLON)) XLON=FILL
 IF(PRESENT(XLAT)) XLAT=FILL
 IF(PRESENT(YLON)) YLON=FILL
 IF(PRESENT(YLAT)) YLAT=FILL
 IF(PRESENT(AREA)) AREA=FILL
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! IS THIS A ROTATED LAT/LON GRID?
 IF(IGDTNUM/=1)THEN
   CALL ROT_EQUID_CYLIND_EGRID_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
   RETURN
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! IS THE EARTH RADIUS DEFINED?
 CALL EARTH_RADIUS(IGDTMPL,IGDTLEN,DUM1,DUM2)
 RERTH=DUM1
 IF(RERTH<0.)THEN
   CALL ROT_EQUID_CYLIND_EGRID_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
   RETURN
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! ROUTINE ONLY WORKS FOR "E"-STAGGER GRIDS.
!   "V" GRID WHEN BIT 5 IS '1' AND BIT 6 IS '0'.
!   "H" GRID WHEN BIT 5 IS '0' AND BIT 6 IS '1'.
 I_OFFSET_ODD=MOD(IGDTMPL(19)/8,2)
 I_OFFSET_EVEN=MOD(IGDTMPL(19)/4,2)
 IF(I_OFFSET_ODD==I_OFFSET_EVEN) THEN
   CALL ROT_EQUID_CYLIND_EGRID_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
   RETURN
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 ISCALE=IGDTMPL(10)*IGDTMPL(11)
 IF(ISCALE==0) ISCALE=10**6
 RLAT0=FLOAT(IGDTMPL(20))/FLOAT(ISCALE)
 RLAT0=RLAT0+90.0_KD
 RLON0=FLOAT(IGDTMPL(21))/FLOAT(ISCALE)
 IROT=MOD(IGDTMPL(14)/8,2)
 IM=IGDTMPL(8)*2-1
 JM=IGDTMPL(9)
 DLATS=FLOAT(IGDTMPL(18))/FLOAT(ISCALE)
 DLONS=FLOAT(IGDTMPL(17))/FLOAT(ISCALE)
! THE GRIB2 CONVENTION FOR "I" RESOLUTION IS TWICE WHAT THIS ROUTINE ASSUMES.
 DLONS=DLONS*0.5_KD
 KSCAN=I_OFFSET_ODD
 ISCAN=MOD(IGDTMPL(19)/128,2)
 HI=(-1.)**ISCAN
 SLAT0=SIN(RLAT0/DPR)
 CLAT0=COS(RLAT0/DPR)
 RLAT1=FLOAT(IGDTMPL(12))/FLOAT(ISCALE)
 RLON1=FLOAT(IGDTMPL(13))/FLOAT(ISCALE)
 SLAT1=SIN(RLAT1/DPR)
 CLAT1=COS(RLAT1/DPR)
 CLON1=COS((RLON1-RLON0)/DPR)
 SLATR=CLAT0*SLAT1-SLAT0*CLAT1*CLON1
 CLATR=SQRT(1-SLATR**2)
 CLONR=(CLAT0*CLAT1*CLON1+SLAT0*SLAT1)/CLATR
 HS=SIGN(1._KD,MOD(RLON1-RLON0+180+3600,360._KD)-180)
 SBD=DPR*ASIN(SLATR)
 WBD=HS*DPR*ACOS(CLONR)
 IF(KSCAN.EQ.0) THEN
   IS1=(JM+1)/2
 ELSE
   IS1=JM/2
 ENDIF
 XMIN=0
 XMAX=IM+2
 YMIN=0
 YMAX=JM+1
 NRET=0
 IF(PRESENT(CROT).AND.PRESENT(SROT))THEN
   LROT=.TRUE.
 ELSE
   LROT=.FALSE.
 ENDIF
 IF(PRESENT(XLON).AND.PRESENT(XLAT).AND.PRESENT(YLON).AND.PRESENT(YLAT))THEN
   LMAP=.TRUE.
 ELSE
   LMAP=.FALSE.
 ENDIF
 IF(PRESENT(AREA))THEN
   LAREA=.TRUE.
 ELSE
   LAREA=.FALSE.
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE GRID COORDINATES TO EARTH COORDINATES
 IF(IOPT.EQ.0.OR.IOPT.EQ.1) THEN
   DO N=1,NPTS
     XPTF=YPTS(N)+(XPTS(N)-IS1)
     YPTF=YPTS(N)-(XPTS(N)-IS1)+KSCAN
     IF(XPTF.GE.XMIN.AND.XPTF.LE.XMAX.AND. &
        YPTF.GE.YMIN.AND.YPTF.LE.YMAX) THEN
       HS=HI*SIGN(1.,XPTF-(IM+1)/2)
       RLONR=(XPTF-1.0_KD)*DLONS + WBD
       RLATR=(YPTF-1.0_KD)*DLATS + SBD
       CLONR=COS(RLONR/DPR)
       SLATR=SIN(RLATR/DPR)
       CLATR=COS(RLATR/DPR)
       SLAT=CLAT0*SLATR+SLAT0*CLATR*CLONR
       IF(SLAT.LE.-1) THEN
         CLAT=0.
         CLON=COS(RLON0/DPR)
         RLON(N)=0
         RLAT(N)=-90
       ELSEIF(SLAT.GE.1) THEN
         CLAT=0.
         CLON=COS(RLON0/DPR)
         RLON(N)=0
         RLAT(N)=90
       ELSE
         CLAT=SQRT(1-SLAT**2)
         CLON=(CLAT0*CLATR*CLONR-SLAT0*SLATR)/CLAT
         CLON=MIN(MAX(CLON,-1._KD),1._KD)
         RLON(N)=MOD(RLON0+HS*DPR*ACOS(CLON)+3600,360._KD)
         RLAT(N)=DPR*ASIN(SLAT)
       ENDIF
       NRET=NRET+1
       IF(LROT) CALL ROT_EQUID_CYLIND_EGRID_VECT_ROT(RLON(N),CROT(N),SROT(N))
       IF(LMAP) CALL ROT_EQUID_CYLIND_EGRID_MAP_JACOB(FILL, RLON(N), &
                                        XLON(N),XLAT(N),YLON(N),YLAT(N))
       IF(LAREA) CALL ROT_EQUID_CYLIND_EGRID_GRID_AREA(FILL, AREA(N))
     ELSE
       RLON(N)=FILL
       RLAT(N)=FILL
     ENDIF
   ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE EARTH COORDINATES TO GRID COORDINATES
 ELSEIF(IOPT.EQ.-1) THEN
   DO N=1,NPTS
     IF(ABS(RLON(N)).LE.360.AND.ABS(RLAT(N)).LE.90) THEN
       HS=SIGN(1._KD,MOD(RLON(N)-RLON0+180+3600,360._KD)-180)
       CLON=COS((RLON(N)-RLON0)/DPR)
       SLAT=SIN(RLAT(N)/DPR)
       CLAT=COS(RLAT(N)/DPR)
       SLATR=CLAT0*SLAT-SLAT0*CLAT*CLON
       IF(SLATR.LE.-1) THEN
         CLATR=0.
         RLONR=0
         RLATR=-90
       ELSEIF(SLATR.GE.1) THEN
         CLATR=0.
         RLONR=0
         RLATR=90
       ELSE
         CLATR=SQRT(1-SLATR**2)
         CLONR=(CLAT0*CLAT*CLON+SLAT0*SLAT)/CLATR
         CLONR=MIN(MAX(CLONR,-1._KD),1._KD)
         RLONR=HS*DPR*ACOS(CLONR)
         RLATR=DPR*ASIN(SLATR)
       ENDIF
       XPTF=((RLONR-WBD)/DLONS)+1.0_KD
       YPTF=((RLATR-SBD)/DLATS)+1.0_KD
       IF(XPTF.GE.XMIN.AND.XPTF.LE.XMAX.AND. &
          YPTF.GE.YMIN.AND.YPTF.LE.YMAX) THEN
         XPTS(N)=IS1+(XPTF-(YPTF-KSCAN))/2
         YPTS(N)=(XPTF+(YPTF-KSCAN))/2
         NRET=NRET+1
         IF(LROT) CALL ROT_EQUID_CYLIND_EGRID_VECT_ROT(RLON(N),CROT(N),SROT(N))
         IF(LMAP) CALL ROT_EQUID_CYLIND_EGRID_MAP_JACOB(FILL, RLON(N), &
                                          XLON(N),XLAT(N),YLON(N),YLAT(N))
         IF(LAREA) CALL ROT_EQUID_CYLIND_EGRID_GRID_AREA(FILL, AREA(N))
       ELSE
         XPTS(N)=FILL
         YPTS(N)=FILL
       ENDIF
     ELSE
       XPTS(N)=FILL
       YPTS(N)=FILL
     ENDIF
   ENDDO
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE GDSWZD_ROT_EQUID_CYLIND_EGRID
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SUBROUTINE ROT_EQUID_CYLIND_EGRID_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  ROT_EQUID_CYLIND_EGRID_ERROR  ERROR HANDLER
!   PRGMMR: GAYNO       ORG: W/NMC23       DATE: 2015-07-13
!
! ABSTRACT: UPON AN ERROR, THIS SUBPROGRAM ASSIGNS
!           A "FILL" VALUE TO THE OUTPUT FIELDS.

! PROGRAM HISTORY LOG:
! 2015-07-13  GAYNO     INITIAL VERSION
! 2015-09-17  GAYNO     RENAME AS "ROT_EQUID_CYLIND_EGRID_ERROR"
!
! USAGE:   CALL ROT_EQUID_CYLIND_EGRID_ERROR(IOPT,FILL,RLAT,RLON,
!                                            XPTS,YPTS,NPTS)
!
!   INPUT ARGUMENT LIST:
!     IOPT     - INTEGER OPTION FLAG
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!   OUTPUT ARGUMENT LIST:
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER, INTENT(IN   ) :: IOPT, NPTS
!
 REAL,    INTENT(IN   ) :: FILL
 REAL,    INTENT(  OUT) :: RLAT(NPTS),RLON(NPTS)
 REAL,    INTENT(  OUT) :: XPTS(NPTS),YPTS(NPTS)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(IOPT>=0) THEN
   RLON=FILL
   RLAT=FILL
 ENDIF
 IF(IOPT<=0) THEN
   XPTS=FILL
   YPTS=FILL
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE ROT_EQUID_CYLIND_EGRID_ERROR
!
 SUBROUTINE ROT_EQUID_CYLIND_EGRID_VECT_ROT(RLON, CROT, SROT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  ROT_EQUID_CYLIND_EGRID_VECT_ROT  VECTOR ROTATION FIELDS
!                                               FOR ROTATED EQUIDISTANT
!                                               CYLINDRICAL "E" GRIDS.
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE VECTOR ROTATION SINES AND
!           COSINES FOR A ROTATED EQUIDISTANT CYLINDRICAL GRID -
!           "E" STAGGER.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "ROT_EQUID_CYLIND_EGRID_VECT_ROT"
!
! USAGE:    CALL ROT_EQUID_CYLIND_EGRID_VECT_ROT(RLON, CROT, SROT)
!
!   INPUT ARGUMENT LIST:
!     RLON     - LONGITUDE IN DEGREES (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     CROT     - CLOCKWISE VECTOR ROTATION COSINES (REAL)
!     SROT     - CLOCKWISE VECTOR ROTATION SINES (REAL)
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 REAL         ,    INTENT(IN   ) :: RLON
 REAL         ,    INTENT(  OUT) :: CROT, SROT

 REAL(KIND=KD)                   :: SLON

 IF(IROT.EQ.1) THEN
   IF(CLATR.LE.0) THEN
     CROT=-SIGN(1._KD,SLATR*SLAT0)
     SROT=0.
   ELSE
     SLON=SIN((RLON-RLON0)/DPR)
     CROT=(CLAT0*CLAT+SLAT0*SLAT*CLON)/CLATR
     SROT=SLAT0*SLON/CLATR
   ENDIF
 ELSE
   CROT=1.
   SROT=0.
 ENDIF

 END SUBROUTINE ROT_EQUID_CYLIND_EGRID_VECT_ROT
!
 SUBROUTINE ROT_EQUID_CYLIND_EGRID_MAP_JACOB(FILL, RLON, &
                                 XLON, XLAT, YLON, YLAT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  ROT_EQUID_CYLIND_EGRID_MAP_JACOB:
!   MAP JACOBIANS FOR ROTATED EQUIDISTANT CYLINDRICAL
!   GRIDS - "E" STAGGER.
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE MAP JACOBIANS FOR
!           A ROTATED EQUIDISTANT CYLINDRICAL GRID -
!           "E" STAGGER.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "ROT_EQUID_CYLIND_EGRID_MAP_JACOB"
!
! USAGE:  CALL ROT_EQUID_CYLIND_EGRID_MAP_JACOB(FILL,RLON,XLON,
!                                               XLAT,YLON,YLAT)
!
!   INPUT ARGUMENT LIST:
!     FILL     - FILL VALUE FOR UNDEFINED POINTS (REAL)
!     RLON     - LONGITUDE IN DEGREES (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     XLON     - DX/DLON IN 1/DEGREES (REAL)
!     XLAT     - DX/DLAT IN 1/DEGREES (REAL)
!     YLON     - DY/DLON IN 1/DEGREES (REAL)
!     YLAT     - DY/DLAT IN 1/DEGREES (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 REAL         ,    INTENT(IN   ) :: FILL, RLON
 REAL         ,    INTENT(  OUT) :: XLON, XLAT, YLON, YLAT

 REAL(KIND=KD)                   :: SLON, TERM1, TERM2
 REAL(KIND=KD)                   :: XLATF, XLONF, YLATF, YLONF

 IF(CLATR.LE.0._KD) THEN
   XLON=FILL
   XLAT=FILL
   YLON=FILL
   YLAT=FILL
 ELSE
   SLON=SIN((RLON-RLON0)/DPR)
   TERM1=(CLAT0*CLAT+SLAT0*SLAT*CLON)/CLATR
   TERM2=SLAT0*SLON/CLATR
   XLONF=TERM1*CLAT/(DLONS*CLATR)
   XLATF=-TERM2/(DLONS*CLATR)
   YLONF=TERM2*CLAT/DLATS
   YLATF=TERM1/DLATS
   XLON=XLONF-YLONF
   XLAT=XLATF-YLATF
   YLON=XLONF+YLONF
   YLAT=XLATF+YLATF
 ENDIF

 END SUBROUTINE ROT_EQUID_CYLIND_EGRID_MAP_JACOB
!
 SUBROUTINE ROT_EQUID_CYLIND_EGRID_GRID_AREA(FILL, AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  ROT_EQUID_CYLIND_EGRID_GRID_AREA:
!    GRID BOX AREA FOR ROTATED EQUIDISTANT CYLINDRICAL
!    GRIDS - "E" STAGGER.
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE GRID BOX AREA FOR
!           A ROTATED EQUIDISTANT CYLINDRICAL GRID -
!           "E" STAGGER.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "ROT_EQUID_CYLIND_EGRID_GRID_AREA"
!
! USAGE:  CALL ROT_EQUID_CYLIND_EGRID_GRID_AREA(FILL,AREA)
!
!   INPUT ARGUMENT LIST:
!     FILL     - FILL VALUE FOR UNDEFINED POINTS (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     AREA     - AREA WEIGHTS IN M**2 (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 REAL,             INTENT(IN   ) :: FILL
 REAL,             INTENT(  OUT) :: AREA

 IF(CLATR.LE.0._KD) THEN
   AREA=FILL
 ELSE
   AREA=RERTH**2*CLATR*DLATS*DLONS*2/DPR**2
 ENDIF

 END SUBROUTINE ROT_EQUID_CYLIND_EGRID_GRID_AREA

 END MODULE GDSWZD_ROT_EQUID_CYLIND_EGRID_MOD


C --- ------------------------------ READ_VCS_HYD ------------------------------
      SUBROUTINE READ_VCS_HYD
C --- Input of tabulated VCS Balmer profiles based on the UNIFIED THEORY as
C --- developed by Vidal, Cooper and Smith (1970, JQSRT 10,1011),
C --- This subroutine determines the STARK-Function PHI(NUE), by linear
C --- interpolation of tables calculated by T.Schoening and K.Butler (1989).
C --- Subroutine adapted from Klaus Fuhrmann

      INCLUDE 'physcnst.inc'           ! Physical constants
      INCLUDE 'lf_decl0.inc'           ! common declarations

      INTEGER*4 itmp                   ! temporary integer
      INTEGER*4 nhe_nr(NBALMER)        ! Nr of electron-density points of line k
      INTEGER*4 nht_nr(NBALMER)        ! Nr of temperatur points of line k
      REAL*4    nelog                  ! log(e-density)
      REAL*4    tlog                   ! log(T(n))
      REAL*4    grid_vcs(NHW,NHE,NHT,NBALMER) ! buffer for VCS-profiles of all NBALMER lines
      REAL*4    grid_vcs_ijk(NHT)      ! temporary buffer for VCS-profile interpolation
      REAL*4    grid_vcs_ik (NHE)      ! temporary buffer for VCS-profile interpolation
      REAL*4    e_vcs_k     (NHE)      ! temporary buffer for e-density gridpoints of one line
      REAL*4    t_vcs_k     (NHT)      ! temporary buffer for t-gridpoints of one line

      COMMON/READ_VCS_HYD_WORK/itmp,nhe_nr,nht_nr,nelog,tlog,grid_vcs,
     *          grid_vcs_ijk,grid_vcs_ik,e_vcs_k,t_vcs_k
      env_len = IGETENV('SIU_MAIN',env)
      OPEN (UNIT = 28, FILE = env(1:env_len)//'/data/'//BALMER_FILE,
     *      STATUS = 'UNKNOWN', FORM = 'UNFORMATTED',READONLY)
C&VAX OPEN (UNIT = 28, FILE = BALMER_FILE, STATUS = 'UNKNOWN',
C&VAX*      FORM = 'UNFORMATTED',READONLY,SHARED)
      READ (28) (nhw_nr(k),(w_vcs(j,k),j=1,nhw_nr(k)),
     *           nht_nr(k),(t_vcs(j,k),j=1,nht_nr(k)),
     *           nhe_nr(k),(e_vcs(j,k),j=1,nhe_nr(k)),
     *           (((grid_vcs(i,j,m,k),i=1,nhw_nr(k)),
     *             m=1,nht_nr(k)),j=1,nhe_nr(k)),k=1,NBALMER)
      CLOSE(28)

C --- Get relevant Balmer lines for quadratic interpolation
      balmer_max = 0
      balmer_min = 1

      DO k = 1,NBALMER
        IF ( wmin .LE. wbalmer(k) + 1.e-6 )  balmer_max = k
      END DO

      DO k = NBALMER,1,-1
        IF ( wmax .GE. wbalmer(k) - 1.e-6 )  balmer_min = k
      END DO

      DO k = balmer_min,balmer_max           ! begin of balmerlines loop
        DO i = 1,nht_nr(k)
          t_vcs_k(i) = t_vcs(i,k)
        END DO

        DO i = 1,nhe_nr(k)
          e_vcs_k(i) = e_vcs(i,k)
        END DO

        DO n = 1, atm.h.ndepth                      ! begin of stratification loop
          tlog   = LOG10(atm.t(n))
          nelog  = LOG10(atm.pe(n)) - tlog - LOG_K

C --- Check temperature and density range

          IF (k .EQ. balmer_min) THEN
            IF ( (tlog .LT. t_vcs(1,k)) .OR.
     *           (tlog .GT. t_vcs(nht_nr(k),k)) ) THEN
              WRITE(CHN,*) 'temperature - interpolation out of bounds'
              lf_status = JIBSET(lf_status,0)         ! Fatal Error
              lf_status = JIBSET(lf_status,4)         ! Fatal Error
              RETURN
            ENDIF
            IF ((nelog .LT. e_vcs(1,k)) .OR.
     *                 (nelog .GT. e_vcs(nhe_nr(k),k))) THEN
              WRITE(6,*) 'electron density - interpolation out',
     *                   ' of bounds --> extrapolation !'
C              lf_status = JIBSET(lf_status,0)         ! Fatal Error
C              lf_status = JIBSET(lf_status,5)         ! Fatal Error
C              RETURN
            ENDIF
          ENDIF

C ---     Quadratic interpolation of PHI(NUE) as a function of (T,NE)
          DO i = 1, nhw_nr(k)
            DO j = 1,nhe_nr(k)
              DO m = 1,nht_nr(k)
                grid_vcs_ijk(m) = grid_vcs(i,j,m,k)
              END DO
              grid_vcs_ik(j) =
     *            QPOL(tlog,t_vcs_k,grid_vcs_ijk,nht_nr(k),itmp)
            END DO
            phi_vcs(i,n,k) =
     *          QPOL(nelog,e_vcs_k,grid_vcs_ik,nhe_nr(k),itmp)
          END DO
        END DO                               ! end of stratification loop
      ENDDO                                  ! end of balmerlines loop
      RETURN
      END


       subroutine sigms (tk, theta, rs, nleg, rat, iz, sig2)
c
c  copyright 1993  university of washington
c                  john rehr, steve zabinsky, matt newville
c
c  the following routines calculate the debye-waller factor for a
c  path based on the temperature, debye temperature, average
c  norman radius, atoms in the path, and their positions.
c  these routines come courtesy of jj rehr and si zabinsky.
c  i changed them a bit.   matt n
c-------------------------------------------------------------------
c
c  from s i zabinsky.
c  inputs:
c       tk      temperature in degrees k
c       theta   debye temp in degrees k
c       rs      average wigner seitz or norman radius in bohr
c                     averaged over entire problem:
c                     (4pi/3)*rs**3 = sum( (4pi/3)rnrm**3 ) / n
c                     (sum is over all atoms in the problem)
c       nleg    nlegs in path
c       rat     positions of each atom in path (in bohr)
c       iz      atomic number of each atom in path
c output:
c       sig2    debye waller factor
c  notes:
c     all units of distance in this routine are angstroms
c     there are nleg atoms including the central atom.
c     index 0 and index nleg both refer to central atom.
       implicit none
       integer          i, j, nleg, nlegx
       double precision tk, theta, rs, sig2, zero, two
       double precision rij, rimjm, rimj, riim, rjjm, ridotj, corrfn
       double precision  dist, cij, cimjm, cijm, cimj, sig2ij, rijm
       parameter (nlegx = 7, zero = 0.d0, two = 2.d0)
       double precision  rat(3,0:nlegx)
       integer iz(0:nlegx)
       external dist, corrfn
c
       sig2   = zero
       do 800 i  = 1, nleg
         do 800 j = i, nleg
c
c  calculate r_i-r_i-1 and r_j-r_j-1 and the rest of the
c  distances, and get the partial cosine term:
c       cosine(i,j) = r_i.r_j / ((r_i - r_i-1) * (r_j - r_j-1))
           rij    = dist ( rat(1,i)  , rat(1,j)   )
           rimjm  = dist ( rat(1,i-1), rat(1,j-1))
           rijm   = dist ( rat(1,i)  , rat(1,j-1))
           rimj   = dist ( rat(1,i-1), rat(1,j)   )
           riim   = dist ( rat(1,i)  , rat(1,i-1))
           rjjm   = dist ( rat(1,j)  , rat(1,j-1))
           ridotj = (rat(1,i)-rat(1,i-1)) * (rat(1,j)-rat(1,j-1))
     $            + (rat(2,i)-rat(2,i-1)) * (rat(2,j)-rat(2,j-1))
     $            + (rat(3,i)-rat(3,i-1)) * (rat(3,j)-rat(3,j-1))
c
c  call corrfn to get the correlations between atom pairs
           cij   = corrfn (rij  , theta, tk, iz(i)  , iz(j)  , rs)
           cimjm = corrfn (rimjm, theta, tk, iz(i-1), iz(j-1), rs)
           cijm  = corrfn (rijm , theta, tk, iz(i)  , iz(j-1), rs)
           cimj  = corrfn (rimj , theta, tk, iz(i-1), iz(j)  , rs)
c
c  combine outputs of corrfn to give the debye-waller factor for
c    this atom pair.   !!! note: don't double count (i.eq.j) terms !!!
           sig2ij = (cij + cimjm - cijm - cimj)*ridotj/(riim * rjjm)
           if (j.eq.i) sig2ij = sig2ij / two
           sig2 = sig2 + sig2ij
 800   continue
       sig2 = sig2/2
       return
c  end subroutine sigms
       end
       double precision function corrfn(rij, theta, tk,iz1,iz2,rs)
c
c  copyright 1993  university of washington
c                  john rehr, steve zabinsky, matt newville
c
c  subroutine calculates correlation function
c  c(ri, rj) = <xi xj> in the debye approximation
c
c            = (1/n)sum_k exp(ik.(ri-rj)) (1/sqrt(mi*mj))*
c                              (hbar/2w_k)*coth(beta hbar w_k/2)
c
c            = (3kt/mu w_d**2) * sqrt(mu**2/mi*mj) * int
c  where :
c       x        k_d*r (distance parameter)  r distance in angstroms
c       theta    debye temp in degrees k
c       tk       temperature in degrees k
c       temper   theta / tk = hbar omegad/kt
c       k_d      debye wave number = (6*pi**2 n/v)
c       n/v      free electron number density = 1/(4pi/3rs**3)
c       rs       wigner seitz or norman radius in bohr
c       ami      atomic mass at sites i in amu
c       amj      atomic mass at sites j in amu
c       int      int_0^1 (temper/x) dw sin(wx)coth(w*temper/2)
c
c  solution by numerical integration
c
c  parameters pi, bohr, con
c  con=hbar**2/kb*amu)*10**20   in ang**2 units
c  hbar=1.0549x10**-34 amu=1.65979x10-27kg kb=1.3807x10-23
       implicit none
       integer  iz1, iz2
       double precision rs, theta, tk,  rij, rx, tx
       double precision conr, conh, rmass, debint, at_weight
       parameter (conh = 72.8385d0, conr = 4.5693346333d0)
       external at_weight, debint
c
c  theta in degrees k, t temperature in degrees k
       rx     = conr  * rij / rs
       tx     = theta / tk
       rmass  = theta * sqrt( at_weight(iz1) *  at_weight(iz2))
       corrfn = conh  * debint (rx,tx) / rmass
       return
c  end subroutine corrfn
       end
       double precision function debfun(w,rx,tx)
c
c  copyright 1993  university of washington
c                  john rehr, steve zabinsky, matt newville
c
c  debfun = (sin(w*rx)/rx) * coth(w*tx/2)
c
       implicit none
       double precision  wmin, argmax, w, emwt
       parameter (wmin = 1.d-20, argmax = 50.d0)
       double precision rx, tx

c  allow t = 0 without bombing
       debfun = 2 / tx
       if (w.gt.wmin) then
          debfun = w
          if (rx.gt.0) debfun = sin(w*rx) / rx
          emwt   = exp(-min(w*tx,argmax))
          debfun = debfun * (1 + emwt) / (1 - emwt)
       end if
       return
c  end function debfun
       end
       double precision function debint (rx,tx)
c
c  copyright 1993  university of washington
c                  john rehr, steve zabinsky, matt newville
c
c  subroutine calculates integrals between [0,1]  b = int_0^1 f(z) dz
c  by trapezoidal rule and binary refinement  (romberg integration)
c  coded by j rehr (10 feb 92)   see, e.g., numerical recipes
c  for discussion and a much fancier version
c-----------------------------------------------
c     del=dz  itn=2**n tol=1.e-5
c     starting values
c      implicit double precision (a-h,o-z)
c     error is approximately 2**(-2n) ~ 10**(-.6n)
c     so nmax=10 implies an error of 1.e-6
c
       implicit none
       integer  nmax, n, itn, i
       double precision tol, zero, one, two, three, debfun
       double precision rx, tx
       parameter(nmax = 12, tol = 1.d-9)
       parameter(zero=0.d0, one=1.d0, two=2.d0, three=3.d0)
       double precision del, bn, bo, zi, sum, bnp1
       external debfun
c
       itn = 1
       del  = one
       debint = zero
       bn   = (debfun(zero,rx,tx) + debfun(one,rx,tx)) /2
       bo   = bn
       do 40 n = 1, nmax
c  nth iteration
c  b_n+1=(b_n)/2+deln*sum_0^2**n f([2n-1]deln)
         del = del / two
         sum = zero
         do 20 i= 1, itn
            zi  = (two * i - 1) * del
            sum = sum + debfun(zi,rx,tx)
 20      continue
c     bnp1=b_n+1 is current value of integral
c     cancel leading error terms b=[4b-bn]/3
c     note: this is the first term in the neville table - remaining
c           errors were found too small to justify the added code
         bnp1   = del * sum + (bn / two)
         debint = (4 * bnp1 - bn)/three
         if (abs( (debint - bo) / debint).lt.tol) goto 45
         bn   = bnp1
         bo   = debint
         itn  = itn * 2
 40    continue
 45    continue
       return
c end function debint
       end
       double precision function dist (r0, r1)
c  find distance between cartesian points r0 and r1
       double precision   r0(3), r1(3)
       dist = 0.d0
       do 10  i = 1, 3
          dist = dist + (r0(i) - r1(i))**2
 10    continue
       dist = sqrt(dist)
       return
c  end function dist
       end
       subroutine cordby(x, nx, y, ny, ierr)
c
c  copyright 1993  university of washington      matt newville
c  copyright 1999  university of chicago         matt newville
c
c  calculate xafs sigma^2 from correlated debye model ala jj rehr
c  important note:   the path information is looked up in the
c      common block /fefdat/, using the path held in scalar 'path_index'
c
c     x  = theta on input, sigma2 on output
c     y =  temperature
c-
       include 'consts.h'
       include 'arrays.h'
       include 'feffit.h'
       include 'fefdat.h'
       include 'pthpar.h'
       double precision x(*), y(*),  getsca, out(maxpts)
       double precision tk, theta, sig2, rat(3,0:maxleg)
       double precision small, big
       parameter(small =1.d-5, big =1.d10)

       integer  ierr, iz(0:maxleg), i, j, ipth, jfeff
       integer  u2ipth, inpath, nx1, ny1, nptstk, ipt, ix, iy
       external getsca, u2ipth, nptstk
c
       ierr = 0
       nx1  = nx
       ny1  = ny
       nx   = nptstk (nx1, ny1)

       ipth = max(1, int ( getsca('path_index',0)))
cc       print*, '  cordby: ', nx1, ny1, nx , ipth
       jfeff  = -1
       if (ipth.ge.1) then
          inpath = u2ipth(max(1, ipth))
          jfeff  = jpthff(inpath)
cc          print*, ' cordby: ', ipth, inpath, jfeff
          do 50 i = 0, nlgpth(jfeff)
             iz(i)   = izpth(i,jfeff)
             do 40 j = 1,3
                rat(j,i)  = ratpth(j,i,jfeff)
 40          continue
 50       continue
       end if
cc       print*, '  cordby 100   nx = ', nx
       do 100 ipt = 1, nx
          ix     = min(nx1, ipt)
          iy     = min(ny1, ipt)
          theta  = max(small, min(big, x(ix)))
          tk     = max(small, min(big, y(iy)))
          sig2  = zero
          if (jfeff.ge.1) then
             call sigms(tk,theta,rwgpth(jfeff),
     $            nlgpth(jfeff),rat,iz,sig2)
          endif
          out(ipt) = sig2
cc          print*, ' debye: ipt ' , ipt, tk, theta, sig2
 100   continue
       do 120 ipt = 1, nx
          x(ipt) = out(ipt)
 120   continue
       return
c  end subroutine cordby
       end
       subroutine eins(x, nx, y, ny, ierr)
c
c calculate debye waller in einstein model
c  inputs
c     x  = theta on input, sigma2 on output
c     y  = temp
c
c  calculate sigma^2 in the eisntein model inputs:
c  returned:
c    x      sigma squared [AA^2]
c                = factor / (theta*rmass*tanh(theta/2t))
c    with factor = hbarc*hbarc/(two * boltz * amu2ev)
c
c  copyright (c) 1998  matt newville
       include 'consts.h'
       include 'arrays.h'
       include 'fefdat.h'
       include 'pthpar.h'
       integer   nx, ny, ierr, i, ipth, nx1, ny1, nptstk, ipt
       integer  u2ipth, inpath, jfeff
       double precision  x(*), y(*), tmp, getsca, theta, tk
       double precision  out(maxpts), a
       double precision small, big, factor, rminv, at_weight
       parameter(factor = 24.25423371d0, small =1.d-5, big =1.d10)
       external  getsca, at_weight, nptstk, u2ipth
       ierr  = -1

       nx1  = nx
       ny1  = ny
       nx   = nptstk (nx1, ny1)
       ipth = max(1, int ( getsca('path_index',0)))
c  construct reduced mass (in amu) using function at_weight
       inpath = u2ipth(max(1, ipth))
       rminv  = zero
       jfeff  = jpthff(inpath)
       do 50 i = 1, nlgpth(jfeff)
          a     = at_weight( izpth(i, jfeff))
          rminv = rminv +  one /max(one, a)
  50   continue
       rminv  = factor*max(small, min(big, rminv))
c
c       print*, ' eins: ', rminv, nx, ipth, x(1), y(1), y(2)
c       print*,  inpath, jfeff, nlgpth(jfeff), 1./rminv
       do 100 ipt = 1, nx
          ix     = min(nx1, ipt)
          iy     = min(ny1, ipt)
          theta  = max(small, min(big, x(ix)))
          tk     = max(small, min(big, y(iy)))
          out(ipt) = zero
          ierr   = 0
c evaluate sigma2 in einstein model, and overwrite x
          if (ipth.ne.0) then
             out(ipt)= rminv/(tanh(theta/(2*tk))*theta)
          endif
 100   continue
       do 120 ipt = 1, nx
          x(ipt) = out(ipt)
 120   continue
       return
c end subroutine eins
       end


!##############################################################################
!# ****************************************************************************
!# <name> disto3d_aux </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains a hand full of auxiliary routines for the
!# elemdbg3d_testX debugger modules.
!#
!# The following routines can be found in this module:
!#
!# .) disto3d_calcDomainVolume
!#    -> Calculates the total volume of the domain represented by a
!#       triangulation by integration of the 1-function.
!#
!# .) disto3d_calcFaceNormalDeviation
!#    -> Calculates the maximal and mean face normal deviation (in respect to
!#       the face's midpoint normal) over all faces of a given triangulation.
!#
!# .) disto3d_calcFaceNLDeviation
!#    -> Calculates the maximal and mean non-linear deviation of all faces
!#       of a given triangulation.
!#
!# .) disto3d_distortCubeCoords
!#    -> Distorts the vertices of a CUBE mesh by coordinate-based stochastical
!#       distortion.
!#
!# .) disto3d_distortCubePlaneXY
!#    -> Distorts the vertices of a CUBE mesh by XY-plane-wise index-based
!#       stochastical distortion.
!#
!# .) disto3d_distortCubePlaneXZ
!#    -> Distorts the vertices of a CUBE mesh by XZ-plane-wise index-based
!#       stochastical distortion.
!#
!# .) disto3d_distortCubePlaneYZ
!#    -> Distorts the vertices of a CUBE mesh by YZ-plane-wise index-based
!#       stochastical distortion.
!#
!# </purpose>
!##############################################################################

module disto3d_aux

use fsystem
use genoutput
use storage
use cubature
use basicgeometry
use transformation
use triangulation
use random

implicit none

contains

  ! ***************************************************************************

!<subroutine>

  pure subroutine disto3d_calcFaceTrafo(Dv, Dtrafo)

!<description>
  ! AUXILIARY ROUTINE:
  ! Calculates the transformation coefficients for a bilinear face trafo from
  ! the reference quadrilateral onto a real face.
!</description>

!<input>
  ! The coordinates of the four corner vertices of the face.
  real(DP), dimension(3,4), intent(IN) :: Dv
!</input>

!<output>
  ! The transformation coefficients for the bilinear trafo.
  real(DP), dimension(4,3), intent(OUT) :: Dtrafo
!</output>

!</subroutine>

  integer :: i

    do i = 1, 3
      Dtrafo(1,i) = 0.25_DP*( Dv(i,1)+Dv(i,2)+Dv(i,3)+Dv(i,4))
      Dtrafo(2,i) = 0.25_DP*(-Dv(i,1)+Dv(i,2)+Dv(i,3)-Dv(i,4))
      Dtrafo(3,i) = 0.25_DP*(-Dv(i,1)-Dv(i,2)+Dv(i,3)+Dv(i,4))
      Dtrafo(4,i) = 0.25_DP*( Dv(i,1)-Dv(i,2)+Dv(i,3)-Dv(i,4))
    end do

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine disto3d_calcFaceNormal(Dtrafo, dx, dy, Dnormal)

!<description>
  ! AUXILIARY ROUTINE:
  ! Calculates the normal vector on a face.
!</description>

!<input>
  ! The transformation coefficients of the face, as returned by the
  ! disto3d_calcFaceTrafo routine.
  real(DP), dimension(4,3), intent(IN) :: Dtrafo

  ! A point on the reference quadrilateral [-1,1]x[-1,1] for which the normal
  ! vector is to be calculated.
  real(DP), intent(IN) :: dx, dy
!</input>

!<output>
  ! The normal vector in the point Dx.
  real(DP), dimension(3), intent(OUT) :: Dnormal
!</output>

!</subroutine>

  ! jacobian matrix
  real(DP), dimension(3,2) :: Djac
  real(DP) :: daux
  integer :: i

    ! Calculate the jacobian matrix in the point Dx.
    do i = 1, 3
      Djac(i,1) = Dtrafo(2,i) + Dtrafo(4,i)*dy
      Djac(i,2) = Dtrafo(3,i) + Dtrafo(4,i)*dx
    end do

    ! Calculate the normal vector as the cross-product of the jacobian matrix's
    ! columns.
    Dnormal(1) = Djac(2,1)*Djac(3,2) - Djac(3,1)*Djac(2,2)
    Dnormal(2) = Djac(3,1)*Djac(1,2) - Djac(1,1)*Djac(3,2)
    Dnormal(3) = Djac(1,1)*Djac(2,2) - Djac(2,1)*Djac(1,2)

    ! Calculate the length of the normal vector
    daux = sqrt(Dnormal(1)**2 + Dnormal(2)**2 + Dnormal(3)**2)
    if(daux .gt. 0.0_DP) then
      ! Normalise the vector
      Dnormal = Dnormal * (1.0_DP / daux)
    end if

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine disto3d_calcDomainVolume(rtria, dvolume)

!<description>
  ! Calculates the volume of the domain represented by the triangulation.
!</description>

!<input>
  ! The triangulation whose total volume is to be determined.
  type(t_triangulation), intent(IN) :: rtria
!</input>

!<output>
  ! The total volume of the domain.
  real(DP), intent(OUT) :: dvolume
!</output>

!</subroutine>

  ! Parameter: Cubature formula
  integer(I32), parameter :: ccubature = CUB_G2_3D

  ! Arrays for the cubature formula
  integer(I32) :: ncubp
  real(DP), dimension(:,:), allocatable :: DcubPts
  real(DP), dimension(:), allocatable :: Domega

  ! Arrays for the triangulation
  real(DP), dimension(:,:), pointer :: p_Dvtx
  integer, dimension(:,:), pointer :: p_Ielem

  ! Array for the corner vertice coordinates
  real(DP), dimension(3,8) :: Dcorners

  ! Array for the transformation
  real(DP), dimension(TRAFO_NAUXJAC3D) :: DjacPrep

  ! Dummy array for jacobian matrix
  real(DP), dimension(9) :: Djac

  ! Other local variables
  integer :: iel, i
  real(DP) :: ddet

    ! Make sure the triangulation is 3D.
    if(rtria%ndim .ne. NDIM3D) then
      call output_line ('Mesh must be a 3D mesh!', &
                        OU_CLASS_ERROR,OU_MODE_STD,'disto3d_calcDomainVolume')
      call sys_halt()
    end if

    ! Make sure the mesh consists only of hexahedra.
    if(rtria%NEL .ne. rtria%InelOfType(TRIA_NVEHEXA3D)) then
      call output_line ('Mesh must contain only hexahedra!', &
                        OU_CLASS_ERROR,OU_MODE_STD,'disto3d_calcDomainVolume')
      call sys_halt()
    end if

    ! Get the arrays from the triangulation
    call storage_getbase_double2D(rtria%h_DvertexCoords, p_Dvtx)
    call storage_getbase_int2D(rtria%h_IverticesAtElement, p_Ielem)

    ! Init the cubature formula
    ncubp = cub_igetNumPts(ccubature)
    allocate(DcubPts(3,ncubp))
    allocate(Domega(ncubp))
    call cub_getCubature(ccubature, DcubPts, Domega)

    ! Loop over all elements
    dvolume = 0.0_DP
    !$omp parallel do private(i,Dcorners,DjacPrep,Djac,ddet) reduction(+:dvolume)
    do iel = 1, rtria%NEL

      ! Get the element's corner vertice coordinates
      do i = 1, 8
        Dcorners(:,i) = p_Dvtx(:,p_Ielem(i,iel))
      end do

      ! Calculate trafo
      call trafo_prepJac_hexa3D(Dcorners, DjacPrep)

      ! Calculate determinants for all points and perform the integration
      do i = 1, ncubp
        call trafo_calcJac_hexa3D (DjacPrep, Djac, ddet, &
                     DcubPts(1,i), DcubPts(2,i), DcubPts(3,i))

        dvolume = dvolume + abs(ddet)*Domega(i)
      end do

    end do ! iel
    !$omp end parallel do

    deallocate(Domega)
    deallocate(DcubPts)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine disto3d_calcFaceNormalDeviation(rtria, dmaxDev, dmeanDev, ccubature)

!<description>
  ! Calculates the mean and maximum normal vector deviation for the faces of
  ! a given triangulation.
  !
  ! Let T:[-1,1]^2 -> R^3 denote the bilinear transformation from the
  ! reference quadrilateral onto a real face and let N:[-1,1]^2 -> R^3 denote
  ! the normal vector field of T.
  !
  ! Then the normal deviation of the transformation is defined as:
  !
  !                          k
  !        Normal_Dev(T) := max || N(x_i,y_i) - N(0,0) ||_2
  !                         i=1
  !
  ! for some set { (x_1,y_1),...,(x_k,y_k) } of points on the reference quad.
  !
  ! Remark:
  ! If the face is planar, then the normal deviation of the face is always 0.
!</description>

!<input>
  ! The triangulation whose face normal deviation is to be determined.
  type(t_triangulation), intent(IN) :: rtria

  ! OPTIONAL: A cubature formula identifier which specifies in which points
  ! the normals are to be calculated. If given, must be a valid quadrilateral
  ! cubatuture rule. If not specified, the trapezoidal rule is used.
  integer, optional, intent(IN) :: ccubature
!</input>

!<output>
  ! The maximum of all face normal deviations.
  real(DP), intent(OUT) :: dmaxDev

  ! The mean of all face normal deviations.
  real(DP), intent(OUT) :: dmeanDev
!</output>

!</subroutine>

  ! Arrays for the cubature formula
  integer(I32) :: ccub,ncubp
  real(DP), dimension(:,:), allocatable :: DcubPts
  real(DP), dimension(:), allocatable :: Domega

  ! Arrays for the triangulation
  real(DP), dimension(:,:), pointer :: p_Dvtx
  integer, dimension(:,:), pointer :: p_Iface
  real(DP), dimension(3,4) :: Dcorners

  ! Array for the bilinear trafo
  real(DP), dimension(4,3) :: Dtrafo

  ! Arrays for the normal vectors
  real(DP), dimension(3) :: Dnormal1, Dnormal2

  ! Other local variables
  integer :: iat, i
  real(DP) :: daux, daux2

    ! Make sure the triangulation is 3D.
    if(rtria%ndim .ne. NDIM3D) then
      call output_line ('Mesh must be a 3D mesh!', &
          OU_CLASS_ERROR,OU_MODE_STD,'disto3d_calcFaceNormalDeviation')
      call sys_halt()
    end if

    ! Make sure the mesh consists only of hexahedra.
    if(rtria%NEL .ne. rtria%InelOfType(TRIA_NVEHEXA3D)) then
      call output_line ('Mesh must contain only hexahedra!', &
          OU_CLASS_ERROR,OU_MODE_STD,'disto3d_calcFaceNormalDeviation')
      call sys_halt()
    end if

    ! Get the arrays from the triangulation
    call storage_getbase_double2D(rtria%h_DvertexCoords, p_Dvtx)
    call storage_getbase_int2D(rtria%h_IverticesAtFace, p_Iface)

    ! Init the cubature formula
    ccub = CUB_TRZ
    if(present(ccubature)) then

      ! Check the shape
      if(cub_igetShape(int(ccubature,I32)) .ne. BGEOM_SHAPE_QUAD) then
        call output_line ('Cubature rule is not a valid quadrilateral rule!', &
            OU_CLASS_ERROR,OU_MODE_STD,'disto3d_calcFaceNormalDeviation')
        call sys_halt()
      else
        ccub = int(ccubature,I32)
      end if
    end if

    ncubp = cub_igetNumPts(ccub)
    allocate(DcubPts(2,ncubp))
    allocate(Domega(ncubp))
    call cub_getCubature(ccub, DcubPts, Domega)

    ! Deallocate Domega, as we don't need it
    deallocate(Domega)

    ! Reset the deviations
    dmaxDev = 0.0_DP
    dmeanDev = 0.0_DP

    ! Loop over all faces
    do iat = 1, rtria%NAT

      ! Get the corner vertice coordinates
      do i = 1, 4
        Dcorners(:,i) = p_Dvtx(:,p_Iface(i,iat))
      end do

      ! Calculate the trafo coefficients
      call disto3d_calcFaceTrafo(Dcorners, Dtrafo)

      ! Calculate the normal vector in the face midpoint
      call disto3d_calcFaceNormal(Dtrafo, 0.0_DP, 0.0_DP, Dnormal1)

      ! Loop over all other normal vectors
      daux = 0.0_DP
      do i = 1, ncubp

        ! Calculate normal vector in cubature point
        call disto3d_calcFaceNormal(Dtrafo, DcubPts(1,i), DcubPts(2,i), &
                                    Dnormal2)

        ! Subtract mid-point normal vector
        Dnormal2 = Dnormal2 - Dnormal1

        ! Calculate euclid norm of deviation vector
        daux2 = sqrt(Dnormal2(1)**2 + Dnormal2(2)**2 + Dnormal2(3)**2)

        ! Calculate maximum for the current face
        daux = max(daux, daux2)

      end do

      ! Incorporate local deviation to global ones
      dmaxDev = max(dmaxDev, daux)
      dmeanDev = dmeanDev + daux

    end do ! iat

    ! Deallocate cubature points
    deallocate(DcubPts)

    ! Calculate mean deviation
    if(rtria%NAT .gt. 0) dmeanDev = dmeanDev / real(rtria%NAT,DP)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine disto3d_calcFaceNLDeviation(rtria, dmaxDev, dmeanDev)

!<description>
  ! Calculates the mean and maximum non-linear deviation for the faces of
  ! a given triangulation.
  !
  ! Let T denote the bilinear transformation from the reference quadrilateral
  ! onto a real face in the triangulation of the form:
  !
  !        T: [-1,1]^2 -> R^3
  !
  !        T(x,y) = a1 + a2*x + a3*y + a4*x*y
  !
  ! with a1,...,a4 in R^3 being the corresponding transformation vectors.
  !
  ! Then the non-linear deviation of the transformation is defined as:
  !
  !        NL_Dev(T) := || a4 ||_2 / || a2 X a3 ||_2
  !
  ! where 'X' denotes the 3D cross-product (outer product).
  !
  ! Remark:
  ! If a face is a parallelogram, then its non-linear deviation is 0.
!</description>

!<input>
  ! The triangulation whose face non-linear deviation is to be determined.
  type(t_triangulation), intent(IN) :: rtria
!</input>

!<output>
  ! The maximum of all face non-linear deviations.
  real(DP), intent(OUT) :: dmaxDev

  ! The mean of all face non-linear deviations.
  real(DP), intent(OUT) :: dmeanDev
!</output>

!</subroutine>

  ! Arrays for the triangulation
  real(DP), dimension(:,:), pointer :: p_Dvtx
  integer, dimension(:,:), pointer :: p_Iface
  real(DP), dimension(3,4) :: Dcorners

  ! Arrays for the bilinear trafo
  real(DP), dimension(4,3) :: Dtrafo

  ! Other local variables
  integer :: iat, i
  real(DP) :: daux, daux2

    ! Make sure the triangulation is 3D.
    if(rtria%ndim .ne. NDIM3D) then
      call output_line ('Mesh must be a 3D mesh!', &
          OU_CLASS_ERROR,OU_MODE_STD,'disto3d_calcFaceNLDeviation')
      call sys_halt()
    end if

    ! Make sure the mesh consists only of hexahedra.
    if(rtria%NEL .ne. rtria%InelOfType(TRIA_NVEHEXA3D)) then
      call output_line ('Mesh must contain only hexahedra!', &
          OU_CLASS_ERROR,OU_MODE_STD,'disto3d_calcFaceNLDeviation')
      call sys_halt()
    end if

    ! Get the arrays from the triangulation
    call storage_getbase_double2D(rtria%h_DvertexCoords, p_Dvtx)
    call storage_getbase_int2D(rtria%h_IverticesAtFace, p_Iface)

    ! Reset the deviations
    dmaxDev = 0.0_DP
    dmeanDev = 0.0_DP

    ! Loop over all faces
    do iat = 1, rtria%NAT

      ! Get the corner vertice coordinates
      do i = 1, 4
        Dcorners(:,i) = p_Dvtx(:,p_Iface(i,iat))
      end do

      ! Calculate the trafo coefficients
      call disto3d_calcFaceTrafo(Dcorners, Dtrafo)

      ! Calculate norm of linear trafo factors
      daux2 = (Dtrafo(2,2)*Dtrafo(3,3) - Dtrafo(2,3)*Dtrafo(3,2))**2 &
            + (Dtrafo(2,3)*Dtrafo(3,1) - Dtrafo(2,1)*Dtrafo(3,3))**2 &
            + (Dtrafo(2,1)*Dtrafo(3,2) - Dtrafo(2,2)*Dtrafo(3,1))**2

      ! Jump out if the linear factors are zero
      if(daux2 .eq. 0.0_DP) then
        dmaxDev = SYS_INFINITY_DP
        dmeanDev = SYS_INFINITY_DP
        return
      end if

      ! Calculate norm of non-linear factors
      daux = Dtrafo(4,1)**2 + Dtrafo(4,2)**2 + Dtrafo(4,3)**2

      ! Calculate non-linear deviation
      daux = sqrt(daux / daux2)

      ! Incorporate local deviation to global ones
      dmaxDev = max(dmaxDev, daux)
      dmeanDev = dmeanDev + daux

    end do ! iat

    ! Calculate mean deviation
    if(rtria%NAT .gt. 0) dmeanDev = dmeanDev / real(rtria%NAT,DP)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine disto3d_distortCubeCoords(rtria, ddist)

!<description>
  ! Distorts the vertices of a CUBE mesh by coordinate-based stochastical
  ! distortion.
!</description>

!<input>
  ! The distortion parameter
  real(DP), intent(IN) :: ddist
!</input>

!<inputoutput>
  ! The CUBE mesh that is to be distorted.
  type(t_triangulation), intent(INOUT) :: rtria
!</inputoutput>

!</subroutine>

  ! local variables
  type(t_random) :: rrng
  real(DP), dimension(:,:), pointer :: p_Dvtx
  real(DP) :: dhdist,dhdist2,dh,dtol,dx,dy,dz
  integer :: i,ivt,invt
  integer(i32) :: iv

    ! Compute inverse mesh width
    dh = real(rtria%NVT,DP)**(1.0_DP/3.0_DP) - 1.0_DP

    ! compute tolerance for boundary vertices
    dtol = 0.5_DP / dh

    ! Compute number of vertices per dimension
    invt = int(dh) + 1

    ! Compute distortion parameters
    dhdist = ddist / dh
    if(dhdist .eq. 0.0_DP) return

    ! Get arrays from the triangulation
    call storage_getbase_double2d (rtria%h_DvertexCoords, p_Dvtx)

    ! seed the rng with the vertex count
    call rng_init(rrng, int(rtria%NVT, I32))

    ! Loop over the vertices
    do ivt = 1, rtria%NVT

      ! compute distortion
      call rng_get_int32(rrng, iv)
      dx = real(1 - iand(ishft(iv,-1), 2), DP)*dhdist
      dy = real(1 - iand(ishft(iv,-2), 2), DP)*dhdist
      dz = real(1 - iand(ishft(iv,-3), 2), DP)*dhdist

      ! Distort the vertice's coordiantes.
      if((p_Dvtx(1,ivt) .gt. dtol) .and. (p_Dvtx(1,ivt)+dtol .lt. 1.0_DP)) &
        p_Dvtx(1,ivt) = p_Dvtx(1,ivt) + dx
      if((p_Dvtx(2,ivt) .gt. dtol) .and. (p_Dvtx(2,ivt)+dtol .lt. 1.0_DP)) &
        p_Dvtx(2,ivt) = p_Dvtx(2,ivt) + dy
      if((p_Dvtx(3,ivt) .gt. dtol) .and. (p_Dvtx(3,ivt)+dtol .lt. 1.0_DP)) &
        p_Dvtx(3,ivt) = p_Dvtx(3,ivt) + dz

    end do

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine disto3d_distortCubePlaneXY(rtria, ddist, dsecDist)

!<description>
  ! Distorts the vertices of a CUBE mesh by XY-plane-wise index-based
  ! stochastical distortion.
!</description>

!<input>
  ! The distortion parameters
  real(DP), intent(IN) :: ddist, dsecDist
!</input>

!<inputoutput>
  ! The CUBE mesh that is to be distorted.
  type(t_triangulation), intent(INOUT) :: rtria
!</inputoutput>

!</subroutine>

  ! local variables
  type(t_random) :: rrng
  real(DP), dimension(:,:), pointer :: p_Dvtx
  real(DP) :: dhdist,dhdist2,dh,dtol,dx,dy,dz
  integer :: i,ivt,invt
  integer(i32) :: iv,idx

    ! Compute inverse mesh width
    dh = real(rtria%NVT,DP)**(1.0_DP/3.0_DP) - 1.0_DP

    ! compute tolerance for boundary vertices
    dtol = 0.5_DP / dh

    ! Compute number of vertices per dimension
    invt = int(dh) + 1

    ! Compute distortion parameters
    dhdist = ddist / dh
    dhdist2 = dsecDist / dh
    if((dhdist .eq. 0.0_DP) .and. (dhdist2 .eq. 0.0_DP)) return

    ! Get arrays from the triangulation
    call storage_getbase_double2d (rtria%h_DvertexCoords, p_Dvtx)

    ! Loop over the vertices
    do ivt = 1, rtria%NVT

      ! Calculate plane index
      idx = int(p_Dvtx(1,ivt) * dh)*invt + int(p_Dvtx(2,ivt) * dh) + 1

      ! seed the rng with the plane index and advance it a few steps
      call rng_init(rrng, idx)
      do i = 1, mod(idx,7)
        call rng_advance(rrng)
      end do

      ! compute distortion
      call rng_get_int32(rrng, iv)
      dx = real(1 - iand(ishft(iv,-1), 2), DP)*dhdist
      dy = real(1 - iand(ishft(iv,-2), 2), DP)*dhdist
      dz = real(1 - iand(ishft(iv,-3), 2), DP)*dhdist2

      ! Distort the vertice's coordiantes.
      if((p_Dvtx(1,ivt) .gt. dtol) .and. (p_Dvtx(1,ivt)+dtol .lt. 1.0_DP)) &
        p_Dvtx(1,ivt) = p_Dvtx(1,ivt) + dx
      if((p_Dvtx(2,ivt) .gt. dtol) .and. (p_Dvtx(2,ivt)+dtol .lt. 1.0_DP)) &
        p_Dvtx(2,ivt) = p_Dvtx(2,ivt) + dy
      if((p_Dvtx(3,ivt) .gt. dtol) .and. (p_Dvtx(3,ivt)+dtol .lt. 1.0_DP)) &
        p_Dvtx(3,ivt) = p_Dvtx(3,ivt) + dz

    end do

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine disto3d_distortCubePlaneXZ(rtria, ddist, dsecDist)

!<description>
  ! Distorts the vertices of a CUBE mesh by XZ-plane-wise index-based
  ! stochastical distortion.
!</description>

!<input>
  ! The distortion parameters
  real(DP), intent(IN) :: ddist, dsecDist
!</input>

!<inputoutput>
  ! The CUBE mesh that is to be distorted.
  type(t_triangulation), intent(INOUT) :: rtria
!</inputoutput>

!</subroutine>

  ! local variables
  type(t_random) :: rrng
  real(DP), dimension(:,:), pointer :: p_Dvtx
  real(DP) :: dhdist,dhdist2,dh,dtol,dx,dy,dz
  integer :: i,ivt,invt
  integer(i32) :: iv,idx

    ! Compute inverse mesh width
    dh = real(rtria%NVT,DP)**(1.0_DP/3.0_DP) - 1.0_DP

    ! compute tolerance for boundary vertices
    dtol = 0.5_DP / dh

    ! Compute number of vertices per dimension
    invt = int(dh) + 1

    ! Compute distortion parameters
    dhdist = ddist / dh
    dhdist2 = dsecDist / dh
    if((dhdist .eq. 0.0_DP) .and. (dhdist2 .eq. 0.0_DP)) return

    ! Get arrays from the triangulation
    call storage_getbase_double2d (rtria%h_DvertexCoords, p_Dvtx)

    ! Loop over the vertices
    do ivt = 1, rtria%NVT

      ! Calculate plane index
      idx = int(p_Dvtx(1,ivt) * dh)*invt + int(p_Dvtx(3,ivt) * dh) + 1

      ! seed the rng with the plane index and advance it a few steps
      call rng_init(rrng, idx)
      do i = 1, mod(idx,7)
        call rng_advance(rrng)
      end do

      ! compute distortion
      call rng_get_int32(rrng, iv)
      dx = real(1 - iand(ishft(iv,-1), 2), DP)*dhdist
      dy = real(1 - iand(ishft(iv,-2), 2), DP)*dhdist2
      dz = real(1 - iand(ishft(iv,-3), 2), DP)*dhdist

      ! Distort the vertice's coordiantes.
      if((p_Dvtx(1,ivt) .gt. dtol) .and. (p_Dvtx(1,ivt)+dtol .lt. 1.0_DP)) &
        p_Dvtx(1,ivt) = p_Dvtx(1,ivt) + dx
      if((p_Dvtx(2,ivt) .gt. dtol) .and. (p_Dvtx(2,ivt)+dtol .lt. 1.0_DP)) &
        p_Dvtx(2,ivt) = p_Dvtx(2,ivt) + dy
      if((p_Dvtx(3,ivt) .gt. dtol) .and. (p_Dvtx(3,ivt)+dtol .lt. 1.0_DP)) &
        p_Dvtx(3,ivt) = p_Dvtx(3,ivt) + dz

    end do

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine disto3d_distortCubePlaneYZ(rtria, ddist, dsecDist)

!<description>
  ! Distorts the vertices of a CUBE mesh by YZ-plane-wise index-based
  ! stochastical distortion.
!</description>

!<input>
  ! The distortion parameters
  real(DP), intent(IN) :: ddist, dsecDist
!</input>

!<inputoutput>
  ! The CUBE mesh that is to be distorted.
  type(t_triangulation), intent(INOUT) :: rtria
!</inputoutput>

!</subroutine>

  ! local variables
  type(t_random) :: rrng
  real(DP), dimension(:,:), pointer :: p_Dvtx
  real(DP) :: dhdist,dhdist2,dh,dtol,dx,dy,dz
  integer :: i,ivt,invt
  integer(i32) :: iv,idx

    ! Compute inverse mesh width
    dh = real(rtria%NVT,DP)**(1.0_DP/3.0_DP) - 1.0_DP

    ! compute tolerance for boundary vertices
    dtol = 0.5_DP / dh

    ! Compute number of vertices per dimension
    invt = int(dh) + 1

    ! Compute distortion parameters
    dhdist = ddist / dh
    dhdist2 = dsecDist / dh
    if((dhdist .eq. 0.0_DP) .and. (dhdist2 .eq. 0.0_DP)) return

    ! Get arrays from the triangulation
    call storage_getbase_double2d (rtria%h_DvertexCoords, p_Dvtx)

    ! Loop over the vertices
    do ivt = 1, rtria%NVT

      ! Calculate plane index
      idx = int(p_Dvtx(2,ivt) * dh)*invt + int(p_Dvtx(3,ivt) * dh) + 1

      ! seed the rng with the plane index and advance it a few steps
      call rng_init(rrng, idx)
      do i = 1, mod(idx,7)
        call rng_advance(rrng)
      end do

      ! compute distortion
      call rng_get_int32(rrng, iv)
      dx = real(1 - iand(ishft(iv,-1), 2), DP)*dhdist2
      dy = real(1 - iand(ishft(iv,-2), 2), DP)*dhdist
      dz = real(1 - iand(ishft(iv,-3), 2), DP)*dhdist

      ! Distort the vertice's coordiantes.
      if((p_Dvtx(1,ivt) .gt. dtol) .and. (p_Dvtx(1,ivt)+dtol .lt. 1.0_DP)) &
        p_Dvtx(1,ivt) = p_Dvtx(1,ivt) + dx
      if((p_Dvtx(2,ivt) .gt. dtol) .and. (p_Dvtx(2,ivt)+dtol .lt. 1.0_DP)) &
        p_Dvtx(2,ivt) = p_Dvtx(2,ivt) + dy
      if((p_Dvtx(3,ivt) .gt. dtol) .and. (p_Dvtx(3,ivt)+dtol .lt. 1.0_DP)) &
        p_Dvtx(3,ivt) = p_Dvtx(3,ivt) + dz

    end do

  end subroutine

end module


c/****************************************
c   define.f for spp ver.1
c 2   Oct. '98    produced by D.KAWATA
c ****************************************/

      implicit none

      double precision M_PI
      parameter (M_PI=3.141592654)
c/*** Definition Max Number ***/
c/*** for particles ***/
c/* Max Number of Particle */
      integer MNR
      parameter (MNR=200)
c/* Max resolutsion in 1 D */
      integer MR
      parameter (MR=1100)

c/*** For Arithmetic Value ***/
      double precision THIRD,INF,DMINV
      parameter (THIRD=1.0/3.0)
      parameter (INF=1000000.0)
      parameter (DMINV=1.0e-6)

c /**** Simulattion Unit *****/
      double precision MUSM,TMUYR,LUKPC,VUKMS,DU
c /* mass unit ( solar mass ) */
      parameter(MUSM=1.0e12)
c /* time ( yr ) */
      parameter (TMUYR=4.71e8)
c /* length unit(100kpc)/kpc */
      parameter (LUKPC=1.0e2)
c /* km/s */
      parameter (VUKMS=207.4d0)
c /* Density */
      parameter (DU=6.77e-26)

c /*** For correction to massive star ***/
      double precision MSNR,MFSN,NFSN,MFSN11,NFSN11
c /* Mass fraction of Massive star */
      parameter (MSNR=1.4)
      parameter (MFSN=0.122182)
      parameter (NFSN=0.007310)
      parameter (MFSN11=0.249163)
      parameter (NFSN11=0.013824)


      SUBROUTINE F (W,WI,TP,XKZ,BZ,F0R,F0I,F1R,F1I,F2R,F2I)
	implicit integer (i,j,k,l,m,n)
	implicit real (a-h,o-z)
C
C	THIS RETURNS ZETA*F0 ETC, FROM STIX FIRST BOOK, ZETA IS ARGUMENT
C	iF0 is Fried and Conte Z
C
      DOUBLE PRECISION Z2R,Z2I,T,TR,TI,SR,SI,XN5,TTR,TTI,UR,UI,U,DTE,W2R,W2I
C      PARAMETER(DIV=4.11)
      PARAMETER(DIV=2.11)
C      PARAMETER(DIV=2.85)
C
      AR=W-XKZ*BZ
      B=XKZ*SQRT(2.*TP)
        IF (ABS(AR*AR-WI*WI)-80.*B*B) 100,100,105
  100 ZR=AR/B
      ZI=WI/B
      DTE=-DPROD(ZI,ZI)+DPROD(ZR,ZR)
      TE=DTE
      U=0.D00
      IF (ABS(TE).LT.80.) U=DEXP(-DTE)
C	print*,'f,100,tp,u',tp,u
      UI=-U*DSIN(DBLE(2.*ZR*ZI))*1.772453850905516D00
      UR=U*DCOS(DBLE(2.*ZR*ZI))*1.772453850905516D00
C	print*,'init u,ur,ui',u,ur,ui
C      U=PR(UR,UI,ZR,ZI)
C      UI=PI(UR,UI,ZR,ZI)
C      UR=U
      U=UR*DBLE(ZR) - UI*DBLE(ZI)
      UI=UR*DBLE(ZI) + UI*DBLE(ZR)
      UR=U
C      U2R=TPR(W,WI,W,WI,UR,UI)/XKZ/XKZ
C      U2I=TPI(W,WI,W,WI,UR,UI)/XKZ/XKZ
      W2R = (DPROD(W,W) - DPROD(WI,WI))/XKZ**2
      W2I = 2.D00*DPROD(W,WI)/XKZ**2
      U2R = W2R*UR - W2I*UI
      U2I = W2R*UI + W2I*UR
      GO TO 115
  105 IF ((AR*AR-WI*WI).LT.0..AND.WI.LT.0.) GO TO 110
      UR=0.
      UI=0.
      U2R=0.
      U2I=0.
C	print*,'f,105,tp,ur',tp,ur
      GO TO 115
  110 U=DEXP(80.D00)
      WRITE (7,180) AR,WI,W,TP,B
      WRITE (7,*) '****warning, subr F (dbl) too big', AR,WI,W
      print*, '****warning, subr F (dbl) too big', AR,WI,W
C      print*,'ar,wi,w,b', AR,WI,W,B
      UR=WI*U
      UI=UR
      U2R=UR
      U2I=UR
  115 IF (AR*AR+WI*WI-(DIV*B)**2) 120,120,135
C
C	ENTRY FOR POWER SERIES
C
  120 Z2R=DPROD(ZR,ZR)-DPROD(ZI,ZI)
      Z2I=2.D00*DPROD(ZR,ZI)
C	print*,'f,120,tp,z2r',tp,z2r
      TR=Z2R
      TI=Z2I
      SR=TR+DBLE(SIGN(.5,XKZ))*UI
      SI=TI-DBLE(SIGN(.5,XKZ))*UR
	pmax = 0.
      DO 125 N=1,100
        XN5=DFLOAT(N)+.5D00
        T=-(TR*Z2R-TI*Z2I)/XN5
        TI=-(TR*Z2I+TI*Z2R)/XN5
        TR=T
        SR=SR+TR
        SI=SI+TI
	psize = abs(tr) + abs(ti)
	if(psize.gt.pmax) then
	  max = n
	  pmax = psize
	endif
C	PRINT*,'N,SUM,TERM',N,DABS(SR)+DABS(SI),DABS(TR)+DABS(TI)
C	PRINT*,'N,UR,UI',N,UR,UI
C	PRINT*,'SR,SI,TR,TI,',SR,SI,TR,TI
        IF (DABS(SR)+DABS(SI)-1.0D9*(DABS(TR)+DABS(TI))) 125,125,130
  125   CONTINUE
  130 F0R=-2.*SI
      F0I=2.*SR
      F1R=(PR(W,WI,F0R,F0I)+WI)/XKZ
      F1I=(PI(W,WI,F0R,F0I)-AR)/XKZ
      F2R=(PR(W,WI,F1R,F1I)+BZ*WI)/XKZ
      F2I=(PI(W,WI,F1R,F1I)-BZ*AR)/XKZ
	write(10,*) w,wi,max,1.e-16*pmax,sqrt(AR*AR+WI*WI)/B
C	WRITE(7,*) F0R,F0I,F1R,F1I,F2R,F2I
      RETURN
C
C	ENTRY FOR ASYMPTOTIC SERIES
C
  135 ZR=QR(B,0.,AR,WI)
      ZI=QI(B,0.,AR,WI)
C	print*,'f,135,tp',tp
      YR=ZR*ZR-ZI*ZI
      YI=2.*ZR*ZI
      SR=QR(W,WI,AR,WI)
      SI=QI(W,WI,AR,WI)
      TR=-PI(SR,SI,SR,SI)*TP
      TI=PR(SR,SI,SR,SI)*TP
      IF (WI) 140,155,140
  140 IF (XKZ*WI) 145,145,150
  145 C=SIGN(2.,XKZ)
      GO TO 160
  150 C=0.
      GO TO 160
  155 C=SIGN(1.,XKZ)
  160 SR=TR+C*U2R
      SI=TI+C*U2I+BZ*BZ
	pmin = 1.e12
      DO 170 N=2,30
        XN5=DFLOAT(N)-.5D00
        TTR=XN5*(TR*YR-TI*YI)
        TTI=XN5*(TR*YI+TI*YR)
C		EXIT WHEN TERMS START TO GET LARGER
       IF (DABS(TR)+DABS(TI)-DABS(TTR)-DABS(TTI)) 175,165,165
  165   TR=TTR
        TI=TTI
        SR=SR+TR
        SI=SI+TI
	psize = abs(tr) + abs(ti)
	if(psize.lt.pmin) then
	  min = n
	  pmin = psize
	endif
C		EXIT IF TERMS ARE SMALL ENOUGH
        IF (DABS(SR)+DABS(SI)-1.0D+10*(DABS(TR)+DABS(TI))) 170,175,175
  170   CONTINUE
C      WRITE (7,180) SR,SI
  175 F2R=SR
      F2I=SI
      F1R=QR(XKZ*F2R-BZ*WI,XKZ*F2I+BZ*AR,W,WI)
      F1I=QI(XKZ*F2R-BZ*WI,XKZ*F2I+BZ*AR,W,WI)
      F0R=QR(XKZ*F1R-WI,XKZ*F1I+AR,W,WI)
      F0I=QI(XKZ*F1R-WI,XKZ*F1I+AR,W,WI)
	write(11,*) w,wi,min,pmin,sqrt(AR*AR+WI*WI)/B
C      WRITE(7,*) F0R,F0I,F1R,F1I,F2R,F2I
	RETURN
C
  180 FORMAT (1X,6E16.8)
      END


      SUBROUTINE VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,LENGTH,ISPV,SPV)
C
C +-----------------------------------------------------------------+
C |                                                                 |
C |                Copyright (C) 1986 by UCAR                       |
C |        University Corporation for Atmospheric Research          |
C |                    All Rights Reserved                          |
C |                                                                 |
C |                 NCARGRAPHICS  Version 1.00                      |
C |                                                                 |
C +-----------------------------------------------------------------+
C
C
C
C
C SUBROUTINE VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,LENGTH,ISPV,SPV)
C
C
C DIMENSION OF           U(LU,N),V(LV,N),SPV(2)
C ARGUMENTS
C
C LATEST REVISION        JULY 1984
C
C PURPOSE                VELVCT DRAWS A REPRESENTATION OF A TWO-
C                        DIMENSIONAL VELOCITY FIELD BY DRAWING ARROWS
C                        FROM EACH DATA LOCATION.  THE LENGTH OF THE
C                        ARROW IS PROPORTIONAL TO THE STRENGTH OF THE
C                        FIELD AT THAT LOCATION AND THE DIRECTION OF
C                        THE ARROW INDICATES THE DIRECTION OF THE FLOW
C                        AT THAT LOCATION.
C
C USAGE                  IF THE FOLLOWING ASSUMPTIONS ARE MET, USE
C
C                               CALL EZVEC (U,V,M,N)
C
C                          ASSUMPTIONS -
C
C                            --THE WHOLE ARRAY IS PROCESSED.
C                            --THE SCALE FACTOR IS CHOSEN INTERNALLY.
C                            --THE PERIMETER IS DRAWN.
C                            --FRAME IS CALLED AFTER PLOTTING.
C                            --THERE ARE NO SPECIAL VALUES.
C
C                        IF THESE ASSUMPTIONS ARE NOT MET, USE
C
C                               CALL VELVCT (U,LU,V,LV,M,N,FLO,HI,
C                                                 NSET,LENGTH,ISPV,SPV)
C
C ARGUMENTS
C
C ON INPUT               U,V
C
C                          THE (ORIGINS OF THE) TWO-DIMENSIONAL ARRAYS
C                          CONTAINING THE VELOCITY FIELD TO BE PLOTTED.
C                          THE VECTOR AT THE POINT (I,J) HAS MAGNITUDE
C                          SQRT(U(I,J)**2+V(I,J)**2) AND DIRECTION
C                          ATAN2(V(I,J),U(I,J)).  OTHER REPRESENTATIONS,
C                          SUCH AS (R,THETA), CAN BE PLOTTED BY
C                          CHANGING STATEMENT FUNCTIONS IN THIS ROUTINE.
C
C                        LU
C
C                          THE FIRST DIMENSION OF U IN THE CALLING
C                          PROGRAM.
C
C                        LV
C
C                          THE FIRST DIMENSION OF V IN THE CALLING
C                          PROGRAM.
C
C                        M
C
C                          THE NUMBER OF DATA VALUES TO BE PLOTTED IN
C                          THE X-DIRECTION (THE FIRST SUBSCRIPT
C                          DIRECTION).  WHEN PLOTTING THE ENTIRE ARRAY,
C                          LU = LV = M.
C
C                        N
C
C                          THE NUMBER OF DATA VALUES TO BE PLOTTED IN
C                          THE Y-DIRECTION (THE SECOND SUBSCRIPT
C                          DIRECTION).
C
C                        FLO
C
C                          THE MINIMUM VECTOR MAGNITUDE TO BE SHOWN.
C
C                        HI
C
C                          THE MAXIMUM VECTOR MAGNITUDE TO BE SHOWN. (A
C                          VALUE LESS THAN OR EQUAL TO ZERO CAUSES THE
C                          MAXIMUM VALUE OF SQRT(U**2+V**2) TO BE USED.)
C
C                        NSET
C
C                          FLAG TO CONTROL SCALING -
C
C                          IF NSET IS ZERO, VELVCT ESTABLISHES THE
C                          WINDOW AND VIEWPORT TO PROPERLY
C                          SCALE PLOTTING INSTRUCTIONS TO THE STANDARD
C                          CONFIGURATION.  PERIM IS CALLED TO DRAW A
C                          BORDER.
C
C                          IF NSET IS GREATER THAN ZERO, VELVCT ASSUMES
C                          THAT THE USER HAS ESTABLISHED THE WINDOW
C                          AND VIEWPORT IN SUCH A WAY AS TO PROPERLY
C                          SCALE THE PLOTTING INSTRUCTIONS GENERATED
C                          BY VELVCT.  PERIM IS NOT CALLED.
C
C                          IF NSET IS LESS THAN ZERO, VELVCT
C                          PLACES THE CONTOUR PLOT
C                          WITHIN THE LIMITS OF THE USER'S CURRENT
C                          WINDOW AND VIEWPORT.  PERIM IS NOT CALLED.
C
C                        LENGTH
C
C                          THE LENGTH, IN PLOTTER ADDRESS UNITS (PAUS),
C                          OF A VECTOR HAVING MAGNITUDE HI
C                          (OR, IF HI=0, THE LENGTH IN PAUS
C                          OF THE LONGEST VECTOR).  IF LENGTH=0, A
C                          VALUE IS CHOSEN SUCH THAT THE LONGEST VECTOR
C                          COULD JUST REACH TO THE TAIL OF THE NEXT
C                          VECTOR.  IF THE HORIZONTAL AND VERTICAL
C                          RESOLUTIONS OF THE PLOTTER ARE DIFFERENT,
C                          LENGTH SHOULD BE NON-ZERO AND SPECIFIED AS A
C                          HORIZONTAL DISTANCE.
C
C                        ISPV
C
C                          FLAG TO CONTROL THE SPECIAL VALUE FEATURE.
C
C                             0 MEANS THAT THE FEATURE IS NOT IN USE.
C
C                             1 MEANS THAT IF THE VALUE OF
C                               U(I,J)=SPV(1) THE VECTOR WILL NOT BE
C                               PLOTTED.
C
C                             2 MEANS THAT IF THE VALUE OF
C                               V(I,J)=SPV(2) THE VECTOR WILL NOT BE
C                               PLOTTED.
C
C                             3 MEANS THAT IF EITHER U(I,J)=SPV(1) OR
C                               V(I,J)=SPV(2) THEN THE VECTOR WILL NOT
C                               BE PLOTTED.
C
C                             4 MEANS THAT IF U(I,J)=SPV(1)
C                               AND V(I,J)=SPV(2), THE VECTOR
C                               WILL NOT BE PLOTTED.
C
C                        SPV
C
C                        AN ARRAY OF LENGTH 2 WHICH GIVES THE VALUE
C                        IN THE U ARRAY AND THE VALUE IN THE V ARRAY
C                        WHICH DENOTE MISSING VALUES.
C                        THIS ARGUMENT IS IGNORED IF ISPV=0.
C
C
C ON OUTPUT              ALL ARGUMENTS REMAIN UNCHANGED.
C
C NOTE                   THE ENDPOINTS OF EACH ARROW DRAWN ARE (FX(X,Y),
C                        FY(X,Y)) AND (MXF(X,Y,U,V,SFX,SFY,MX,MY),
C                        MYF(X,Y,U,V,SFX,SFY,MX,MY)) WHERE X=I, Y=J,
C                        U=U(I,J), V=V(I,J), AND SFX AND SFY ARE SCALE
C                        FACTORS.  HERE I IS THE X-INDEX AND J IS THE
C                        Y-INDEX.  (MX,MY) IS THE LOCATION OF THE TAIL.
C                        THUS THE ACTUAL LENGTH OF THE ARROW IS
C                        SQRT(DX**2+DY**2) AND THE DIRECTION IS
C                        ATAN2(DX,DY), WHERE DX=MX-MXF(...) AND
C                        DY=MY-MYF(...).
C
C ENTRY POINTS           VELVCT,EZVECT,DRWVEC,VELVEC,VELDAT
C
C COMMON BLOCKS          VEC1,VEC2
C
C I/O                    PLOTS THE VECTOR FIELD.
C
C PRECISION              SINGLE
C
C LANGUAGE               FORTRAN
C
C REQUIRED LIBRARY       GRIDAL AND THE SPPS
C ROUTINES
C
C HISTORY                WRITTEN AND STANDARDIZED IN NOVEMBER 1973.
C                        REVISED IN MAY, 1975, TO INCLUDE MXF AND MYF.
C                        REVISED IN MARCH, 1981, TO FIX CERTAIN ERRORS;
C                        TO USE FL2INT AND PLOTIT INSTEAD OF MXMY,
C                        FRSTPT, AND VECTOR; AND TO MAKE THE ARROWHEADS
C                        NARROWER.  CONVERTED TO FORTRAN77 AND GKS
C                        IN JULY 1984.
C
C ALGORITHM              EACH VECTOR IS EXAMINED, POSSIBLY TRANSFORMED,
C                        THEN PLOTTED.
C
C PORTABILITY            FORTRAN77
C
C ---------------------------------------------------------------------
C
C SPECIAL NOTE -
C
C USING THIS ROUTINE TO PUT VECTORS ON AN ARBITRARY BACKGROUND DRAWN BY
C SUPMAP IS A BIT TRICKY.  THE ARITHMETIC STATEMENT FUNCTIONS FX AND FY
C ARE EASY TO REPLACE.  THE PROBLEM ARISES IN REPLACING MXF AND MYF.
C THE FOLLOWING EXAMPLE MAY BE HELPFUL. (SUPMAP IS AN ENTRY POINT IN
C THE EZMAP PACKAGE.)
C
C SUPPOSE THAT WE HAVE TWO ARRAYS, CLON(36,9) AND CLAT(36,9), WHICH
C CONTAIN THE E-W AND N-S COMPONENTS OF A WIND FLOW FIELD ON THE SURFACE
C OF THE EARTH.  CLON(I,J) IS THE MAGNITUDE OF THE EASTERLY FLOW.
C CLAT(I,J) IS THE MAGNITUDE OF THE NORTHERLY FLOW AT A LONGITUDE (I-1)
C *10 DEGREES EAST OF GREENWICH AND A LATITUDE (J-1)*10 DEGREES NORTH OF
C THE EQUATOR.  SUPMAP IS TO BE USED TO DRAW A POLAR PROJECTION OF THE
C EARTH AND VELVCT IS TO BE USED TO SUPERIMPOSE VECTORS REPRESENTING THE
C FLOW FIELD ON IT.  THE FOLLOWING STEPS WOULD BE NECESSARY:
C
C     1.  CALL SUPMAP (1,90.,0.,-90.,90.,90.,90.,90.,-4,10,0,1,IER)
C         TO DRAW THE MAP.
C
C     2.  CALL VELVCT (CLON,36,CLAT,36,36,9,0.,0.,1,50,0,0.) TO PUT
C         VECTORS ON IT.  NOTICE THAT NSET HAS THE VALUE 1 TO TELL
C         VELVCT THAT SUPMAP HAS DONE THE REQUIRED SET CALL.
C
C     3.  IN ORDER TO ENSURE THAT STEP 2 WILL WORK PROPERLY, DELETE
C         THE ARITHMETIC STATEMENT FUNCTIONS FX, FY, MXF, AND MYF
C         FROM VELVCT AND INCLUDE THE FOLLOWING FUNCTIONS.
C
C     FUNCTION FX(XX,YY)
C     CALL MAPTRN (10.*(YY-1.),10.*(XX-1.),X,Y)
C     FX=X
C     RETURN
C     END
C
C     FUNCTION FY(XX,YY)
C     CALL MAPTRN (10.*(YY-1.),10.*(XX-1.),X,Y)
C     FY=Y
C     RETURN
C     END
C
C     FUNCTION MXF(XX,YY,UU,VV,SFX,SFY,MX,MY)
C     CFCT=COS(.17453292519943*(YY-1.))
C     CALL MAPTRN(10.*(YY-1.)         ,10.*(XX-1.)              ,X1,Y1)
C     CALL MAPTRN(10.*(YY-1.)+1.E-6*VV,10.*(XX-1.)+1.E-6*UU/CFCT,X2,Y2)
C     U=((X2-X1)/SQRT((X2-X1)**2+(Y2-Y1)**2))*SQRT(UU**2+VV**2)
C     MXF=MX+IFIX(SFX*U)
C     RETURN
C     END
C
C     FUNCTION MYF(XX,YY,UU,VV,SFX,SFY,MX,MY)
C     CFCT=COS(.17453292519943*(YY-1.))
C     CALL MAPTRN(10.*(YY-1.)         ,10.*(XX-1.)              ,X1,Y1)
C     CALL MAPTRN(10.*(YY-1.)+1.E-6*VV,10.*(XX-1.)+1.E-6*UU/CFCT,X2,Y2)
C     V=((Y2-Y1)/SQRT((X2-X1)**2+(Y2-Y1)**2))*SQRT(UU**2+VV**2)
C     MYF=MY+IFIX(SFY*V)
C     RETURN
C     END
C
C THE BASIC NOTION BEHIND THE CODING OF THE MXF AND MYF FUNCTIONS IS AS
C FOLLOWS.  SINCE UU AND VV ARE THE LONGITUDINAL AND LATITUDINAL COMPONENTS,
C RESPECTIVELY, OF A VELOCITY VECTOR HAVING UNITS OF DISTANCE OVER TIME,
C 1.E-6*UU/COS(LATITUDE) AND 1.E-6*VV REPRESENT THE CHANGE IN LONGITUDE
C AND LATITUDE, RESPECTIVELY, OF A PARTICLE MOVING WITH THE FLOW FIELD
C FOR A VERY SHORT PERIOD OF TIME.  THE ROUTINE MAPTRN IS USED TO FIND
C THE POSITION OF THE PARTICLE'S PROJECTION AT THE BEGINNING AND END OF
C THAT TINY TIME SLICE AND, THEREFORE, THE DIRECTION IN WHICH TO DRAW
C THE ARROW REPRESENTING THE VELOCITY VECTOR SO THAT IT WILL BE TANGENT
C TO A PROJECTED FLOW LINE OF THE FIELD AT THAT POINT.  THE VALUES U
C AND V ARE COMPUTED SO AS TO GIVE THE ARROW THE LENGTH IMPLIED BY UU
C AND VV.  (THE CODE ENSURES THAT SQRT(U**2+V**2) IS EQUAL TO
C SQRT(UU**2+VV**2).)  THE LENGTH OF THE ARROW REPRESENTS THE MAGNITUDE
C OF THE VELOCITY VECTOR, UNAFFECTED BY PERSPECTIVE.  THE SCALING SET
C UP BY VELVCT WILL THEREFORE BE APPROPRIATE FOR THE ARROWS DRAWN.
C
C THIS METHOD IS RATHER HEURISTIC AND HAS THREE INHERENT PROBLEMS.
C FIRST, THE CONSTANT 1.E-6 MAY NEED TO BE MADE LARGER OR SMALLER,
C DEPENDING ON THE MAGNITUDE OF YOUR U/V DATA.  SECOND, THE NORTH AND
C SOUTH POLES MUST BE AVOIDED.  AT EITHER POLE, CFCT GOES TO ZERO,
C GIVING A DIVISION BY ZERO; IN A SMALL REGION NEAR THE POLE, THE
C METHOD MAY TRY TO USE MAPTRN WITH A LATITUDE OUTSIDE THE RANGE
C (-90,+90).  THIRD, THE PROJECTION MUST BE SET UP SO AS TO AVOID
C HAVING VECTOR BASEPOINTS AT THE EXACT EDGE OF THE MAP.  VECTORS
C THERE WILL BE OF THE CORRECT LENGTH, BUT THEY MAY BE DRAWN IN THE
C WRONG DIRECTION (WHEN THE PROJECTED PARTICLE TRACK DETERMINING THE
C DIRECTION CROSSES THE EDGE AND REAPPEARS ELSEWHERE ON THE MAP).
C WITH A LITTLE CARE, THE DESIRED RESULTS MAY BE OBTAINED.
C ---------------------------------------------------------------------
C
C DECLARATIONS -
C
      COMMON /VEC1/   ASH        ,EXT        ,ICTRFG     ,ILAB       ,
     +                IOFFD      ,IOFFM      ,ISX        ,ISY        ,
     +                RMN        ,RMX        ,SIDE       ,SIZE       ,
     +                XLT        ,YBT        ,ZMN        ,ZMX
C
      COMMON /VEC2/   BIG        ,INCX       ,INCY
C
C ARGUMENT DIMENSIONS.
C
      DIMENSION       U(LU,N)    ,V(LV,N)    ,SPV(2)
        CHARACTER*10    LABEL
        REAL WIND(4), VIEW(4), IAR(4)
C
C ---------------------------------------------------------------------
C
C INTERNAL PARAMETERS OF VELVCT ARE AS FOLLOWS.  THE DEFAULT VALUES OF
C THESE PARAMETERS ARE DECLARED IN THE BLOCK DATA ROUTINE VELDAT.
C
C                        NAME   DEFAULT  FUNCTION
C                        ----   -------  --------
C
C                        BIG   R1MACH(2) CONSTANT USED TO INITIALIZE
C                                        POSSIBLE SEARCH FOR HI.
C
C                        EXT     0.25    THE LENGTHS OF THE SIDES OF THE
C                                        PLOT ARE PROPORTIONAL TO M AND
C                                        N WHEN NSET IS LESS THAN OR
C                                        EQUAL TO ZERO, EXCEPT WHEN
C                                        MIN(M,N)/MAX(M,N) IS LESS THAN
C                                        EXT, IN WHICH CASE A SQUARE
C                                        GRAPH IS PLOTTED.
C
C                        ICTRFG    1     FLAG TO CONTROL THE POSITION OF
C                                        THE ARROW RELATIVE TO  A BASE
C                                        POINT AT (MX,MY).
C
C                                        ZERO - CENTER AT (MX,MY)
C
C                                        POSITIVE - TAIL AT (MX,MY)
C
C                                        NEGATIVE -  HEAD AT (MX,MY)
C
C                        ILAB      0     FLAG TO CONTROL THE DRAWING OF
C                                        LINE LABELS.
C
C                                        ZERO - DO NOT DRAW THE LABELS
C
C                                        NON-ZERO - DRAW THE LABELS
C
C                        INCX      1     X-COORDINATE STEP SIZE FOR LESS
C                                        DENSE ARRAYS.
C
C                        INCY      1     Y-COORDINATE STEP SIZE.
C
C                        IOFFD     0     FLAG TO CONTROL NORMALIZATION
C                                        OF LABEL NUMBERS.
C
C                                        ZERO - INCLUDE A DECIMAL POINT
C                                        WHEN POSSIBLE
C
C                                        NON-ZERO - NORMALIZE ALL LABEL
C                                        NUMBERS BY ASH
C
C                        IOFFM     0     FLAG TO CONTROL PLOTTING OF
C                                        THE MESSAGE BELOW THE PLOT.
C
C                                        ZERO - PLOT THE MESSAGE
C
C                                        NON-ZERO - DO NOT PLOT IT
C
C                        RMN     160.    ARROW SIZE BELOW WHICH THE
C                                        HEAD NO LONGER SHRINKS, ON A
C                                        2**15 X 2**15 GRID.
C
C                        RMX    6400.    ARROW SIZE ABOVE WHICH THE
C                                        HEAD NO LONGER GROWS LARGER,
C                                        ON A 2**15 X 2**15 GRID.
C
C                        SIDE    0.90    LENGTH OF LONGER EDGE OF PLOT.
C                                        (SEE ALSO EXT.)
C
C                        SIZE    256.    WIDTH OF THE CHARACTERS IN
C                                        VECTOR LABELS, ON A 2**15 X
C                                        2**15 GRID.
C
C                        XLT     0.05    LEFT HAND EDGE OF THE PLOT.
C                                        (0 IS THE LEFT EDGE OF THE
C                                        FRAME, 1 THE RIGHT EDGE.)
C
C                        YBT     0.05    BOTTOM EDGE OF THE PLOT (0 IS
C                                        THE BOTTOM OF THE FRAME, 1 THE
C                                        TOP OF THE FRAME.)
C
C ---------------------------------------------------------------------
C
C INTERNAL FUNCTIONS WHICH MAY BE MODIFIED FOR DATA TRANSFORMATION -
C
C                        SCALE    COMPUTES A SCALE FACTOR USED IN THE
C                                 DETERMINATION OF THE LENGTH OF THE
C                                 VECTOR TO BE DRAWN.
C
C                        DIST     COMPUTES THE LENGTH OF A VECTOR.
C
C                        FX       RETURNS THE X INDEX AS THE
C                                 X-COORDINATE OF THE VECTOR BASE.
C
C                        MXF      RETURNS THE X-COORDINATE OF THE VECTOR
C                                 HEAD.
C
C                        FY       RETURNS THE Y INDEX AS THE
C                                 Y-COORDINATE OF THE VECTOR BASE.
C
C                        MYF      RETURNS THE Y-COORDINATE OF THE VECTOR
C                                 HEAD.
C
C                        VLAB     THE VALUE FOR THE VECTOR LABEL WHEN
C                                 ILAB IS NON-ZERO.
C
      SAVE
      DIST(XX,YY) = SQRT(XX*XX+YY*YY)
      FX(XX,YY) = XX
      FY(XX,YY) = YY
      MXF(XX,YY,UU,VV,SFXX,SFYY,MXX,MYY) = MXX+IFIX(SFXX*UU)
      MYF(XX,YY,UU,VV,SFXX,SFYY,MXX,MYY) = MYY+IFIX(SFYY*VV)
      SCALEX(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3,XX4,YY3,YY4,
     1       LENN) = LENN/HAA
      SCALEY(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3,XX4,YY3,YY4,
     1       LENN) = SCALEX(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3,
     2                                                 XX4,YY3,YY4,LENN)
      VLAB(UU,VV,II,JJ) = DIST(UU,VV)
C
C FORCE THE BLOCK DATA ROUTINE, WHICH SETS DEFAULT VARIABLES, TO LOAD.
C +NOAO - blockdata replaced with run time initialization.
C
C     EXTERNAL        VELDAT
      call veldat
C -NOAO
C
C ---------------------------------------------------------------------
C
C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR.
C
      CALL Q8QST4 ('NSSL','VELVCT','VELVCT','VERSION  6')
C
C INITIALIZE AND TRANSFER SOME ARGUMENTS TO LOCAL VARIABLES.
C
      BIG = -R1MACH(2)
      MX = LU
      MY = LV
      NX = M
      NY = N
      GL = FLO
      HA = HI
      ISP = ISPV
      NC = 0
C
C COMPUTE CONSTANTS BASED ON THE ADDRESSABILITY OF THE PLOTTER.
C
      CALL GETUSV('XF',ISX)
      CALL GETUSV('YF',ISY)
      ISX = 2**(15-ISX)
      ISY = 2**(15-ISY)
      LEN = LENGTH*ISX
C
C SET UP THE SCALING OF THE PLOT.
C
        CALL GQCNTN(IERR,IOLDNT)
        CALL GQNT(IOLDNT,IERR,WIND,VIEW)
        X1 = VIEW(1)
        X2 = VIEW(2)
        Y1 = VIEW(3)
        Y2 = VIEW(4)
        X3 = WIND(1)
        X4 = WIND(2)
        Y3 = WIND(3)
        Y4 = WIND(4)
        CALL GETUSV('LS',IOLLS)
C
C     SAVE NORMALIZATION TRANSFORMATION 1
C
      CALL GQNT(1,IERR,WIND,VIEW)
C
      IF (NSET) 101,102,106
C
  101 X3 = 1.
      X4 = FLOAT(NX)
      Y3 = 1.
      Y4 = FLOAT(NY)
      GO TO 105
C
  102 X1 = XLT
      X2 = XLT+SIDE
      Y1 = YBT
      Y2 = YBT+SIDE
      X3 = 1.
      Y3 = 1.
      X4 = FLOAT(NX)
      Y4 = FLOAT(NY)
      IF (AMIN1(X4,Y4)/AMAX1(X4,Y4) .LT. EXT) GO TO 105
C
      IF (NX-NY) 103,105,104
  103 X2 = XLT+SIDE*X4/Y4
      GO TO 105
  104 Y2 = YBT+SIDE*Y4/X4
C
  105 CALL SET(X1,X2,Y1,Y2,X3,X4,Y3,Y4,1)
      IF (NSET .EQ. 0) CALL PERIM (1,0,1,0)
C
C CALCULATE A LENGTH IF NONE PROVIDED.
C
  106 IF (LEN .NE. 0) GO TO 107
      CALL FL2INT(FX(1.,1.),FY(1.,1.),MX,MY)
      CALL FL2INT(FX(FLOAT(1+INCX),FLOAT(1+INCY)),
     +            FY(FLOAT(1+INCX),FLOAT(1+INCY)),LX,LY)
      LEN = SQRT((FLOAT(MX-LX)**2+FLOAT(MY-LY)**2)/2.)
C
C SET UP SPECIAL VALUES.
C
  107 IF (ISP .EQ. 0) GO TO 108
      SPV1 = SPV(1)
      SPV2 = SPV(2)
      IF (ISP .EQ. 4) SPV2 = SPV(1)
C
C FIND THE MAXIMUM VECTOR LENGTH.
C
  108 IF (HA .GT. 0.) GO TO 118
C
      HA = BIG
      IF (ISP .EQ. 0) GO TO 115
C
      DO 114 J=1,NY,INCY
         DO 113 I=1,NX,INCX
            IF (ISP-2) 109,111,110
  109       IF (U(I,J) .EQ. SPV1) GO TO 113
            GO TO 112
  110       IF (U(I,J) .EQ. SPV1) GO TO 113
  111       IF (V(I,J) .EQ. SPV2) GO TO 113
  112       HA = AMAX1(HA,DIST(U(I,J),V(I,J)))
  113    CONTINUE
  114 CONTINUE
      GO TO 126
C
  115 DO 117 J=1,NY,INCY
         DO 116 I=1,NX,INCX
            HA = AMAX1(HA,DIST(U(I,J),V(I,J)))
  116    CONTINUE
  117 CONTINUE
C
C BRANCH IF NULL VECTOR SIZE.
C
  126 IF (HA .LE. 0.) GO TO 125
C
C COMPUTE SCALE FACTORS.
C
  118 SFX = SCALEX(M,N,INCX,INCY,HA,X1,X2,Y1,Y2,X3,X4,Y3,Y4,LEN)
      SFY = SCALEY(M,N,INCX,INCY,HA,X1,X2,Y1,Y2,X3,X4,Y3,Y4,LEN)
      IOFFDT = IOFFD
      IF (GL.NE.0.0 .AND. (ABS(GL).LT.0.1 .OR. ABS(GL).GE.1.E5))
     1    IOFFDT = 1
      IF (HA.NE.0.0 .AND. (ABS(HA).LT.0.1 .OR. ABS(HA).GE.1.E5))
     1    IOFFDT = 1
      ASH = 1.0
      IF (IOFFDT .NE. 0)
     1    ASH = 10.**(3-IFIX(ALOG10(AMAX1(ABS(GL),ABS(HA)))-500.)-500)
      IZFLG = 0
C
C COMPUTE ZMN AND ZMX, WHICH ARE USED IN DRWVEC.
C
      ZMN = LEN*(GL/HA)
      ZMX = FLOAT(LEN)+.01
C
C DRAW THE VECTORS.
C
      DO 123 J=1,NY,INCY
         DO 122 I=1,NX,INCX
            UI = U(I,J)
            VI = V(I,J)
            IF (ISP-1) 121,119,120
  119       IF (UI-SPV1) 121,122,121
  120       IF (VI .EQ. SPV2) GO TO 122
            IF (ISP .GE. 3) GO TO 119
  121       X = I
            Y = J
            CALL FL2INT(FX(X,Y),FY(X,Y),MX,MY)
            LX = MAX0(1,MXF(X,Y,UI,VI,SFX,SFY,MX,MY))
            LY = MAX0(1,MYF(X,Y,UI,VI,SFX,SFY,MX,MY))
            IZFLG = 1
            IF (ILAB .NE. 0) CALL ENCD(VLAB(UI,VI,I,J),ASH,LABEL,NC,
     +                                                           IOFFDT)
            CALL DRWVEC (MX,MY,LX,LY,LABEL,NC)
  122    CONTINUE
  123 CONTINUE
C
      IF (IZFLG .EQ. 0) GO TO 125
C
      IF (IOFFM .NE. 0) GO TO 200
C +NOAO - FTN internal write replaced with call to encode
C     WRITE(LABEL,'(E10.3)')HA
      call encode (10, '(e10.3)', label, ha)
C -NOAO
C
C     TURN OFF CLIPPING SO ARROW CAN BE DRAWN
C
      CALL GQCLIP(IER,ICLP,IAR)
      CALL GSCLIP(0)
      CALL DRWVEC (28768,608,28768+LEN,608,LABEL,10)
C
C     RESTORE CLIPPING
C
      CALL GSCLIP(ICLP)
        IX = 1+(28768+LEN/2)/ISX
        IY = 1+(608-(5*ISX*MAX0(256/ISX,8))/4)/ISY
        CALL GQCNTN(IER,ICN)
        CALL GSELNT(0)
        XC = CPUX(IX)
        YC = CPUY(IY)
      CALL WTSTR (XC,YC,
     +                         'MAXIMUM VECTOR',MAX0(256/ISX,8),0,0)
      CALL GSELNT(ICN)
C
C DONE.
C
      GOTO 200
C
C ZERO-FIELD ACTION.
C
  125 IX = 1+16384/ISX
        IY = 1+16384/ISY
        CALL GQCNTN(IER,ICN)
        CALL GSELNT(0)
        XC = CPUX(IX)
        YC = CPUY(IY)
      CALL WTSTR (XC,YC,
     +                             'ZERO FIELD',MAX0(960/ISX,8),0,0)
        CALL GSELNT(ICN)
C
C RESTORE TRANS 1 AND LOG SCALING AND ORIGINAL TRANS NUMBER
C
  200 CONTINUE
      IF (NSET .LE. 0) THEN
        CALL SET(VIEW(1),VIEW(2),VIEW(3),VIEW(4),
     -           WIND(1),WIND(2),WIND(3),WIND(4),IOLLS)
      ENDIF
      CALL GSELNT(IOLDNT)
      RETURN
      END
      SUBROUTINE EZVEC (U,V,M,N)
C
C THIS SUBROUTINE IS FOR THE USER WHO WANTS A QUICK-AND-DIRTY VECTOR
C PLOT WITH DEFAULT VALUES FOR MOST OF THE ARGUMENTS.
C
        SAVE
C
      DIMENSION       U(M,N)     ,V(M,N)     ,SPVAL(2)
C
      DATA FLO,HI,NSET,LENGTH,ISPV,SPVAL(1),SPVAL(2) /
     +      0.,0.,   0,     0,   0,      0.,      0. /
C
C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR.
C
      CALL Q8QST4 ('CRAYLIB','VELVCT','EZVEC','VERSION  6')
C
      CALL VELVCT (U,M,V,M,M,N,FLO,HI,NSET,LENGTH,ISPV,SPVAL)
C +NOAO - call to frame is suppressed.
C     CALL FRAME
C -NOAO
      RETURN
      END
      SUBROUTINE DRWVEC (M1,M2,M3,M4,LABEL,NC)
C
C THIS ROUTINE IS CALLED TO DRAW A SINGLE ARROW.  IT HAS ARGUMENTS AS
C FOLLOWS -
C
C     (M1,M2)  -  COORDINATE OF ARROW BASE, ON A 2**15 X 2**15 GRID.
C     (M3,M4)  -  COORDINATE OF ARROW HEAD, ON A 2**15 X 2**15 GRID.
C     LABEL    -  CHARACTER LABEL TO BE PUT ABOVE ARROW.
C     NC       -  NUMBER OF CHARACTERS IN LABEL.
C
        SAVE
C
C
      COMMON /VEC1/   ASH        ,EXT        ,ICTRFG     ,ILAB       ,
     +                IOFFD      ,IOFFM      ,ISX        ,ISY        ,
     +                RMN        ,RMX        ,SIDE       ,SIZE       ,
     +                XLT        ,YBT        ,ZMN        ,ZMX
        CHARACTER*10 LABEL
C
C SOME LOCAL PARAMETERS ARE THE FOLLOWING -
C
C     CL     -  ARROW HEAD LENGTH SCALE FACTOR - EACH SIDE OF THE ARROW
C               HEAD IS THIS LONG RELATIVE TO THE LENGTH OF THE ARROW
C     ST,CT  -  SIN AND COS OF THE ARROW HEAD ANGLE
C     PI     -  THE CONSTANT PI
C     TWOPI  -  TWO TIMES PI
C     OHOPI  -  ONE HALF OF PI
C     FHOPI  -  FIVE HALVES OF PI
C
      DATA    CL / .25 /
      DATA    ST / .382683432365090 /
      DATA    CT / .923879532511287 /
      DATA    PI / 3.14159265358979 /
      DATA TWOPI / 6.28318530717959 /
      DATA OHOPI / 1.57079632679489 /
      DATA FHOPI / 7.85398163397448 /
C
      DIST(X,Y) = SQRT(X*X+Y*Y)
C
C TRANSFER ARGUMENTS TO LOCAL VARIABLES AND COMPUTE THE VECTOR LENGTH.
C
      N1 = M1
      N2 = M2
      N3 = M3
      N4 = M4
      DX = N3-N1
      DY = N4-N2
      R = DIST(DX,DY)
C
C SORT OUT POSSIBLE CASES, DEPENDING ON VECTOR LENGTH.
C
      IF (R .LE. ZMN) RETURN
C
      IF (R .LE. ZMX) GO TO 101
C
C PLOT A POINT FOR VECTORS WHICH ARE TOO LONG.
C
      CALL PLOTIT (N1,N2,0)
      CALL PLOTIT (N1,N2,1)
      CALL PLOTIT (N1,N2,0)
      RETURN
C
C ADJUST THE COORDINATES OF THE VECTOR ENDPOINTS AS IMPLIED BY THE
C CENTERING OPTION.
C
  101 IF (ICTRFG) 102,103,104
C
  102 N3 = N1
      N4 = N2
      N1 = FLOAT(N1)-DX
      N2 = FLOAT(N2)-DY
      GO TO 104
C
  103 N1 = FLOAT(N1)-.5*DX
      N2 = FLOAT(N2)-.5*DY
      N3 = FLOAT(N3)-.5*DX
      N4 = FLOAT(N4)-.5*DY
C
C DETERMINE THE COORDINATES OF THE POINTS USED TO DRAW THE ARROWHEAD.
C
  104 C1 = CL
C
C SHORT ARROWS HAVE HEADS OF A FIXED MINIMUM SIZE.
C
      IF (R .LT. RMN) C1 = RMN*CL/R
C
C LONG ARROWS HAVE HEADS OF A FIXED MAXIMUM SIZE.
C
      IF (R .GT. RMX) C1 = RMX*CL/R
C
C COMPUTE THE COORDINATES OF THE HEAD.
C
      N5 = FLOAT(N3)-C1*(CT*DX-ST*DY)
      N6 = FLOAT(N4)-C1*(CT*DY+ST*DX)
      N7 = FLOAT(N3)-C1*(CT*DX+ST*DY)
      N8 = FLOAT(N4)-C1*(CT*DY-ST*DX)
C
C PLOT THE ARROW.
C
      CALL PLOTIT (N1,N2,0)
      CALL PLOTIT (N3,N4,1)
      CALL PLOTIT (N5,N6,0)
      CALL PLOTIT (N3,N4,1)
      CALL PLOTIT (N7,N8,1)
      CALL PLOTIT (0,0,0)
C
C IF REQUESTED, PUT THE VECTOR MAGNITUDE ABOVE THE ARROW.
C
      IF (NC .EQ. 0) RETURN
      PHI = ATAN2(DY,DX)
      IF (AMOD(PHI+FHOPI,TWOPI) .GT. PI) PHI = PHI+PI
      IX = 1+IFIX(.5*FLOAT(N1+N3)+1.25*
     +            FLOAT(ISX*MAX0(IFIX(SIZE)/ISX,8))*COS(PHI+OHOPI))/ISX
      IY = 1+IFIX(.5*FLOAT(N2+N4)+1.25*
     +            FLOAT(ISX*MAX0(IFIX(SIZE)/ISX,8))*SIN(PHI+OHOPI))/ISY
        CALL GQCNTN(IER,ICN)
        CALL GSELNT(0)
        XC = CPUX(IX)
        YC = CPUY(IY)
      CALL WTSTR(XC,YC,
     +           LABEL,MAX0(IFIX(SIZE)/ISX,8),
     +                                     IFIX(57.2957795130823*PHI),0)
        CALL GSELNT(ICN)
      RETURN
      END
      SUBROUTINE VELVEC (U,LU,V,LV,M,N,FLO,HI,NSET,ISPV,SPV)
C
C THIS ROUTINE SUPPORTS USERS OF THE OLD VERSION OF THIS PACKAGE.
C
      DIMENSION       U(LU,N)    ,V(LV,N)    ,SPV(2)
C
        SAVE
C
C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR.
C
      CALL Q8QST4 ('CRAYLIB','VELVCT','VELVEC','VERSION  4')
      CALL VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,0,ISPV,SPV)
      RETURN
      END
C
C REVISION HISTORY ----------------------------------------------------
C
C FEBRUARY, 1979   ADDED REVISION HISTORY
C                  MODIFIED CODE TO CONFORM TO FORTRAN 66 STANDARD
C
C JULY, 1979       FIXED HI VECTOR TRAP AND MESSAGE INDICATING
C                  MAXIMUM VECTOR PLOTTED.
C
C DECEMBER, 1979   CHANGED THE STATISTICS CALL FROM CRAYLIB TO NSSL
C
C MARCH, 1981      FIXED SOME FRINGE-CASE ERRORS, CHANGED THE CODE TO
C                  USE FL2INTT AND PLOTIT INSTEAD OF MXMY, FRSTPT, AND
C                  VECTOR, AND MADE THE ARROWHEADS NARROWER (45 DEGREES
C                  APART, RATHER THAN 60 DEGREES APART)
C
C FEBRUARY, 1984   PROVIDED A DIMENSION STATEMENT FOR A VARIABLE INTO
C                  WHICH A TEN-CHARACTER STRING WAS BEING ENCODED.  ON
C                  THE CRAY, WHEN THE ENCODE WAS DONE, A WORD FOLLOWING
C                  THE VARIABLE WAS CLOBBERED, BUT THIS APPARENTLY MADE
C                  NO DIFFERENCE.  ON AT LEAST ONE OTHER MACHINE, THE
C                  CODE BLEW UP.  (ERROR REPORTED BY GREG WOODS)
C
C JULY, 1984       CONVERTED TO FORTRAN77 AND GKS.
C
C ---------------------------------------------------------------------