text:
      subroutine zrbact(x1,x2,rc1,rc2,rc3,rc4,rc5,rc6,rc7,
     1 rc8,lp,arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,
     2 gamma,alpha,alpha1,alpha2,alpha3,alpha4,ar)
c
c **********************************************************
c *  njtj
c *    Routine brackets the root of the given function.
c *    Taken from Numerical Recipes page 245.
c *  njtj
c **********************************************************
c
c  njtj
c  ###  Cray conversions
c  ###    1)Comment out implicit double precision.
c  ###    2)Switch double precision parameter
c  ###      to single precision parameter statement.
c  ###  Cray conversions
c  njtj
c
      implicit double precision (a-h,o-z)
c
      parameter (factor=1.6D0,ntry=50)
Cray      parameter (factor=1.6,ntry=50)
c
      dimension r(jrc),rab(jrc),ar(jrc)
c
      call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp,
     1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x1,
     2 alpha,alpha1,alpha2,alpha3,alpha4,f1,ar)
      call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp,
     1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x2,
     2 alpha,alpha1,alpha2,alpha3,alpha4,f2,ar)
c
      do 11 j=1,ntry
        if(f1*f2.lt.0.0)return
        if(abs(f1).lt.abs(f2))then
          x1=x1+factor*(x1-x2)
          call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp,
     1     arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x1,
     2     alpha,alpha1,alpha2,alpha3,alpha4,f1,ar)
        else
          x2=x2+factor*(x2-x1)
          call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp,
     1     arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x2,
     2     alpha,alpha1,alpha2,alpha3,alpha4,f2,ar)
        endif
11    continue
c
c  failure, abort program
c
      write(6,1000)lp
      call ext(830+lp)
 1000 format(//,'error in zbractk - can not bracket orbital ',i2)
      return
      end

ext: f

max_stars_repo_name: qsnake/petot

max_issues_repo_name: qsnake/petot

max_forks_repo_name: qsnake/petot


text:
PURE FUNCTION func_mean(arr, dof) RESULT(ans)
    ! NOTE: See https://numpy.org/doc/stable/reference/generated/numpy.mean.html

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    INTEGER(kind = INT64), INTENT(in), OPTIONAL                                 :: dof
    REAL(kind = REAL64)                                                         :: ans
    REAL(kind = REAL64), DIMENSION(:), INTENT(in)                               :: arr

    ! Declare internal variables ...
    INTEGER(kind = INT64)                                                       :: n

    ! Find size of array ...
    n = SIZE(arr, kind = INT64)

    ! Calculate the mean ...
    IF(PRESENT(dof))THEN
        ans = SUM(arr) / REAL(n - dof, kind = REAL64)
    ELSE
        ans = SUM(arr) / REAL(n, kind = REAL64)
    END IF
END FUNCTION func_mean

max_stars_repo_name: Guymer/fortranlib

max_issues_repo_name: Guymer/fortranlib

max_forks_repo_name: Guymer/fortranlib


text:
Image(markblog.jpg, Blogger of Davis Wiki user Users/MarkKlebanov, 300, thumbnail) Blogger, owned by Google, is yet another web publishing (Blogging) service.  Competition includes LiveJournal and Xanga.  Blogger is notorious for being used by professors, scholars and political activists.

A benefit to those using Blogger as opposed to LiveJournal or Xanga is the ability to do extreme customizations.  There is little to no limitations to how a Blogger can look.  Anyone with great XML and CSS skills can turn a Blogger from a boring white page into something flashy and jumpy.

The downside to using Blogger is the lack of blogger users coming together through the service(found on LiveJournal in the form of Communities and on Xanga in the form of Blogrings).  Blogger users improvise with Blogrolls, a side column that allows bloggers to list other blogs they read.

Present on the pages of free Blogger users is a Blogger bar.  This Blogger bar is customizable in four colors to fit the skin of the Blog.  HTML and CSS codes have been developed that allow desparate Blogger users to hide the Blogger bar from their website, though its not usually recommended since the Blogger bar is the main source of Blogger revenue.  Premium paid users of Blogger do not have the Blogger bar.

Unlike Xanga and LiveJournal where the service name is followed by the username in web addresses, Blogger usernames are followed by BlogSpot instead of Blogger.  Before all the formerly premium services became free when Google bought Blogger, Blogspot designated the accounts of those who opted out of using the premium services.

Bloggers parent company, Google, also owns Picasa, a popular photo sort and collage program among amateur and professional photographers.

  Create a blog at http://blogger.com Blogger
  Alpha Epsilon Pi has a http://alphaepsilonpi.blogspot.com blog at Blogger. Run By Mark Klebanov
  Several Davis Wiki users have a Blogger.  Do a search for BlogSpot instead of Blogger to find users who have one.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
module meta_data_interface
    use icar_constants

    implicit none

    private
    public :: meta_data_t
    public :: attribute_t

    type attribute_t
        character(len=kMAX_NAME_LENGTH) :: name
        character(len=kMAX_ATTR_LENGTH) :: value
    end type

    type meta_data_t
    !   private
        character(len=kMAX_NAME_LENGTH) :: name
        integer :: n_attrs = 0

        type(attribute_t), allocatable :: attributes(:)
    contains

        procedure, public  :: add_attribute
        ! procedure, public  :: get_attribute
    end type

    interface

        module subroutine add_attribute(this, input_name, input_value)
            implicit none
            class(meta_data_t), intent(inout) :: this
            character(len=*),   intent(in)    :: input_name
            character(len=*),   intent(in)    :: input_value
        end subroutine

        ! module subroutine get_attribute(this, name, value)
        !     implicit none
        !     class(output_t),   intent(inout)  :: this
        !     character(len=kMAX_ATTR_LENGTH), intent(in) :: name
        !     character(len=kMAX_ATTR_LENGTH), intent(value) :: value
        ! end subroutine

    end interface
end module

max_stars_repo_name: scrasmussen/icar

max_issues_repo_name: scrasmussen/icar

max_forks_repo_name: scrasmussen/icar


text:
C    Copyright(C) 2014-2017 National Technology & Engineering Solutions of
C    Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C    * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C    * Redistributions in binary form must reproduce the above
C      copyright notice, this list of conditions and the following
C      disclaimer in the documentation and/or other materials provided
C      with the distribution.
C
C    * Neither the name of NTESS nor the names of its
C      contributors may be used to endorse or promote products derived
C      from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C $Id: close6.f,v 1.2 1998/07/14 18:18:31 gdsjaar Exp $
C $Log: close6.f,v $
C Revision 1.2  1998/07/14 18:18:31  gdsjaar
C Removed unused variables, cleaned up a little.
C
C Changed BLUE labels to GREEN to help visibility on black background
C (indirectly requested by a couple users)
C
C Revision 1.1.1.1  1990/11/30 11:04:54  gdsjaar
C FASTQ Version 2.0X
C
c Revision 1.1  90/11/30  11:04:53  gdsjaar
c Initial revision
c
C
CC* FILE: [.PAVING]CLOSE6.FOR
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/6/90
CC* MODIFICATION: COMPLETED HEADER INFORMATION
C
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/31/90
CC* MODIFICATION: ADDED ARGUMENTS TO CALL TO CLOSE6 TO PASS MINIMUM
CC**              ELEMENT SIZE (SIZMIN) AND GETSIZ PARAMETERS OF
CC**              EMIN AND EMAX
C
      SUBROUTINE CLOSE6 (MXND, MXCORN, MLN, NUID, XN, YN, LXK, KXL, NXL,
     &   LXN, ANGLE, BNSIZE, LNODES, NODE, NLOOP, KKKOLD, LLLOLD,
     &   NNNOLD, NAVAIL, IAVAIL, DONE, XMIN, XMAX, YMIN, YMAX, DEV1,
     &   LLL, KKK, NNN, LCORN, NCORN, GRAPH, VIDEO, SIZEIT, NOROOM,
     &   ERR, XNOLD, YNOLD, NXKOLD, LINKEG, LISTEG, BMESUR, MLINK,
     &   NPNOLD, NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX,
     &   IDIVIS, SIZMIN, EMAX, EMIN)
C***********************************************************************
C
C  SUBROUTINE CLOSE6 = FINISHES UP A LOOP WITH ONLY 6 LINES IN THE LOOP
C
C***********************************************************************
C
      DIMENSION XN (MXND), YN (MXND), NUID (MXND)
      DIMENSION LXK (4, MXND), KXL (2, 3*MXND)
      DIMENSION NXL (2, 3*MXND), LXN (4, MXND)
      DIMENSION ANGLE (MXND), LNODES (MLN, MXND), BNSIZE (2, MXND)
      DIMENSION LCORN (MXCORN)
C
      DIMENSION XNOLD(NPNOLD), YNOLD(NPNOLD)
      DIMENSION NXKOLD(NNXK, NPEOLD)
      DIMENSION LINKEG(2, MLINK), LISTEG(4 * NPEOLD), BMESUR(NPNOLD)
C
      LOGICAL GRAPH, VIDEO, ERR, SIZEIT, NOROOM
C
      CHARACTER*3 DEV1
C
      ERR = .FALSE.
C
C  SET ALL THE LOOP NODES TO BE INTERIOR
C
      INODE = NODE
      IKOUNT = 0
  100 CONTINUE
      IKOUNT = IKOUNT + 1
      IF (IKOUNT .GT. 6) THEN
         CALL MESAGE ('** PROBLEMS IN CLOSE6 WITH TOO MANY IN LOOP **')
         ERR = .TRUE.
         GOTO 110
      ENDIF
C
      LNODES (4, INODE) = - 2
      CALL MARKSM (MXND, MLN, LXK, KXL, NXL, LXN, LNODES, INODE, ERR)
      IF (ERR) GOTO 110
C
      INODE = LNODES (3, INODE)
      IF (INODE .NE. NODE) GOTO 100
C
C  NOW GET THE CORRECT INTERPRETATION OF THE SHAPE
C
      CALL CNTCRN (MXND, MXCORN, MLN, LNODES, LCORN, NCORN, NLOOP,
     &   NODE, ERR)
      IF (ERR) GOTO 110
C
C  PROCESS A TRIANGLE SHAPE WITH VARIOUS INTERVAL COMBINATIONS
C
      IF (NCORN .EQ. 3) THEN
         I1 = LNODES (7, LCORN(1))
         I2 = LNODES (7, LCORN(2))
         I3 = LNODES (7, LCORN(3))
C
C  HANDLE A 4-1-1 TRIANGLE
C
         IF (MAX0 (I1, I2, I3) .EQ. 4) THEN
            IF (I1 .EQ. 4) THEN
               XNEW = ( ( (XN (LCORN (1)) + XN (LCORN (2)) ) * .5) +
     &            XN (LCORN (3)) ) * .5
               YNEW = ( ( (YN (LCORN (1)) + YN (LCORN (2)) ) * .5) +
     &            YN (LCORN (3)) ) * .5
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/31/90
CC* MODIFICATION: ADDED ARGUMENTS TO CALL TO ADD1CN TO PASS MINIMUM
CC**              ELEMENT SIZE (SIZMIN) AND GETSIZ PARAMETERS OF
CC**              EMIN AND EMAX
C
               CALL ADD1CN (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, BNSIZE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, XNEW, YNEW, LCORN(1), IAVAIL, NAVAIL,
     &            GRAPH, VIDEO, SIZEIT, NOROOM, ERR, XNOLD, YNOLD,
     &            NXKOLD, LINKEG, LISTEG, BMESUR, MLINK, NPNOLD,
     &            NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX,
     &            IDIVIS, SIZMIN, EMAX, EMIN)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ELSEIF (I2 .EQ. 4) THEN
               XNEW = ( ( (XN (LCORN (2)) + XN (LCORN (3)) ) * .5) +
     &            XN (LCORN (1)) ) * .5
               YNEW = ( ( (YN (LCORN (2)) + YN (LCORN (3)) ) * .5) +
     &            YN (LCORN (1)) ) * .5
               CALL ADD1CN (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, BNSIZE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, XNEW, YNEW, LCORN(2), IAVAIL, NAVAIL,
     &            GRAPH, VIDEO, SIZEIT, NOROOM, ERR, XNOLD, YNOLD,
     &            NXKOLD, LINKEG, LISTEG, BMESUR, MLINK, NPNOLD,
     &            NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX,
     &            IDIVIS, SIZMIN, EMAX, EMIN)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ELSE
               XNEW = ( ( (XN (LCORN (3)) + XN (LCORN (1)) ) * .5) +
     &            XN (LCORN (2)) ) * .5
               YNEW = ( ( (YN (LCORN (3)) + YN (LCORN (1)) ) * .5) +
     &            YN (LCORN (2)) ) * .5
               CALL ADD1CN (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, BNSIZE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, XNEW, YNEW, LCORN(3), IAVAIL, NAVAIL,
     &            GRAPH, VIDEO, SIZEIT, NOROOM, ERR, XNOLD, YNOLD,
     &            NXKOLD, LINKEG, LISTEG, BMESUR, MLINK, NPNOLD,
     &            NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX,
     &            IDIVIS, SIZMIN, EMAX, EMIN)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ENDIF
C
C  HANDLE A 3-2-1 TRIANGLE
C
         ELSEIF (MAX0 (I1, I2, I3) .EQ. 3) THEN
            IF (I1 .EQ. 1) THEN
               CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, LNODES (2, LCORN(1)),
     &            LNODES (3, LCORN(2)), IAVAIL, NAVAIL, GRAPH, VIDEO,
     &            NOROOM, ERR)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ELSEIF (I2 .EQ. 1) THEN
               CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, LNODES (2, LCORN(2)),
     &            LNODES (3, LCORN(3)), IAVAIL, NAVAIL, GRAPH, VIDEO,
     &            NOROOM, ERR)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ELSE
               CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, LNODES (2, LCORN(3)),
     &            LNODES (3, LCORN(1)), IAVAIL, NAVAIL, GRAPH, VIDEO,
     &            NOROOM, ERR)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ENDIF
C
C  HANDLE A 2-2-2 TRIANGLE
C
         ELSE
            XNEW1 = ( ( (XN (LCORN (1)) + XN (LCORN (2)) ) * .5) +
     &         XN (LCORN (3)) ) * .5
            XNEW2 = ( ( (XN (LCORN (2)) + XN (LCORN (3)) ) * .5) +
     &         XN (LCORN (1)) ) * .5
            XNEW3 = ( ( (XN (LCORN (3)) + XN (LCORN (1)) ) * .5) +
     &         XN (LCORN (2)) ) * .5
C
            YNEW1 = ( ( (YN (LCORN (1)) + YN (LCORN (2)) ) * .5) +
     &         YN (LCORN (3)) ) * .5
            YNEW2 = ( ( (YN (LCORN (2)) + YN (LCORN (3)) ) * .5) +
     &         YN (LCORN (1)) ) * .5
            YNEW3 = ( ( (YN (LCORN (3)) + YN (LCORN (1)) ) * .5) +
     &         YN (LCORN (2)) ) * .5
C
            XNEW = (XNEW1 + XNEW2 + XNEW3) / 3.
            YNEW = (YNEW1 + YNEW2 + YNEW3) / 3.
            CALL ADD1CN (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &         ANGLE, BNSIZE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &         NLOOP, XNEW, YNEW, LCORN(1), IAVAIL, NAVAIL,
     &         GRAPH, VIDEO, SIZEIT, NOROOM, ERR, XNOLD, YNOLD, NXKOLD,
     &         LINKEG, LISTEG, BMESUR, MLINK, NPNOLD, NPEOLD, NNXK,
     &         REMESH, REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS, SIZMIN,
     &         EMAX, EMIN)
            IF ((NOROOM) .OR. (ERR)) GOTO 110
         ENDIF
C
C  PROCESS A RECTANGLE SHAPE WITH VARIOUS INTERVAL COMBINATIONS
C
      ELSEIF (NCORN .EQ. 4) THEN
         I1 = LNODES (7, LCORN(1))
         I2 = LNODES (7, LCORN(2))
         I3 = LNODES (7, LCORN(3))
         I4 = LNODES (7, LCORN(4))
C
C  HANDLE A 3-1-1-1 RECTANGLE
C
         IF (MAX0 (I1, I2, I3, I4) .EQ. 3) THEN
            IF (I1 .EQ. 3) THEN
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/31/90
CC* MODIFICATION: ADDED ARGUMENTS TO CALL TO ADD2CN TO PASS MINIMUM
CC**              ELEMENT SIZE (SIZMIN) AND GETSIZ PARAMETERS OF
CC**              EMIN AND EMAX
C
               CALL ADD2CN (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, BNSIZE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, LCORN(1), IAVAIL, NAVAIL, GRAPH, VIDEO,
     &            SIZEIT, NOROOM, ERR, XNOLD, YNOLD, NXKOLD, LINKEG,
     &            LISTEG, BMESUR, MLINK, NPNOLD, NPEOLD, NNXK, REMESH,
     &            REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS, SIZMIN, EMAX,
     &            EMIN)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ELSEIF (I2 .EQ. 3) THEN
               CALL ADD2CN (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, BNSIZE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, LCORN(2), IAVAIL, NAVAIL, GRAPH, VIDEO,
     &            SIZEIT, NOROOM, ERR, XNOLD, YNOLD, NXKOLD, LINKEG,
     &            LISTEG, BMESUR, MLINK, NPNOLD, NPEOLD, NNXK, REMESH,
     &            REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS, SIZMIN, EMAX,
     &            EMIN)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ELSEIF (I3 .EQ. 3) THEN
               CALL ADD2CN (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, BNSIZE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, LCORN(3), IAVAIL, NAVAIL, GRAPH, VIDEO,
     &            SIZEIT, NOROOM, ERR, XNOLD, YNOLD, NXKOLD, LINKEG,
     &            LISTEG, BMESUR, MLINK, NPNOLD, NPEOLD, NNXK, REMESH,
     &            REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS, SIZMIN, EMAX,
     &            EMIN)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ELSE
               CALL ADD2CN (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, BNSIZE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, LCORN(4), IAVAIL, NAVAIL, GRAPH, VIDEO,
     &            SIZEIT, NOROOM, ERR, XNOLD, YNOLD, NXKOLD, LINKEG,
     &            LISTEG, BMESUR, MLINK, NPNOLD, NPEOLD, NNXK, REMESH,
     &            REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS, SIZMIN, EMAX,
     &            EMIN)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ENDIF
C
C  HANDLE A 2-2-1-1 RECTANGLE
C
         ELSEIF (MAX0 ((I1+I2), (I2+I3), (I3+I4), (I4+I1)) .EQ. 4) THEN
            IF ( (I1+I2) .EQ. 4) THEN
               XNEW = ( XN (LNODES (3, LCORN(1))) +
     &            XN (LNODES (3, LCORN(2))) +
     &            ( XN (LCORN (3)) * .5) +
     &            XN (LCORN (4)) +
     &            ( XN (LCORN (1)) * .5) ) * .25
               YNEW = ( YN (LNODES (3, LCORN(1))) +
     &            YN (LNODES (3, LCORN(2))) +
     &            ( YN (LCORN (3)) * .5) +
     &            YN (LCORN (4)) +
     &            ( YN (LCORN (1)) * .5) ) * .25
               CALL ADD1CN (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, BNSIZE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, XNEW, YNEW, LCORN(1), IAVAIL, NAVAIL,
     &            GRAPH, VIDEO, SIZEIT, NOROOM, ERR, XNOLD, YNOLD,
     &            NXKOLD, LINKEG, LISTEG, BMESUR, MLINK, NPNOLD,
     &            NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX,
     &            IDIVIS, SIZMIN, EMAX, EMIN)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ELSEIF ( (I2+I3) .EQ. 4) THEN
               XNEW = ( XN (LNODES (3, LCORN(2))) +
     &            XN (LNODES (3, LCORN(3))) +
     &            ( XN (LCORN (4)) * .5) +
     &            XN (LCORN (1)) +
     &            ( XN (LCORN (2)) * .5) ) * .25
               YNEW = ( YN (LNODES (3, LCORN(2))) +
     &            YN (LNODES (3, LCORN(3))) +
     &            ( YN (LCORN (4)) * .5) +
     &            YN (LCORN (1)) +
     &            ( YN (LCORN (2)) * .5) ) * .25
               CALL ADD1CN (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, BNSIZE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, XNEW, YNEW, LCORN(2), IAVAIL, NAVAIL,
     &            GRAPH, VIDEO, SIZEIT, NOROOM, ERR, XNOLD, YNOLD,
     &            NXKOLD, LINKEG, LISTEG, BMESUR, MLINK, NPNOLD,
     &            NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX,
     &            IDIVIS, SIZMIN, EMAX, EMIN)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ELSEIF ( (I3+I4) .EQ. 4) THEN
               XNEW = ( XN (LNODES (3, LCORN(3))) +
     &            XN (LNODES (3, LCORN(4))) +
     &            ( XN (LCORN (1)) * .5) +
     &            XN (LCORN (2)) +
     &            ( XN (LCORN (3)) * .5) ) * .25
               YNEW = ( YN (LNODES (3, LCORN(3))) +
     &            YN (LNODES (3, LCORN(4))) +
     &            ( YN (LCORN (1)) * .5) +
     &            YN (LCORN (2)) +
     &            ( YN (LCORN (3)) * .5) ) * .25
               CALL ADD1CN (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, BNSIZE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, XNEW, YNEW, LCORN(3), IAVAIL, NAVAIL,
     &            GRAPH, VIDEO, SIZEIT, NOROOM, ERR, XNOLD, YNOLD,
     &            NXKOLD, LINKEG, LISTEG, BMESUR, MLINK, NPNOLD,
     &            NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX,
     &            IDIVIS, SIZMIN, EMAX, EMIN)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ELSE
               XNEW = ( XN (LNODES (3, LCORN(4))) +
     &            XN (LNODES (3, LCORN(1))) +
     &            ( XN (LCORN (2)) * .5) +
     &            XN (LCORN (3)) +
     &            ( XN (LCORN (4)) * .5) ) * .25
               YNEW = ( YN (LNODES (3, LCORN(4))) +
     &            YN (LNODES (3, LCORN(1))) +
     &            ( YN (LCORN (2)) * .5) +
     &            YN (LCORN (3)) +
     &            ( YN (LCORN (4)) * .5) ) * .25
               CALL ADD1CN (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, BNSIZE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, XNEW, YNEW, LCORN(4), IAVAIL, NAVAIL,
     &            GRAPH, VIDEO, SIZEIT, NOROOM, ERR, XNOLD, YNOLD,
     &            NXKOLD, LINKEG, LISTEG, BMESUR, MLINK, NPNOLD,
     &            NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX,
     &            IDIVIS, SIZMIN, EMAX, EMIN)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ENDIF
C
C  HANDLE A 2-1-2-1 RECTANGLE
C
         ELSE
            IF (I1 .EQ. 2) THEN
               CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, LNODES (3, LCORN(1)),
     &            LNODES (3, LCORN(3)), IAVAIL, NAVAIL,
     &            GRAPH, VIDEO, NOROOM, ERR)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ELSE
               CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, LNODES (3, LCORN(2)),
     &            LNODES (3, LCORN(4)), IAVAIL, NAVAIL,
     &            GRAPH, VIDEO, NOROOM, ERR)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ENDIF
         ENDIF
C
C  PROCESS A SEMICIRCLE SHAPE WITH VARIOUS INTERVAL COMBINATIONS
C
      ELSEIF (NCORN .EQ. 2) THEN
         I1 = LNODES (7, LCORN(1))
         I2 = LNODES (7, LCORN(2))
C
C  HANDLE A 5-1 SEMICIRCLE
C
         IF (MAX0 (I1, I2) .EQ. 5) THEN
            IF (I1 .EQ. 1) THEN
               CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, LNODES (2, LCORN(1)),
     &            LNODES (3, LCORN(2)), IAVAIL, NAVAIL,
     &            GRAPH, VIDEO, NOROOM, ERR)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ELSE
               CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, LNODES (2, LCORN(2)),
     &            LNODES (3, LCORN(1)), IAVAIL, NAVAIL,
     &            GRAPH, VIDEO, NOROOM, ERR)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ENDIF
C
C  HANDLE A 4-2 SEMICIRCLE
C
         ELSEIF (MAX0 (I1, I2) .EQ. 4) THEN
            IF (I1 .EQ. 2) THEN
               CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, LNODES (3, LCORN(1)),
     &            LNODES (3, LNODES (3, LCORN(2))), IAVAIL, NAVAIL,
     &            GRAPH, VIDEO, NOROOM, ERR)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ELSE
               CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &            ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &            NLOOP, LNODES (3, LCORN(2)),
     &            LNODES (3, LNODES (3, LCORN(1))), IAVAIL, NAVAIL,
     &            GRAPH, VIDEO, NOROOM, ERR)
               IF ((NOROOM) .OR. (ERR)) GOTO 110
            ENDIF
C
C  HANDLE A 3-3 SEMICIRCLE
C
         ELSE
            CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &         ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &         NLOOP, LNODES (3, LCORN(1)),
     &         LNODES (3, LCORN(2)), IAVAIL, NAVAIL,
     &         GRAPH, VIDEO, NOROOM, ERR)
            IF ((NOROOM) .OR. (ERR)) GOTO 110
C            CALL ADD2CN (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
C     &         ANGLE, BNSIZE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
C     &         NLOOP, LCORN(1), IAVAIL, NAVAIL, GRAPH, VIDEO, SIZEIT,
C     &            NOROOM, ERR, XNOLD, YNOLD, NXKOLD, LINKEG, LISTEG,
C     &            BMESUR, MLINK, NPNOLD, NPEOLD, NNXK, REMESH, REXMIN,
C     &            REXMAX, REYMIN, REYMAX, IDIVIS, SIZMIN, EMAX, EMIN)
C            IF ((NOROOM) .OR. (ERR)) GOTO 110
         ENDIF
C
C  PROCESS A TEAR-DROP SHAPE (1 CORNER)
C
      ELSEIF (NCORN .EQ. 1) THEN
         CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &      ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &      NLOOP, LNODES (3, LCORN(1)),
     &      LNODES (2, LNODES (2, LCORN(1))), IAVAIL, NAVAIL,
     &      GRAPH, VIDEO, NOROOM, ERR)
         IF ((NOROOM) .OR. (ERR)) GOTO 110
C
C  PROCESS A TRUE CIRCLE (OR ANYTHING ELSE FOR THAT MATTER)
C
      ELSE
         I1 = NODE
         I2 = LNODES (3, NODE)
         I3 = LNODES (3, LNODES (3, NODE))
         I4 = LNODES (3, LNODES (3, LNODES (3, NODE)))
         I5 = LNODES (2, LNODES (2, NODE))
         I6 = LNODES (2, NODE)
C
         DIST1 = SQRT ( ((XN (I1) - XN (I4)) ** 2) +
     &      ((YN (I1) - YN (I4)) ** 2) )
         DIST2 = SQRT ( ((XN (I2) - XN (I5)) ** 2) +
     &      ((YN (I2) - YN (I5)) ** 2) )
         DIST3 = SQRT ( ((XN (I3) - XN (I6)) ** 2) +
     &      ((YN (I3) - YN (I6)) ** 2) )
C
         IF ( (DIST1 .LE. DIST2) .AND. (DIST1 .LE. DIST3) ) THEN
            CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &         ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &         NLOOP, I1, I4, IAVAIL, NAVAIL, GRAPH, VIDEO,
     &         NOROOM, ERR)
            IF ((NOROOM) .OR. (ERR)) GOTO 110
         ELSEIF ( (DIST2 .LE. DIST3) .AND. (DIST2 .LE. DIST1) ) THEN
            CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &         ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &         NLOOP, I2, I5, IAVAIL, NAVAIL, GRAPH, VIDEO,
     &         NOROOM, ERR)
            IF ((NOROOM) .OR. (ERR)) GOTO 110
         ELSE
            CALL ADD2EL (MXND, MLN, XN, YN, NUID, LXK, KXL, NXL, LXN,
     &         ANGLE, LNODES, NNN, KKK, LLL, NNNOLD, LLLOLD,
     &         NLOOP, I3, I6, IAVAIL, NAVAIL, GRAPH, VIDEO,
     &         NOROOM, ERR)
            IF ((NOROOM) .OR. (ERR)) GOTO 110
         ENDIF
      ENDIF
C
  110 CONTINUE
C
      RETURN
C
      END

max_stars_repo_name: brian-kelley/seacas

max_issues_repo_name: brian-kelley/seacas

max_forks_repo_name: brian-kelley/seacas


submodule(euler_interface_m) euler_prob_0052_m
    implicit none

contains

    module character(len=20) function euler0052()
        write (euler0052, "(i20)") ans()
    end function euler0052

    integer function ans()
        integer :: i, j
        logical, dimension(0:9) :: arr, arr_tmp

        i = 1
        outer: do
            call digs_used_in_num(i, arr)

            inner: do j = 2, 6
                call digs_used_in_num(i*j, arr_tmp)

                if (all(arr .eqv. arr_tmp)) then
                    if (j == 6) exit outer
                else
                    exit inner
                end if
            end do inner

            i = i + 1
        end do outer

        ans = i
    end function ans

    subroutine digs_used_in_num(n, arr)
        integer, intent(in) :: n
        logical, intent(out) :: arr(0:9)
        integer, allocatable :: int_arr(:)
        integer :: i

        call int_2_arr(n, int_arr)
        arr = .false.

        do i = 1, digs_of_int(n)
            arr(int_arr(i)) = .true.
        end do
    end subroutine digs_used_in_num

end submodule euler_prob_0052_m


text:
!~ ============================================
program InterAtomshopping
!~ ============================================
	use moduleone
	use moduletwo
	implicit real (kind=DP) (a-h, o-z)

	integer (kind=4) :: Tswitch

	real (kind=DP) :: Delta0, Delta1, Delta2, DeltaP, DeltaZ
	real (kind=DP) :: V_pd_sigma, V_pd_pi, V_dd_sigma, V_dd_pi, V_dd_delta, V_pp_sigma, V_pp_pi
	real (kind=DP) :: V_pp_sigma_interlayer,   V_pp_pi_interlayer,   SOC_dd,  SOC_pp
	real (kind=DP) :: Vx, Vy, Vz, Vn, a, Vx2, Vy2, Vz2

	real (kind=DP) :: tdp(1:3,1:5,1:6),  tdd(1:5,1:5,1:6),  tpp(1:3,1:3,1:10)

	Tswitch=1
	a1=avalue
	tdp(1:3, 1:5, 1:6) = 0.d0
	tdd(1:5, 1:5, 1:6) = 0.d0
	tpp(1:3, 1:3, 1:10) = 0.d0

	!~ ================================
	!	MoS2
	if (Tswitch==1) then
		Delta0=Delta0_MoS2
		Delta1=Delta1_MoS2
		Delta2=Delta2_MoS2
		DeltaP=DeltaP_MoS2
		DeltaZ=DeltaZ_MoS2
		V_pd_sigma=V_pd_sigma_MoS2
		V_pd_pi=V_pd_pi_MoS2
		V_dd_sigma=V_dd_sigma_MoS2
		V_dd_pi=V_dd_pi_MoS2
		V_dd_delta=V_dd_delta_MoS2
		V_pp_sigma=V_pp_sigma_MoS2
		V_pp_pi=V_pp_pi_MoS2
		V_pp_sigma_interlayer=V_pp_sigma_interlayer_MoS2
		V_pp_pi_interlayer=V_pp_pi_interlayer_MoS2
		SOC_dd=SOC_dd_MoS2
		SOC_pp=SOC_pp_MoS2
	!	WS2
	else if (Tswitch==2) then
		Delta0=Delta0_WS2
		Delta1=Delta1_WS2
		Delta2=Delta2_WS2
		DeltaP=DeltaP_WS2
		DeltaZ=DeltaZ_WS2
		V_pd_sigma=V_pd_sigma_WS2
		V_pd_pi=V_pd_pi_WS2
		V_dd_sigma=V_dd_sigma_WS2
		V_dd_pi=V_dd_pi_WS2
		V_dd_delta=V_dd_delta_WS2
		V_pp_sigma=V_pp_sigma_WS2
		V_pp_pi=V_pp_pi_WS2
		V_pp_sigma_interlayer=V_pp_sigma_interlayer_WS2
		V_pp_pi_interlayer=V_pp_pi_interlayer_WS2
		SOC_dd=SOC_dd_WS2
		SOC_pp=SOC_pp_WS2
	!	MoSe2
	else if (Tswitch==3) then
		Delta0=Delta0_MoSe2
		Delta1=Delta1_MoSe2
		Delta2=Delta2_MoSe2
		DeltaP=DeltaP_MoSe2
		DeltaZ=DeltaZ_MoSe2
		V_pd_sigma=V_pd_sigma_MoSe2
		V_pd_pi=V_pd_pi_MoSe2
		V_dd_sigma=V_dd_sigma_MoSe2
		V_dd_pi=V_dd_pi_MoSe2
		V_dd_delta=V_dd_delta_MoSe2
		V_pp_sigma=V_pp_sigma_MoSe2
		V_pp_pi=V_pp_pi_MoSe2
		V_pp_sigma_interlayer=V_pp_sigma_interlayer_MoSe2
		V_pp_pi_interlayer=V_pp_pi_interlayer_MoSe2
		SOC_dd=SOC_dd_MoSe2
		SOC_pp=SOC_pp_MoSe2
	!	WSe2
	else if (Tswitch==4) then
		Delta0=Delta0_WSe2
		Delta1=Delta1_WSe2
		Delta2=Delta2_WSe2
		DeltaP=DeltaP_WSe2
		DeltaZ=DeltaZ_WSe2
		V_pd_sigma=V_pd_sigma_WSe2
		V_pd_pi=V_pd_pi_WSe2
		V_dd_sigma=V_dd_sigma_WSe2
		V_dd_pi=V_dd_pi_WSe2
		V_dd_delta=V_dd_delta_WSe2
		V_pp_sigma=V_pp_sigma_WSe2
		V_pp_pi=V_pp_pi_WSe2
		V_pp_sigma_interlayer=V_pp_sigma_interlayer_WSe2
		V_pp_pi_interlayer=V_pp_pi_interlayer_WSe2
		SOC_dd=SOC_dd_WSe2
		SOC_pp=SOC_pp_WSe2
	end if

!=============================================================

!	Nearest Hoping
!~ W-S
!~ W-Se
!~ M0-S

		    !~ Mo
		 !~ 1(Beta)
              !~ S  Top
!~ 3 (Alpha)      2(Gamma)

	!~ =============================================
	!~                                  PD            V-Beta Stop
	!~ =============================================

	Vx=  0.d0  ;       Vy=   1.d0/sq3*a1   ;      Vz= -0.5d0*a1

	call	 PD_Bonds_Family( Tswitch, Vx, Vy, Vz, &
			& E_x_xy,  E_x_yz,  E_x_xz,  E_x_x2y2, E_x_z2, &
			& E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2, &
			& E_z_xy,  E_z_yz ,  E_z_xz,  E_z_x2y2 , E_z_z2)

	!~ =============================================

	a=sqrt(1./7)/7.d0
!	beta
	tdp(1,1,1)=14*a*V_pd_pi
	tdp(1,2,1)=0.
	tdp(1,3,1)=-7*a*sqrt(3.)*V_pd_pi
	tdp(1,4,1)=0.
	tdp(1,5,1)=0.

	tdp(2,1,1)=0.
	tdp(2,2,1)=-sqrt(3.)*a*(4*sqrt(3.)*V_pd_sigma-V_pd_pi )
	tdp(2,3,1)=0.
	tdp(2,4,1)=-1*a*(4*sqrt(3.)*V_pd_sigma+6*V_pd_pi )
	tdp(2,5,1)=2*a*(V_pd_sigma- 3*sqrt(3.)*V_pd_pi )

	tdp(3,1,1)=0.
	tdp(3,2,1)=2*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	tdp(3,3,1)=0.
	tdp(3,4,1)=2*a*(3*V_pd_sigma-2*sqrt(3.)*V_pd_pi )
	tdp(3,5,1)=-sqrt(3.)*a*(V_pd_sigma+ 4*sqrt(3.)*V_pd_pi )

	print*,''
	print*, E_x_xy, E_x_yz, E_x_xz, E_x_x2y2, E_x_z2
	print*,''
	print*, tdp(1, 1:5, 1)

	print*,''
	print*, E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2
	print*,''
	print*, tdp(2, 1:5, 1)

	print*,''
	print*, E_z_xy,  E_z_yz , E_z_xz , E_z_x2y2 , E_z_z2
	print*,''
	print*, tdp(3, 1:5, 1)

	!~ =============================================
	!~                                  PD            V-Gamma Stop
	!~ =============================================

	Vx=  0.5d0*a1  ;       Vy=   -0.5d0/sq3*a1   ;      Vz= -0.5d0*a1

	call	 PD_Bonds_Family( Tswitch, Vx, Vy, Vz, &
			& E_x_xy,  E_x_yz,  E_x_xz,  E_x_x2y2, E_x_z2, &
			& E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2, &
			& E_z_xy,  E_z_yz ,  E_z_xz,  E_z_x2y2 , E_z_z2)

	!~ =============================================

!	gamma
	tdp(1,1,2)=-1*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	tdp(1,2,2)=3*a*(sqrt(3.)*V_pd_sigma -2*V_pd_pi )
	tdp(1,3,2)=-sqrt(3.)*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	tdp(1,4,2)=sqrt(3.)*a*(sqrt(3.)*V_pd_sigma+5*V_pd_pi )
	tdp(1,5,2)=sqrt(3.)*a*(V_pd_sigma-3*sqrt(3.)*V_pd_pi )

	tdp(2,1,2)=sqrt(3.)*a*(sqrt(3.)*V_pd_sigma+5*V_pd_pi )
	tdp(2,2,2)=-sqrt(3.)*a*(sqrt(3.)*V_pd_sigma+5*V_pd_pi )
	tdp(2,3,2)=3*a*(sqrt(3.)*V_pd_sigma -2*V_pd_pi )
	tdp(2,4,2)=-sqrt(3.)*a*(V_pd_sigma-3*sqrt(3.)*V_pd_pi )
	tdp(2,5,2)=-1*a*(V_pd_sigma-3*sqrt(3.)*V_pd_pi )

	tdp(3,1,2)=3*a*(sqrt(3.)*V_pd_sigma- 2*V_pd_pi )
	tdp(3,2,2)=-1*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	tdp(3,3,2)=sqrt(3.)*a*(3*sqrt(3.)*V_pd_sigma +V_pd_pi )
	tdp(3,4,2)=-a*(3*V_pd_sigma-2*sqrt(3.)*V_pd_pi )
	tdp(3,5,2)=-sqrt(3.)*a*(V_pd_sigma+4*sqrt(3.)*V_pd_pi )

	print*,''
	print*, E_x_xy, E_x_yz, E_x_xz, E_x_x2y2, E_x_z2
	print*,''
	print*, tdp(1, 1:5, 2)

	print*,''
	print*, E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2
	print*,''
	print*, tdp(2, 1:5, 2)

	print*,''
	print*, E_z_xy,  E_z_yz , E_z_xz , E_z_x2y2 , E_z_z2
	print*,''
	print*, tdp(3, 1:5, 2)

	!~ =============================================
	!~                                  PD            V-alpha Stop
	!~ =============================================

	Vx=  -0.5d0*a1  ;       Vy=   -0.5d0/sq3*a1   ;      Vz= -0.5d0*a1

	call	 PD_Bonds_Family( Tswitch, Vx, Vy, Vz, &
			& E_x_xy,  E_x_yz,  E_x_xz,  E_x_x2y2, E_x_z2, &
			& E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2, &
			& E_z_xy,  E_z_yz ,  E_z_xz,  E_z_x2y2 , E_z_z2)

	!~ =============================================

!	alpha
	tdp(1,1,3)=-1*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	tdp(1,2,3)=-3*a*(sqrt(3.)*V_pd_sigma -2*V_pd_pi )
	tdp(1,3,3)=-sqrt(3.)*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	tdp(1,4,3)=-sqrt(3.)*a*(sqrt(3.)*V_pd_sigma+5*V_pd_pi )
	tdp(1,5,3)=-sqrt(3.)*a*(V_pd_sigma-3*sqrt(3.)*V_pd_pi )

	tdp(2,1,3)=-sqrt(3.)*a*(sqrt(3.)*V_pd_sigma+5*V_pd_pi )
	tdp(2,2,3)=-sqrt(3.)*a*(sqrt(3.)*V_pd_sigma+5*V_pd_pi )
	tdp(2,3,3)=-3*a*(sqrt(3.)*V_pd_sigma -2*V_pd_pi )
	tdp(2,4,3)=-sqrt(3.)*a*(V_pd_sigma-3*sqrt(3.)*V_pd_pi )
	tdp(2,5,3)=-1*a*(V_pd_sigma-3*sqrt(3.)*V_pd_pi )

	tdp(3,1,3)=-3*a*(sqrt(3.)*V_pd_sigma- 2*V_pd_pi )
	tdp(3,2,3)=-1*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	tdp(3,3,3)=-sqrt(3.)*a*(3*sqrt(3.)*V_pd_sigma +V_pd_pi )
	tdp(3,4,3)=-a*(3*V_pd_sigma-2*sqrt(3.)*V_pd_pi )
	tdp(3,5,3)=-sqrt(3.)*a*(V_pd_sigma+4*sqrt(3.)*V_pd_pi )

	print*,''
	print*, E_x_xy, E_x_yz, E_x_xz, E_x_x2y2, E_x_z2
	print*,''
	print*, tdp(1, 1:5, 3)

	print*,''
	print*, E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2
	print*,''
	print*, tdp(2, 1:5, 3)

	print*,''
	print*, E_z_xy,  E_z_yz , E_z_xz , E_z_x2y2 , E_z_z2
	print*,''
	print*, tdp(3, 1:5, 3)

!!~ Bottom

!	Nearest Hoping
!~ W-S
!~ W-Se
!~ M0-S
!	Mo-Se	Bottom layer

		    !~ Mo
		 !~ 4(Beta)
              !~ S  Bottom
!~ 6 (Alpha)      5(Gamma)

	a=sqrt(1./7)/7
!	4beta
	tdp(1,1,4)=14*a*V_pd_pi
	tdp(1,2,4)=0.
	tdp(1,3,4)=7*a*sqrt(3.)*V_pd_pi
	tdp(1,4,4)=0.
	tdp(1,5,4)=0.

	tdp(2,1,4)=0.
	tdp(2,2,4)=sqrt(3.)*a*(4*sqrt(3.)*V_pd_sigma-V_pd_pi )
	tdp(2,3,4)=0.
	tdp(2,4,4)=-1*a*(4*sqrt(3.)*V_pd_sigma+6*V_pd_pi )
	tdp(2,5,4)=2*a*(V_pd_sigma- 3*sqrt(3.)*V_pd_pi )

	tdp(3,1,4)=0.
	tdp(3,2,4)=2*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	tdp(3,3,4)=0.
	tdp(3,4,4)=-2*a*(3*V_pd_sigma-2*sqrt(3.)*V_pd_pi )
	tdp(3,5,4)=sqrt(3.)*a*(V_pd_sigma+ 4*sqrt(3.)*V_pd_pi )

!	gamma
	tdp(1,1,5)=-1*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	tdp(1,2,5)=-3*a*(sqrt(3.)*V_pd_sigma -2*V_pd_pi )
	tdp(1,3,5)=sqrt(3.)*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	tdp(1,4,5)=sqrt(3.)*a*(sqrt(3.)*V_pd_sigma+5*V_pd_pi )
	tdp(1,5,5)=sqrt(3.)*a*(V_pd_sigma-3*sqrt(3.)*V_pd_pi )

	tdp(2,1,5)=sqrt(3.)*a*(sqrt(3.)*V_pd_sigma+5*V_pd_pi )
	tdp(2,2,5)=sqrt(3.)*a*(sqrt(3.)*V_pd_sigma+5*V_pd_pi )
	tdp(2,3,5)=-3*a*(sqrt(3.)*V_pd_sigma -2*V_pd_pi )
	tdp(2,4,5)=-sqrt(3.)*a*(V_pd_sigma-3*sqrt(3.)*V_pd_pi )
	tdp(2,5,5)=-1*a*(V_pd_sigma-3*sqrt(3.)*V_pd_pi )

	tdp(3,1,5)=-3*a*(sqrt(3.)*V_pd_sigma- 2*V_pd_pi )
	tdp(3,2,5)=-1*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	tdp(3,3,5)=sqrt(3.)*a*(3*sqrt(3.)*V_pd_sigma +V_pd_pi )
	tdp(3,4,5)=a*(3*V_pd_sigma-2*sqrt(3.)*V_pd_pi )
	tdp(3,5,5)=sqrt(3.)*a*(V_pd_sigma+4*sqrt(3.)*V_pd_pi )

!	alpha
	!~ tdp(1,1,6)=-1*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	!~ tdp(1,2,6)=3*a*(sqrt(3.)*V_pd_sigma -2*V_pd_pi )
	!~ tdp(1,3,6)=sqrt(3.)*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	!~ tdp(1,4,6)=-sqrt(3.)*a*(sqrt(3.)*V_pd_sigma+5*V_pd_pi )
	!~ tdp(1,5,6)=-sqrt(3.)*a*(V_pd_sigma-3*sqrt(3.)*V_pd_pi )

	!~ tdp(2,1,6)=-sqrt(3.)*a*(sqrt(3.)*V_pd_sigma+5*V_pd_pi )
	!~ tdp(2,2,6)=sqrt(3.)*a*(sqrt(3.)*V_pd_sigma+5*V_pd_pi )
	!~ tdp(2,3,6)=3*a*(sqrt(3.)*V_pd_sigma -2*V_pd_pi )
	!~ tdp(2,4,6)=-sqrt(3.)*a*(V_pd_sigma-3*sqrt(3.)*V_pd_pi )
	!~ tdp(2,5,6)=-1*a*(V_pd_sigma-3*sqrt(3.)*V_pd_pi )

	!~ tdp(3,1,6)=3*a*(sqrt(3.)*V_pd_sigma- 2*V_pd_pi )
	!~ tdp(3,2,6)=-1*a*(3*sqrt(3.)*V_pd_sigma+V_pd_pi )
	!~ tdp(3,3,6)=-sqrt(3.)*a*(3*sqrt(3.)*V_pd_sigma +V_pd_pi )
	!~ tdp(3,4,6)=a*(3*V_pd_sigma-2*sqrt(3.)*V_pd_pi )
	!~ tdp(3,5,6)=sqrt(3.)*a*(V_pd_sigma+4*sqrt(3.)*V_pd_pi )

	!~ =============================================
	!~                                  PD            V-Beta S bottom
	!~ =============================================

	Vx=  0.d0  ;       Vy=   1.d0/sq3*a1   ;      Vz= 0.5d0*a1

	call	 PD_Bonds_Family( Tswitch, Vx, Vy, Vz, &
			& E_x_xy,  E_x_yz,  E_x_xz,  E_x_x2y2, E_x_z2, &
			& E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2, &
			& E_z_xy,  E_z_yz ,  E_z_xz,  E_z_x2y2 , E_z_z2)

	print*,''
	print*, E_x_xy, E_x_yz, E_x_xz, E_x_x2y2, E_x_z2
	print*,''
	print*, tdp(1, 1:5, 4)

	print*,''
	print*,  E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2
	print*,''
	print*, tdp(2, 1:5, 4)

	print*,''
	print*, E_z_xy,  E_z_yz , E_z_xz , E_z_x2y2 , E_z_z2
	print*,''
	print*, tdp(3, 1:5, 4)

	!~ =============================================
	!~                                  PD            V-Gamma S bottom
	!~ =============================================

	Vx=  0.5d0*a1  ;       Vy=   -0.5d0/sq3*a1   ;      Vz= 0.5d0*a1

	call	 PD_Bonds_Family( Tswitch, Vx, Vy, Vz, &
			& E_x_xy,  E_x_yz,  E_x_xz,  E_x_x2y2, E_x_z2, &
			& E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2, &
			& E_z_xy,  E_z_yz ,  E_z_xz,  E_z_x2y2 , E_z_z2)

	print*,''
	print*, E_x_xy, E_x_yz, E_x_xz, E_x_x2y2, E_x_z2
	print*,''
	print*, tdp(1, 1:5, 5)

	print*,''
	print*,  E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2
	print*,''
	print*, tdp(2, 1:5, 5)

	print*,''
	print*, E_z_xy,  E_z_yz , E_z_xz , E_z_x2y2 , E_z_z2
	print*,''
	print*, tdp(3, 1:5, 5)

	!~ =============================================
	!~                                  PD            V-alpha S bottom
	!~ =============================================

	Vx=  -0.5d0*a1  ;       Vy=   -0.5d0/sq3*a1   ;      Vz= 0.5d0*a1

	call	 PD_Bonds_Family( Tswitch, Vx, Vy, Vz, &
			& E_x_xy,  E_x_yz,  E_x_xz,  E_x_x2y2, E_x_z2, &
			& E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2, &
			& E_z_xy,  E_z_yz ,  E_z_xz,  E_z_x2y2 , E_z_z2)

	!~ =============================================

    tdp(1, 1:5, 6)= [ E_x_xy, E_x_yz, E_x_xz, E_x_x2y2, E_x_z2  ]

    tdp(2, 1:5, 6)= [ E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2  ]

    tdp(3, 1:5, 6)= [ E_z_xy,  E_z_yz , E_z_xz , E_z_x2y2 , E_z_z2  ]

	print*,''
	print*, E_x_xy, E_x_yz, E_x_xz, E_x_x2y2, E_x_z2
	print*,''
	print*, tdp(1, 1:5, 6)

	print*,''
	print*,  E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2
	print*,''
	print*, tdp(2, 1:5, 6)

	print*,''
	print*, E_z_xy,  E_z_yz , E_z_xz , E_z_x2y2 , E_z_z2
	print*,''
	print*, tdp(3, 1:5, 6)

!~ ============================================
end program InterAtomshopping
!~ ============================================

max_stars_repo_name: xxzpl/TMDCs-Simulator

max_issues_repo_name: xxzpl/TMDCs-Simulator

max_forks_repo_name: xxzpl/TMDCs-Simulator


text:
        SUBROUTINE GG_WWCR ( date, alias, mndif, iuwtch, iunum, tzone,
     +                       timiss, tmstrt, tmstp, iret )
C************************************************************************
C* GG_WWCR                                                              *
C*                                                                      *
C* This subroutine returns the array of active thunderstorm and tornados*
C* for either the current WOUs or WCNs                                  *
C*                                                                      *
C* GG_WWCR ( DATE, ALIAS, MNDIF, IUWTCH, IUNUM, TZONE, TIMISS, TMSTRT,  *
C*           TMSTP, IRET )                                              *
C*                                                                      *
C* Input parameters:                                                    *
C*   DATE	    CHAR*          Ending time for watches              *
C*   ALIAS          CHAR*          Alias for WOU or WCN                 *
C*   MNDIF          INTEGER        Minutes difference from end time	*
C*                                                                      *
C* Output parameters:                                                   *
C*   IUWTCH (IUNUM) INTEGER        Unique watch numbers                 *
C*   IUNUM          INTEGER        Number of Unique watchs         	*
C*   TZONE (IUNUM)  CHAR*          Time zones                        	*
C*   TIMISS(IUNUM)  CHAR*          Issue times for each watch      	*
C*   TMSTRT(IUNUM)  CHAR*          Start times for each watch      	*
C*   TMSTP(IUNUM)   CHAR*          Stop times for each watch       	*
C*   IRET           INTEGER                Return code                  *
C*                                                                      *
C**                                                                     *
C* Log:                                                                 *
C* A. Hardy/NCEP    2/03        Modified from GG_WCUR                   *
C* A. Hardy/NCEP    3/03        Modified for reverse search             *
C* A. Hardy/NCEP    6/03        Increased array size 100 -> NW          *
C* A. Hardy/NCEP    7/03        Added MNDIF to call sequence            *
C* A. Hardy/NCEP    8/03        Added MNDIF to unique watch IF          *
C* A. Hardy/NCEP    1/04        Added tmstp to call sequence            *
C* B. Yin/SAIC      3/04        Changed SS_GTIM to CSS_GTIM             *
C* T. Lee/SAIC      9/04        Replaced FL_TMPL with CTB_DTGET         *
C* A. Hardy/NCEP    11/04       Added calls to ST_RNUL                  *
C* m.gamazaychikov/SAIC 12/04   Added ion flag to CTB_DTGET CS          *
C* A. Hardy/NCEP    04/05       Added check for cancel messages		*
C* m.gamazaychikov/SAIC 01/06   Changed templ string length to MXTMPL   *
C* F. J. Yen/NCEP   02/06	Increase length of buffer to max decoded*
C* m.gamazaychikov/SAIC 04/06   Added idtmch flag to CTB_DTGET CS       *
C* F. J. Yen/NCEP        4/08   Added bin mins & mstrct to CTB_DTGET CSC*
C* F. J. Yen/NCEP	 7/08	Increased look back from 6 hrs to 48 hrs*
C************************************************************************
        INCLUDE                'GEMPRM.PRM'
        INCLUDE                'ggcmn.cmn'
C*
        CHARACTER*(*)   date, alias, tzone(*), timiss(*), tmstrt(*),
     +                  tmstp(*)
        INTEGER                iuwtch(*)
C*
        CHARACTER        path*25, templ*(MXTMPL), cdttm*20, dattm2*20,
     +                   buffer*120, tfile*128, tmstr4*20,
     +                   tmstp4*20, carr(11)*20, tnum*4,
     +                   temp4*20
C*
        CHARACTER        stime*20, flstrt*160, zone(NW)*3,
     +                   chiss(NW)*20, fnull*(MXFLSZ)
        INTEGER          itarr(5), jtarr(5), idtarr(5), itype
        LOGICAL          done, found, finis, rnew, iuflg, gdtim
C-----------------------------------------------------------------------
        iret = 0
        dattim = date
C
C*        Scan the directory for all of the watch data files.
C
        CALL ST_LCUC ( alias, alias, ier )
        CALL ST_NULL ( alias, fnull, nf, ier )
        path  = ' '
        templ = ' '
	CALL CTB_DTGET ( fnull, path, templ, ic, is, if, ir, ii, ion,
     +          ihb, mnb, iha, mna, mstrct, idtmch, ier )
        CALL ST_RNUL ( path, path, lens, ier )
        CALL ST_RNUL ( templ, templ, lens, ier )
        CALL ST_LSTR ( path, lenp, ier )
        nexp   = MXNMFL
        iorder =  1
        CALL FL_SCND ( path, templ, iorder, nexp, files, nfile, ier )
C
C*        Check for the last file requested by the user.
C
        CALL ST_LCUC ( dattim, dattim, ier )
        itype = 1
        IF  ( ( dattim .eq. 'LAST' ) .or.
     +              ( dattim .eq. 'ALL' ) )  THEN
            CALL CSS_GTIM ( itype, dattm2, ier )
            CALL FL_MNAM ( dattm2, templ, filnam, ier )
          ELSE
            CALL CSS_GTIM ( itype, cdttm, ier )
            CALL TI_STAN ( dattim, cdttm, dattm2, ier )
            IF ( ier .ne. 0 ) THEN
                    CALL ER_WMSG ( 'TI', ier, dattim, ierr )
                    iret = ier
                    RETURN
            ENDIF
            CALL FL_MNAM ( dattm2, templ, filnam, ier )
        END IF
C
C*        Find the earliest file to start searching. For ALL times
C*        go back 10 days, for any other entry for dattim subtract
C*        1 day from the time given.
C
        IF  ( dattim .eq. 'ALL' )  THEN
            minuts = 14400
          ELSE
            minuts = 1440
        END IF
        CALL TI_CTOI ( dattm2, itarr, ier )
        CALL TI_SUBM ( itarr, minuts, jtarr, ier )
        CALL TI_ITOC ( jtarr, stime, ier )
        CALL FL_MNAM ( stime, templ, flstrt, ier )
C
C*        Get 4-digit year to compare dates.
C
        CALL TI_DTM4 ( dattm2, dattm4, ier )
C
C*        Decode each file until the end time is reached.
C
        nwtch = 0
        wnum ( 1 ) = ' '
        done  = .false.
        ifl = 1
        DO WHILE  ( ( ifl .le. nfile ) .and. ( .not. done ) )
           IF  ( files(ifl) .gt. filnam )  THEN
              done = .true.
            ELSE
              IF  ( files(ifl) .ge. flstrt )  THEN
                tfile = path(:lenp) // '/' // files(ifl)
                CALL FL_SOPN ( tfile, lunf, ier )
C
                iostat = 0
                DO WHILE  ( iostat .eq. 0 )
                  READ ( lunf, 2, IOSTAT = iostat ) buffer
2                  FORMAT ( A )
                  IF  ( iostat .eq. 0 )  THEN
                    IF  ( buffer(1:1) .eq. '|' )  THEN
                        CALL ST_CLST ( buffer, '|', ' ', 11,
     +                                       carr, num, ier )
                        CALL ST_NUMB ( carr ( 6 ), nmwtch, ier )
                        CALL ST_INCH ( nmwtch, tnum, ier )
                        carr ( 6 ) = tnum
                        CALL ST_NUMB ( carr ( 10 ), jflag, ier )
                        icorr = MOD ( jflag, 4 )
                        jtest = jflag / 4
                        CALL ST_NUMB ( carr ( 11 ), icancl, ier )
                        found = .false.
                        finis = .false.
                        rnew  = .false.
                        ii    = 1
                        jw    = 0
C
                              IF ( ( carr ( 2 )(:3) .eq. 'TOR' ) .or.
     +                       ( carr ( 2 )(:3) .eq. 'TSM' ) .or.
     +                       ( carr ( 2 )(:3) .eq. 'SVR' ) ) THEN
                            IF ( .not. found ) THEN
C
C*                                Add new watch to the data arrays.
C
                                rnew  = .true.
                                temp4 = carr ( 5 )
                            END IF
                        END IF

C
C*                        See if this may actually be a correction
C*                        to a watch number.
                        IF ( icorr .eq. 1 ) THEN
                            DO ii = 1, nwtch
                                IF ( ( carr(2)(:2) .eq. wtype(ii))
     +                            .and. ( carr(4) .eq. timstr(ii))
     +                            .and. ( carr(5) .eq. timstp(ii)) )
     +                                 icnum = ii
                            END DO
                         END IF
                        IF ( rnew ) THEN
C
C*                            Add new watch information.
C
                            nwtch = nwtch + 1
                            jw    = nwtch
                            wtype  (jw) = carr (2)(:2)
                            chiss  (jw) = carr (3)
                            timstr (jw) = carr (4)
                            timstp (jw) = temp4
                            wnum   (jw) = carr (6)(:4)
                            zone   (jw) = carr (9)(:3)
			    npt    (jw) = 0
                            itest  (jw) = jtest
                        END IF
                      END IF
                  END IF
                END DO
C
                CALL FL_CLOS ( lunf, ier )
C
              END IF
C
          END IF
          ifl = ifl + 1
        END DO
C
        CALL TI_CTOI ( dattm4, idtarr, ier )
        CALL TI_ADDM ( idtarr, mndif, idtarr, ier )
        CALL TI_ITOC ( idtarr, dattm4, ier )
C
        ij = 1
        iunum = 0
        iuflg = .false.
        DO ii = nwtch, 1, -1
           gdtim = .false.
C

           CALL TI_DTM4 ( timstp ( ii ), tmstp4, ier )
           CALL TI_DTM4 ( timstr ( ii ), tmstr4, ier )
C
            CALL TI_CTOI ( tmstr4, idtarr, ier )
            CALL TI_ADDM ( idtarr, mndif, idtarr, ier )
            CALL TI_ITOC ( idtarr, tmstr4, ier )
            CALL TI_CTOI ( tmstp4, idtarr, ier )
            CALL TI_ITOC ( idtarr, tmstp4, ier )
C
            IF ( (dattim .eq. 'ALL' ) .or.
     +          ( ( tmstp4 .ge. dattm4 ) .and.
     +            ( tmstr4 .le. dattm4 ) ) ) THEN
C
C*             Check time differences.
C
               CALL TI_DIFF ( dattim, chiss(ii), nmis, ier )
               CALL TI_DIFF ( dattim, timstr(ii), nmst, ier )
               CALL TI_DIFF ( dattim, timstp(ii), nmsp, ier )
C
               IF ( nmis .ge. 0 ) THEN
                   IF ( nmst .ge. 0 ) THEN
                       IF ( nmsp .le. mndif )  THEN
                           gdtim = .true.
                         ELSE
                           CALL TI_DIFF ( timstr(ii), timstp(ii),
     +                                    nm, ier )
                           IF ( nm .eq. 0 ) THEN
                               gdtim = .true.
C
C*			       This check sets a limit on how far
C*				to go back to check for cancel messages.
C*                              Currently it is set for 48 hours.
C
                               IF ( (mndif .eq. 0  ) .and.
     +                            ( nmsp .le. 2880  ) ) THEN
                                     nmsp = mndif
                               END IF
                             ELSE
                               gdtim = .false.
                           END IF
                       END IF
                     ELSE
                       gdtim = .false.
                   END IF
                 ELSE
                   gdtim = .false.
               END IF
C
C*	       Find unique watch numbers.
C
               IF ( ( ( wtype (ii) .eq. 'TS') .or.
     +              ( wtype (ii) .eq. 'TO') .or.
     +              ( wtype (ii) .eq. 'SV') ) .and. ( gdtim)
     +              .and. ( nmsp .le. mndif ) ) THEN
                   CALL ST_NUMB (wnum (ii), iwnm, ier )
                   DO jj = 1, iunum
                       if ( iuwtch (jj) .eq. iwnm ) THEN
                           iuflg = .true.
                       END IF
                   END DO
C
                   IF ( .not. iuflg ) THEN
                       iunum = iunum + 1
                       iuwtch ( iunum ) = iwnm
                       tzone(iunum)  = zone(ii)
                       timiss(iunum) = chiss(ii)
                       tmstrt(iunum) = timstr(ii)
                       tmstp(iunum)  = timstp(ii)
                   END IF
                   iuflg = .false.
               END IF
               ij = ij + 1
            END IF
        END DO
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text: the quick brown fox jumped over the lazy dog.


text:
      module other
      implicit none

      integer, parameter :: other_int = selected_real_kind(14)

      end module other

max_stars_repo_name: wilsonify/fwrap

max_issues_repo_name: fwrap/fwrap

max_forks_repo_name: fwrap/fwrap


text:
      SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC )
*
*  -- LAPACK auxiliary routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INCC, INCX, INCY, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   C( * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  DLARGV generates a vector of real plane rotations, determined by
*  elements of the real vectors x and y. For i = 1,2,...,n
*
*     (  c(i)  s(i) ) ( x(i) ) = ( a(i) )
*     ( -s(i)  c(i) ) ( y(i) ) = (   0  )
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of plane rotations to be generated.
*
*  X       (input/output) DOUBLE PRECISION array,
*                         dimension (1+(N-1)*INCX)
*          On entry, the vector x.
*          On exit, x(i) is overwritten by a(i), for i = 1,...,n.
*
*  INCX    (input) INTEGER
*          The increment between elements of X. INCX > 0.
*
*  Y       (input/output) DOUBLE PRECISION array,
*                         dimension (1+(N-1)*INCY)
*          On entry, the vector y.
*          On exit, the sines of the plane rotations.
*
*  INCY    (input) INTEGER
*          The increment between elements of Y. INCY > 0.
*
*  C       (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
*          The cosines of the plane rotations.
*
*  INCC    (input) INTEGER
*          The increment between elements of C. INCC > 0.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IC, IX, IY
      DOUBLE PRECISION   F, G, T, TT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
*     ..
*     .. Executable Statements ..
*
      IX = 1
      IY = 1
      IC = 1
      DO 10 I = 1, N
         F = X( IX )
         G = Y( IY )
         IF( G.EQ.ZERO ) THEN
            C( IC ) = ONE
         ELSE IF( F.EQ.ZERO ) THEN
            C( IC ) = ZERO
            Y( IY ) = ONE
            X( IX ) = G
         ELSE IF( ABS( F ).GT.ABS( G ) ) THEN
            T = G / F
            TT = SQRT( ONE+T*T )
            C( IC ) = ONE / TT
            Y( IY ) = T*C( IC )
            X( IX ) = F*TT
         ELSE
            T = F / G
            TT = SQRT( ONE+T*T )
            Y( IY ) = ONE / TT
            C( IC ) = T*Y( IY )
            X( IX ) = G*TT
         END IF
         IC = IC + INCC
         IY = IY + INCY
         IX = IX + INCX
   10 CONTINUE
      RETURN
*
*     End of DLARGV
*
      END

max_stars_repo_name: pkeuchel/oomph-lib

max_issues_repo_name: pkeuchel/oomph-lib

max_forks_repo_name: pkeuchel/oomph-lib


text:
module CONSTANTS
! Description:
!    Contains physical constants used in the peogram and the SET_UNITS subroutine
!    to set the reference units for non-dimensionalization of the state vector.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    d.amato@upm.es
!
! ==============================================================================

use KINDS, only: dk,qk

! VARIABLES
implicit none

! Reference quantities for non-dimensionalization [km, 1/s].
real(qk)           ::  DU,TU

! Physical quantities.
! Earth.
real(qk),parameter     ::  REarth          = 6.37122E3_qk          ! [km]
real(qk),parameter     ::  smaEarth        = 1.49598023E8_qk       ! [km] = Astronomical unit
real(qk),parameter     ::  muEarth         = 3.98601E5_qk          ! [km^3/s^2]
real(qk),parameter     ::  J2Earth         = 1.08265E-3_qk         ! [-]
real(qk)               ::  wEarth                                  ! Earth angular velocity [rad/s]
real(qk)               ::  R_SoI                                   ! Earth sphere of influence radius [km]
! Sun.
real(qk),parameter     ::  muSun           = 1.32712428E11_qk      ! [km^3/s^2]
! Misc.
real(qk),parameter     ::  secsPerDay      = 86400._qk
real(qk),parameter     ::  pi    = 3.1415926535897932384626433832795027974814_qk
real(qk),parameter     ::  twopi = 6.2831853071795864769252867665590055949581_qk
real(qk)               ::  d2r

contains

subroutine SET_UNITS(r,mu)
! Description:
!    Computes reference quantities from a position vector and a gravitational
!    parameter.
! ==============================================================================

! VARIABLES
implicit none

! Arguments
real(qk),intent(IN)     ::  r(1:3)    ! Input Cartesian position [km, km/s].
real(qk),intent(IN)     ::  mu        ! Gravitational parameter  [km^3/s^2].

! ==============================================================================

DU = sqrt(dot_product(r,r))
TU = SQRT(mu/DU**3)

END SUBROUTINE SET_UNITS

end module CONSTANTS

max_stars_repo_name: dkamato/NAPLES

max_issues_repo_name: dkamato/NAPLES

max_forks_repo_name: dkamato/NAPLES


text:
The City Limits of Davis:

The city limits do not include the university or most anything west of it, which is almost exclusively student housing.  The net effect is that nearly half of the citys student population doesnt get to participate in city elections, exactly the way the rest of the city likes it.  Students, who are poor and need a place to live, tend to be in favor of new development, whereas old residents, who own homes, tend to be in favor of driving up the scarcity of housing as much as they can in order to raise their property values.

Interestingly, although much of the University lies outside of the city of Davis, the borders of Yolo county follow Putah Creek and thus include most of the University owned land and virtually all of the developed land.  The remainder south of Putah is Solano County.

The University owns an enormous amount of land and is technically in unincorporated Yolo county.  To skirt Davis nogrowth politics, many of the Real Estate new developments proposed are on University property in unincorporated county.

See: NIMBY

Additional topics needing to be covered in this article include buffer space and the agreement with the County where the City pays to extend their control over development outside of the city limits.


text:
A guy who lives in Davis

Who wants to play basketball


text:
!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine report_date_time(lun)
!
!     reports actual date and time in file (lun)
!
      use timers

      implicit none
      integer, intent(in) :: lun
      character(len= 8)   :: datum
      character(len=10)   :: tijd
      integer(4) ithndl              ! handle to time this subroutine
      data       ithndl / 0 /
      if ( timon ) call timstrt( "report_date_time", ithndl )

      call date_and_time (date=datum,time=tijd)
!
      write(lun,'(//20(a))')       &
       '  Actual date/time = ',datum(1:4),'/',datum(5:6),'/',datum(7:8), &
       '  ',tijd(1:2),':',tijd(3:4),':',tijd(5:6)
!
      if ( timon ) call timstop ( ithndl )
      end subroutine report_date_time

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


text:
C                                                                       LOV06850
C     LOVE WAVE MATRIX METHOD INTEGRATION                               LOV06860
C                                                                       LOV06870
      SUBROUTINE  LOVMRX(H,RHO,VS,AX,L,W,C,                             LOV06880
     *                   IA,IG,U,EK,Y0,IER)                             LOV06890
C                                                                       LOV06900
C     INPUT                                                             LOV06910
C       H    : LAYER THICKNESS.  H(L) IS ARBITRARY                      LOV06920
C       RHO  : DENSITY                                                  LOV06930
C       VS   : SHEAR WAVE VELOCITY                                      LOV06940
C       AX   : ANISOTROPY FACTOR XI                                     LOV06950
C       L    : NUMBER OF LAYERS INCLUDING THE BOTTOM                    LOV06960
C              HALF-SPACE                                               LOV06970
C       W    : ANGULAR FREQUENCY                                        LOV06980
C       C    : PHASE VELOCITY                                           LOV06990
C       IA   : = 0 ;   ISOTROPIC MODEL                                  LOV07000
C              = 1 ; ANISOTROPIC MODEL                                  LOV07010
C       IG   : = 1 ; TO COMPUTE Y ONLY                                  LOV07020
C              = 2 ; TO COMPUTE Y AND C*DY/DC                           LOV07030
C              = 3 ; TO COMPUTE Y, C*DY/DC AND W*DY/DW                  LOV07040
C     OUTPUT                                                            LOV07050
C       U    : GROUP VELOCITY BY DIFFERENTIATION (IG=3)                 LOV07060
C       EK   : ENERGY INTEGRAL 2*K**2*I3 BY                             LOV07070
C              DIFFERENTIATION  (IG>=2)                                 LOV07080
C       Y0   : SURFACE VALUE OF Y                                       LOV07090
C              SURFACE VALUE OF C*DY/DC (WHEN IG>=2)                    LOV07100
C              SURFACE VALUE OF W*DY/DW (WHEN IG=3)                     LOV07110
C              Y0(1) ; Y1                                               LOV07120
C              Y0(2) ; Y2/ABS(Y1), DISPERSION FUNCTION                  LOV07130
C                 Y2 HERE IS Y2/K IN THE CONVENTIONAL                   LOV07140
C                 DEFINITION                                            LOV07150
C       IER  : RETURN CODE                                              LOV07160
C              < 0 ; INPUT ERROR                                        LOV07170
C              = 0 ; NO ERROR                                           LOV07180
C                                                                       LOV07190
C     DISPER-80,  VER-86                                                LOV07200
C                                                                       LOV07210
C     M. SAITO  23/VI/79                                                LOV07220
C     REVISED    3/XII/86                                               LOV07230
C                                                                       LOV07240
      DIMENSION  H(L),RHO(L),VS(L),AX(L),Y0(6)                          LOV07250
      DATA  EPS/1.E-10/,BIG/1.E+10/                                     LOV07260
C                                                                       LOV07270
C     DEFINE  SH0(X**2)= SINH(X)/X AND                                  LOV07280
C             SH1(X**2)=(COSH(X)-SINH(X)/X)/X**2                        LOV07290
C                                                                       LOV07300
      SH0(X) = 0.9999997 + X*(0.1666667                                 LOV07310
     *       + X*(0.0083361 + X*0.0001984))                             LOV07320
      SH1(X) = 0.3333333 + X*(0.0333333                                 LOV07330
     *       + X*(0.0011907 + X*0.0000220))                             LOV07340
C                                                                       LOV07350
C     FOR DOUBLE PRECISION USE                                          LOV07360
C                                                                       LOV07370
C     SH0(X) = 1.0D0 + X*(1.6666 66666 66666 7D-1                       LOV07380
C    *       + X*(8.33 33333 33334 0D-3                                 LOV07390
C    1       + X*( 1.9 84126 98412 7D-4                                 LOV07400
C    2       + X*(2.7557 31918 9D-6 + X*(2.50 12108 4D-8                LOV07410
C    3       + X*(1.60596 1D-10 + X*7.64 7D-13))))))                    LOV07420
C     SH1(X) = 3.3333 33333 33333 3D-1                                  LOV07430
C    *       + X*(3.333 33333 33333 3D-2                                LOV07440
C    1       + X*(1.19 04761 90476 2D-3                                 LOV07450
C    2       + X*(2.20458 55379 2D-5                                    LOV07460
C    3       + X*(2.505 21083 7D-7 + X*(1.9 27085 3D-9                  LOV07470
C    4       + X*(1.0706 3D-11 + X*4.50D-14))))))                       LOV07480
C                                                                       LOV07490
C     INITIAL VALUE                                                     LOV07500
C                                                                       LOV07510
      IF( L.LE.1 .OR. W.LE.0 .OR. C.LE.0 )  GO TO  90                   LOV07520
      I   = L                                                           LOV07530
      RO  = RHO(I)                                                      LOV07540
      IF( RO.LE.0 )  GO TO  92                                          LOV07550
      DO  1  J=2,L                                                      LOV07560
        IF( VS(I-1).GT.0 )  GO TO  2                                    LOV07570
        I = I - 1                                                       LOV07580
    1 CONTINUE                                                          LOV07590
      GO TO  92                                                         LOV07600
C                                                                       LOV07610
    2 IER = 0                                                           LOV07620
      IGG = MAX(1,MIN(3,IG))                                            LOV07630
      WN  = W/C                                                         LOV07640
      CC  = C*C                                                         LOV07650
      ROC = RO*CC                                                       LOV07660
      Y1 = EPS                                                          LOV07670
      Y2 = 0                                                            LOV07680
      Y3 = 0                                                            LOV07690
      Y4 = 0                                                            LOV07700
      Y5 = 0                                                            LOV07710
      Y6 = 0                                                            LOV07720
      EL  = RO*VS(I)**2                                                 LOV07730
      IF( EL.GT.0 )  THEN                                               LOV07740
        XI  = 1                                                         LOV07750
        IF( IA.GT.0 )  XI = AX(I)                                       LOV07760
        RBB = XI - (C/VS(I))**2                                         LOV07770
C       WRITE (*,*),"XI C VS(I) RBB= ",RBB,XI,C,VS(I)                   LOV07775
        IF( RBB.LE.0 )  GO TO  92                                       LOV07780
        RB  = SQRT(RBB)                                                 LOV07790
        Y2  = Y1*EL*RB                                                  LOV07800
        IF( IGG.GE.2 )  Y4 =-Y1*ROC/RB                                  LOV07810
      ENDIF                                                             LOV07820
C                                                                       LOV07830
C     INTEGRATE UPWARD                                                  LOV07840
C                                                                       LOV07850
      DO  3  II=2,L                                                     LOV07860
        I   = I - 1                                                     LOV07870
        RO  = RHO(I)                                                    LOV07880
        ROC = RO*CC                                                     LOV07890
        XI  = 1                                                         LOV07900
        IF( IA.GT.0 )  XI = AX(I)                                       LOV07910
        EL  = RO*VS(I)**2                                               LOV07920
        IF( EL.LE.0 .OR. H(I).LE.0 )  GO TO  92                         LOV07930
        RBB = XI - (C/VS(I))**2                                         LOV07940
        HK  = H(I)*WN                                                   LOV07950
        X   = RBB*HK**2                                                 LOV07960
C                                                                       LOV07970
C       SINH(X)/X                                                       LOV07980
C                                                                       LOV07990
        AA = ABS(X)                                                     LOV08000
        IF( AA.LE.1 )  THEN                                             LOV08010
          SHB = SH0(X)                                                  LOV08020
          CHB = 1 + X*SH0(X/4)**2/2                                     LOV08030
          IF( IGG.GE.2 )  DHB = HK**2*SH1(X)                            LOV08040
        ELSE                                                            LOV08050
          AA = SQRT(AA)                                                 LOV08060
          IF( X.GE.0 )  THEN                                            LOV08070
            CHB = 1                                                     LOV08080
            SHB = TANH(AA)/AA                                           LOV08090
          ELSE                                                          LOV08100
            SHB = SIN(AA)/AA                                            LOV08110
            CHB = COS(AA)                                               LOV08120
          ENDIF                                                         LOV08130
          IF( IGG.GE.2 )  DHB = HK**2*(CHB - SHB)/X                     LOV08140
        ENDIF                                                           LOV08150
        SHB = HK*SHB                                                    LOV08160
C                                                                       LOV08170
C       LAYER MATRIX                                                    LOV08180
C                                                                       LOV08190
        B11 = CHB                                                       LOV08200
        B12 = SHB/EL                                                    LOV08210
        B21 = EL*RBB*SHB                                                LOV08220
C                                                                       LOV08230
        Z1  = Y1                                                        LOV08240
        Z2  = Y2                                                        LOV08250
        Y1  = B11*Z1 + B12*Z2                                           LOV08260
        Y2  = B21*Z1 + B11*Z2                                           LOV08270
C                                                                       LOV08280
        IF( IGG.GE.2 )  THEN                                            LOV08290
          C11 =-HK*SHB                                                  LOV08300
          C12 =-(HK*DHB + SHB)/EL                                       LOV08310
          C21 =-EL*HK*CHB - ROC*SHB                                     LOV08320
C                                                                       LOV08330
          Z3  = Y3                                                      LOV08340
          Z4  = Y4                                                      LOV08350
          Y3  = B11*Z3 + B12*Z4 + C11*Z1 + C12*Z2                       LOV08360
          Y4  = B21*Z3 + B11*Z4 + C21*Z1 + C11*Z2                       LOV08370
C                                                                       LOV08380
          IF( IGG.GT.2 )  THEN                                          LOV08390
            W11 = HK*RBB*SHB                                            LOV08400
            W12 = HK*CHB/EL                                             LOV08410
            W21 = HK*EL*RBB*CHB                                         LOV08420
C                                                                       LOV08430
            Z5  = Y5                                                    LOV08440
            Z6  = Y6                                                    LOV08450
            Y5  = B11*Z5 + B12*Z6 + W11*Z1 + W12*Z2                     LOV08460
            Y6  = B21*Z5 + B11*Z6 + W21*Z1 + W11*Z2                     LOV08470
          ENDIF                                                         LOV08480
        ENDIF                                                           LOV08490
C                                                                       LOV08500
C     NORMALIZATION                                                     LOV08510
C                                                                       LOV08520
        Z1 = MAX(ABS(Y1), ABS(Y2))                                      LOV08530
        IF( Z1.GT.BIG )  THEN                                           LOV08540
          Y1 = EPS*Y1                                                   LOV08550
          Y2 = EPS*Y2                                                   LOV08560
          IF( IGG.GE.2 )  THEN                                          LOV08570
            Y3 = EPS*Y3                                                 LOV08580
            Y4 = EPS*Y4                                                 LOV08590
            IF( IGG.GT.2 )  THEN                                        LOV08600
              Y5 = EPS*Y5                                               LOV08610
              Y6 = EPS*Y6                                               LOV08620
            ENDIF                                                       LOV08630
          ENDIF                                                         LOV08640
        ENDIF                                                           LOV08650
C                                                                       LOV08660
    3 CONTINUE                                                          LOV08670
C                                                                       LOV08680
C     NORMAL EXIT                                                       LOV08690
C                                                                       LOV08700
      Y0(1) = Y1                                                        LOV08710
      IF( ABS(Y2)*EPS.LE.ABS(Y1) )  THEN                                LOV08720
        Y0(2) = Y2/ABS(Y1)                                              LOV08730
      ELSE                                                              LOV08740
        Y0(2) = SIGN(BIG,Y2)                                            LOV08750
      ENDIF                                                             LOV08760
      IF( IGG.GE.2 )  THEN                                              LOV08770
        Y0(3) = Y3                                                      LOV08780
        Y0(4) = Y4                                                      LOV08790
        EK =-WN*Y4/Y1                                                   LOV08800
        IF( IGG.GT.2 )  THEN                                            LOV08810
          U =C*Y4/(Y4 + Y6)                                             LOV08820
          Y0(5) = Y5                                                    LOV08830
          Y0(6) = Y6                                                    LOV08840
        ENDIF                                                           LOV08850
      ENDIF                                                             LOV08860
C                                                                       LOV08870
      RETURN                                                            LOV08880
C                                                                       LOV08890
C     INPUT ERROR                                                       LOV08900
C                                                                       LOV08910
   90 WRITE(6,91)  L,W,C                                                LOV08920
   91   FORMAT(20X,5('?'),3X,'(LOVMRX)   INPUT ERROR',3X,               LOV08930
     *         'L  =',I5,3X,'W  =',1PE13.6,3X,                          LOV08940
     1         'C  =',E13.6,3X,5('?'))                                  LOV08950
      IER =-1                                                           LOV08960
      RETURN                                                            LOV08970
C                                                                       LOV08980
   92 WRITE(6,93)  I                                                    LOV08990
   93   FORMAT(20X,5('?'),3X,'(LOVMRX)   INPUT ERROR',3X,               LOV09000
     *         'AT LAYER',I5,3X,5('?'))                                 LOV09010
      IER =-MAX(1,I)                                                    LOV09020
      RETURN                                                            LOV09030
      END                                                               LOV09040

max_stars_repo_name: AntonBiryukovUofC/RayTracerFortran

max_issues_repo_name: AntonBiryukovUofC/RayTracerFortran

max_forks_repo_name: AntonBiryukovUofC/RayTracerFortran


text:
	FUNCTION XPADC(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE DC CHANNEL OF THE WIND X PREAMP
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
	COMMON /COMPBLK/ CVAR(5)
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2
	DATA R9,C9,R10,CINP /5.E8, 23.6E-12, 5.E8, 4.37E-12/
	DATA R33,C16 /2.2E+03, 1.203E-9/
	DATA R1C,R2C,CCOMP / 0., 4.64E3, .947E-6/    ! as shown on drawing
C	DATA R1C,R2C,CCOMP / 0., 5.E3, .947E-6/
	DATA R5 /22.1E3/
	DATA TWOPI /6.2831853/
C
C	C16 = 1.203E-9                             ! ADJUSTING EX
C	C9  = 23.6E-12                            ! ADJUSTING EX
C	CINP = 4.37E-12                          ! ADJUSTING EX
C
C	C16 = CVAR(1)
C	C9 = CVAR(2)
C	CINP = CVAR(3)
C
	W = TWOPI*F
	CGAIN = 1.
C	DIVISION OF SIGNAL BEFORE FOLLOWER
	Y1 = CMPLX(1./R9,W*C9)
	Y2 = CMPLX(1./R10,W*CINP)
	Z1 = 1./Y1
	Z2 = 1./Y2
	CGAIN = CGAIN*Z2/(Z1+Z2)
C	EFFECT OF OUTPUT RC
	WC16 = 1./(W*C16)
C	PRINT*,'W,Z1,WC16',W,Z1,WC16
C	PRINT*,'F,CGAIN,PHASE
	CGAIN = CGAIN*CMPLX(0.,-WC16)/CMPLX(R33,-WC16)
C*****************   effect of compensation
C
C	EFFECT OF INPUT (211) BOARD
C
	WCC = W*CCOMP
	Z2 = CMPLX(R2C,-1./WCC)
	Y1 = 1./R5 + 1./(R1C + Z2) + CMPLX(0.,W*C16)
	CGAIN = CGAIN*(Z2/(R1C+Z2))/(1. + R33*Y1)
C*************
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	XPADC = CABS(CGAIN)
	RETURN
	END

ext: for


text:
	PROGRAM  OABSND
C************************************************************************
C* PROGRAM OABSND							*
C*									*
C* This program performs a Barnes analysis for sounding data.		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 6/86	From existing code			*
C* M. desJardins/GSFC	11/88	GEMPAK 4.1				*
C* K. Brill/GSC          4/90   Added guess file and multiple files	*
C* K. Brill/NMC          8/90   Fix multiple files			*
C* J. Nielsen/SUNYA	10/90	Use first guess in first pass		*
C*				Adjust weights only after first pass	*
C* K. Brill/NMC         10/90   Quit for NSTN=0; Output guess rms	*
C* K. Brill/NMC		06/91	Added EXTRAP and COSSLT; replace COSLSQ	*
C*				with COSLAT				*
C* S. Jacobs/EAI         3/93   Add J Nielsen's change to extrap        *
C* L. Williams/EAI       3/94   Clean up declarations of user input	*
C*				variables				*
C* S. Jacobs/NMC	 6/94	STNDEX*48 --> *72			*
C* L. Williams/EAI	 7/94	Removed call to OANUPD			*
C* S. Jacobs/NMC	 3/95	Added mand data only flag; Call SN_MAND	*
C* K. Tyle/GSC		 8/96	Added FL_MFIL to search for file type	*
C* S. Maxwell/GSC        7/97   Increased input character length        *
C* S. Jacobs/NCEP	 6/98	Added guess flag to OA_BARN call	*
C* T. Lee/GSC		 3/99	Processed multiple files & missing data	*
C* D. Kidwell/NCEP	 5/99	Added mandat to OANPRM call             *
C* K. Brill/HPC		 4/03	CALL DG_INTL				*
C* R. Tian/SAIC		 1/04	Added nuflg to DG_INTL call		*
C* R. Tian/SAIC		 2/04	Removed nuflg from DG_INTL call		*
C* R. Tian/SAIC          3/05   Modfied to adapt new file/time mgnt     *
C* J. Wu/SAIC		 4/05	Added bounds blocking			*
C* T. Piper/SAIC        01/08   Added GD_INIT; removed from IN_BDTA     *
C* S. Chiswell/SRS	 8/09	Moved SN_MAND call due to logic error	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	PARAMETER	( LLDTMX = LLSTFL * MMFILE )
C*
	CHARACTER	snfile*(LLMXLN), gdfile*(LLMXLN),guess*(LLMXLN),
     +                  snparm*(LLMXLN), area*(LLMXLN), dattim*(LLMXLN),
     +			cgamma*(LLMXLN), csrch*(LLMXLN), pass*(LLMXLN),
     +			stndex*(LLMXLN), levels*(LLMXLN),
     +			vcoord*(LLMXLN), filnam*(LLMXLN),
     +			finam(MMFILE)*(LLMXLN), cqcntl*(LLMXLN),
     +			stid(LLDTMX)*8, guesfun*(LLMXLN),
     +                  coabnd*(LLMXLN), cproj*4
C*
	LOGICAL		done, respnd, proces, gsflag, mandat,
     +			found, mrgdat (MMFILE)
	CHARACTER	parms (MMPARM)*4, timdst (LLMXTM, MMFILE)*20,
     +			udattm*20, prmsn (MMPARM, MMFILE)*4,
     +			gdattm*20, stnprm (MMPARM)*4,
     +                  stncnd (MMPARM)*12, gsdttm*48, stn*8,
     +			prmcnd (MMPARM)*12, timfil (LLMXTM, MMFILE)*20,
     +			timall (LLMXTM)*20, stnam (MMPARM, LLDTMX)*8,
     +                  gsfunc (MMPARM)*72
	REAL		gltln (4), prjang (3)
	INTEGER		nqc (MMPARM, 2)
	INTEGER		iextnd (4), isnfln (MMFILE), ntimds (MMFILE)
        INTEGER         nprmsn (MMFILE), ivcin (MMFILE), ntfil (MMFILE),
     +			ivert (MMFILE)
C*
	REAL		slat (LLDTMX), slon (LLDTMX), srow (LLDTMX),
     +			scol (LLDTMX), cosslt (LLDTMX)
	REAL		gelat (LLMXGD), gelon (LLMXGD), coslat (LLMXGD)
        INTEGER		stnin(LLDTMX), gpin (LLMXGD)
C*
	REAL		rms  (LLOAGD), rlevel (LLMXLV), qcntl (LLOAGD)
	INTEGER		isn  (LLOAGD), iglevl (LLOAGD), igcord (LLOAGD)
	CHARACTER	gparm (LLOAGD)*4, voutc*4, gsparm (LLOAGD)*72
C*
	LOGICAL		extrap, eeee
C*
	PARAMETER	( ISZBUF = 300000 )
	REAL		data (ISZBUF)
C-----------------------------------------------------------------------
C*	Initialize TAE.
C
	CALL IP_INIT  ( respnd, iperr )
	IF  ( iperr .eq. 0 )  THEN
C
C*      Initialize grid library common area grdcmn.cmn
C
            CALL GD_INIT  ( iperr )
	    CALL GG_INIT  ( 1, iperr )
	END IF
	IF  ( iperr .eq. 0 )  THEN
	    done = .false.
	  ELSE
	    done = .true.
	END IF
	CALL IP_IDNT  ( 'OABSND', ier )
C
C*	Initialize the DG library.
C
	CALL DG_INTL ( ier )
C
C*	Main loop to read in TAE parameters and perform analysis.
C
	DO WHILE  ( .not. done )
C
C*	  Set flag to indicate processing will be done.
C
	  proces = .true.
C
C*	  Read in the variables from the TAE.
C
	  CALL OANINP  ( snfile, gdfile, guess, snparm, stndex, area,
     +			 dattim, levels, vcoord, cgamma, csrch, pass,
     +			 cqcntl, guesfun, coabnd, iperr )
C
C*	  Exit if there is an error
C
	  IF  ( iperr .ne. 0 )  THEN
	    done = .true.
	   ELSE
C
C*	    Decode values for gamma, search, npass and QC threshold.
C
	    IF  ( proces )  THEN
		CALL ST_RLST  ( cgamma, '/', .3, 1, gamma, n, ier )
C
C*		Check for extrapolation flag in CSRCH.
C
		CALL ST_LCUC ( csrch, csrch, ier )
		iextrp = INDEX ( csrch, 'EX' )
		IF ( iextrp .ne. 0 ) THEN
		     extrap = .true.
		ELSE
		     extrap = .false.
		END IF
C*
		CALL ST_RLST  ( csrch, '/', 20., 1, search, n, ier )
		CALL ST_ILST  ( pass, '/', 2, 1, npass, n, ier )
		IF  ( ( gamma .lt. 0. ) .or. ( gamma .gt. 1. ) )  THEN
		    gamma = .3
		    CALL ER_WMSG  ( 'OABSND', +1, cgamma, ier )
		  ELSE IF  ( gamma .eq. 0 )  THEN
		    CALL ER_WMSG  ( 'OABSND', +2, cgamma, ier )
		    npass = 1
		END IF
		IF  ( ( search .le. 0. ) .or. ( search .gt. 50. ) ) THEN
		    search = 20.
		    CALL ER_WMSG  ( 'OABSND', +3, csrch, ier )
		END IF
		IF  ( ( npass .lt. 1 ) .or. ( npass .gt. 5 ) )  THEN
		    npass = 2
		    CALL ER_WMSG  ( 'OABSND', +4, pass, ier )
		  ELSE IF  ( npass .ne. 2 )  THEN
		    CALL ER_WMSG  ( 'OABSND', +5, ' ', ier )
		END IF
C*
		CALL ST_RLST ( cqcntl, ';', 0., MMPARM, qcntl, nn, ier )
		DO  i = 1, nn
		    IF  ( qcntl (i) .lt. 0. .or. guess .eq. ' ' )
     +			  qcntl (i) = 0.
		END DO
	    END IF
C
C*	    Get list of requested level parameters.
C
	    IF ( proces ) THEN
	      CALL IN_PRMC  ( MMPARM, snparm, parms, prmcnd,
     +                        nparms, ier )
              IF ( nparms .eq. 0 .or. ier .ne. 0 ) THEN
                iret = -9
	        CALL ER_WMSG ( 'OABSND', iret, snparm, ier )
	        proces = .false.
	      END IF
	    END IF
C
C*          Get list of guess functions.
C
            IF ( proces ) THEN
                CALL IN_PARM ( MMPARM, guesfun, gsfunc, nguess, ier )
                DO i = 1, nparms
                    IF ( gsfunc (i) .eq. 'BLNK ' .or.
     +                   i .gt. nguess ) THEN
                        gsfunc (i) = parms (i)
                    END IF
                END DO
            END IF
C
C*	    Get levels.
C
	    CALL LV_INPT  ( levels, LLMXLV, vcoord, nlevel,
     +		            rlevel, levtyp, voutc,  ilvert,
     +			    mandat, iret )
C
C*	    Check that this is not level range.
C
	    IF  ( levtyp .ne. 1 )  THEN
	      nlevel = 0
	      iret   = -10
	      CALL ER_WMSG  ( 'OABSND', iret, ' ', ier )
	    END IF
C
C*	    Get list of station parameters.
C
	    CALL IN_PRMC  ( MMPARM, stndex, stnprm, stncnd,
     +			    nstnpm, ier )
C
C*	    Check that there are some computable parameters.
C
	    ngrid = nstnpm + nparms * nlevel
	    IF  ( ngrid .eq. 0 )  THEN
	      iret = -9
	      CALL ER_WMSG  ( 'OABSND', iret, ' ', ier )
	    END IF
	    IF ( iret .ne. 0 ) proces = .false.
C*
	    IF ( proces ) THEN
C
C*	      Save the level, vertical coordinate and parameter name for
C*	      each grid to be computed.
C
	      igrid = 0
	      DO  il = 1, nlevel
	        DO  ip = 1, nparms
	  	  igrid = igrid + 1
		  iglevl (igrid) = NINT ( rlevel (il) )
		  igcord (igrid) = ilvert
		  gparm  (igrid) = parms (ip)
		  gsparm (igrid) = gsfunc (ip)
		  qcntl  (igrid) = qcntl (ip)
	        END DO
   	      END DO
C*
	      DO  ip = 1, nstnpm
	        igrid = igrid + 1
	        iglevl (igrid) = 0
	        igcord (igrid) = 0
	        gparm  (igrid) = stnprm (ip)
		gsparm (igrid) = stnprm (ip)
	      END DO
C*
	    END IF
C
C*	    Open the sounding data files.
C
	    IF  ( proces )  THEN
		CALL FL_MFIL ( snfile, ' ', filnam, iret )
		IF ( iret .ne. 0 ) CALL ER_WMSG ( 'FL', iret, ' ', ier )
C
C*              Close all grid files in order to open surface file.
C
                CALL DG_NEND ( iret )
		CALL OANOPN  ( filnam, finam, timdst, ntimds,
     +			       nfiles, prmsn, nprmsn, ivcin, iret )
		IF  ( iret .ne. 0 )  proces = .false.
	    END IF
C
C*	    Get the analysis times; first check to see if an actual
C*          time is requested.  If an actual time is not requested,
C*          the first or last time in the first data set is used
C*          for the time search.
C
	    CALL ST_LCUC ( dattim, dattim, ier )
	    IF ( dattim .eq. 'LAST' ) THEN
	      dattim = timdst ( ntimds (1), 1 )
	    ELSE IF ( dattim .eq. 'FIRST' ) THEN
	      dattim = timdst ( 1, 1 )
	    END IF
C*
	    IF  ( proces )  THEN
	      i = 0
	      DO WHILE ( proces .and. i .lt. nfiles )
	        i = i + 1
		CALL TI_FIND  ( dattim, ntimds (i), timdst (1,i),
     +				udattm, ntfil (i), timfil (1,i), iret )
	      END DO
C
C*	      Get the list of OA times.
C
	      ntall = 0
	      DO  i = 1, nfiles
		nt = ntfil (i)
		DO  j = 1, nt
		    found = .false.
		    DO  k = 1, ntall
			IF  ( timfil (j,i) .eq. timall (k) )
     +			      found = .true.
		    END DO
C
		    IF  ( .not. found )  THEN
			ntall = ntall + 1
			timall (ntall) = timfil (j,i)
		    END IF
		END DO
	      END DO
	    END IF
C
C*	    Sort the time.
C
	    CALL TI_SORT ( ntall, timall, timall, ier )
C
C*	    Start the loop over times.
C
	    itime = 0
	    DO WHILE ( proces .and. itime .lt. ntall )
	      itime = itime + 1
              gdattm = timall ( itime )
C
C*	      Open the grid file.
C
	      CALL OA_GFIL  ( gdfile, guess, gdattm, area, gsflag,
     +	                      gsdttm, cproj, prjang, deltan, gltln,
     +                        kex, key, iextnd, iret )
	      kexy = kex * key
	      IF  ( iret .ne. 0 )  THEN
		proces = .false.
	        ELSE IF  ( kexy .gt. LLMXGD )  THEN
		  iret = -4
		  CALL ER_WMSG ( 'OABSND', iret, ' ', ier )
		  proces = .false.
	        ELSE
		  CALL OA_LTLN  ( kex, key, iextnd, gelat, gelon,
     +		                  coslat, iret )
		  IF  ( iret .ne. 0 )  proces = .false.
	      END IF
C
C*	      Set the bounds - tranformed to sys_N using the
C*            projection information retrieved from grid files.
C
	      IF ( itime .eq. 1 ) THEN
                  CALL ST_NULL ( coabnd, coabnd, lens, iret )
		  CALL ST_NULL ( cproj, cproj, lens, iret )
	          CALL OA_BNDSET ( coabnd, cproj, prjang, gltln, iret )
		  CALL ST_RNUL ( coabnd, coabnd, lens, iret )
		  CALL ST_RNUL ( cproj, cproj, lens, iret )
              END IF
C
C*	      Open input files and loop over the files to get the
C*	      data. First initialize NSTN, the number of stations.
C
	      nstn = 0
	      CALL DG_NEND ( ier )
              DO inn = 1, nfiles
	        nsav = nstn
C
C*		Open the upper-air file.
C
		CALL SN_OPNF  ( finam (inn), .false., isnfln (inn),
     +			   	iflsrc, nprmsn (inn), prmsn (1, inn),
     +				ivert (inn), mrgdat (inn), iret )
C
C*	    	Set the mandatory data only flag.
C
		CALL SN_MAND ( isnfln ( inn ), mandat, ier )
C
C*		Set the area for input data.
C
		IF  ( proces )  THEN
		    CALL LC_SARE ( area, isnfln (inn), stn, iret )
		    IF  ( iret .ne. 0 )  proces = .false.
C
C*                  Write warning if the area is not the DATA area.
C
                    IF  ( area .ne. 'DATA' )  THEN
	                CALL ER_WMSG  ( 'OABSND', +6, area, ier )
		    END IF
		END IF
C
C*		Get the valid parameters.
C
	        CALL OANPRM  ( ivcin (inn),
     +                         parms, prmcnd, nparms, stnprm,
     +		  	       stncnd, nstnpm, nlevel, prmsn (1, inn),
     +                         nprmsn (inn), mandat, iret )
	        IF  ( iret .ne. 0 )  THEN
C
C*	          Write message about non-contributing file.
C
	          CALL ER_WMSG ( 'OABSND', +10, finam (inn), ier )
	        ELSE
C
C*		    Read in the sounding data.
C
	            CALL SN_STIM  ( isnfln (inn), gdattm, ier )
	            CALL SN_BEGS  ( isnfln (inn), ier )
		    CALL OANDTA  ( isnfln (inn), nparms, rlevel, nlevel,
     +				   ilvert, nstnpm, ngrid, data, slat,
     +				   slon, cosslt, nstn, stid, iret )
	            IF ( iret .ne. 0 ) THEN
                      CALL ER_WMSG ( 'OABSND', +10, finam (inn), ier )
	              nstn = nsav
	            END IF
	        END IF
C
C*		Close the data file.
C
		CALL SN_CLOS  ( isnfln (inn), ier )
	      END DO
	      IF ( nstn .eq. 0 ) proces = .false.
C
C*	      Give user a chance to exit.
C
	      IF  ( proces ) THEN
	        CALL OANDSP  ( gdfile, gltln, iextnd, kex, key,
     +		  	       deltan, filnam, area, parms, nparms,
     +			       rlevel, nlevel, vcoord, stnprm, nstnpm,
     +			       gdattm, gamma, search, npass, guess,
     +			       gsflag, gsdttm, extrap, qcntl,
     +                         coabnd, iret )
	        IF  ( iret .ne. 0 ) proces = .false.
	      END IF
C
C*	      Analyze data.
C
	      IF  ( proces )  THEN
C
C*		    Write the time.
C
		    WRITE  ( 6, 1000 )  gdattm
1000		    FORMAT ( / ' Processing data at time ', A )
C
C*		    Continue unless there were too many or too few
C*		    stations.
C
		    IF  ( iret .eq. 0 )  THEN
C
C*			Set pointer for grid data in large buffer.
C
			ipsint = ( nstn * ngrid ) + 1
			ipgrid = ( 2 * ipsint ) - 1
C
C*			Check for room for all grid data.
C
			igsize = kexy * ngrid
			itotal = igsize + ipgrid
			IF  ( itotal .gt. ISZBUF )  THEN
			    iret = -5
			    CALL ER_WMSG  ( 'OABSND', iret, ' ', ier )
			END IF
		    END IF
C
C*		    Convert lat/lon to row/col.
C
		    IF  ( iret .eq. 0 )  THEN
			CALL OA_BOXC  ( slat, slon, nstn, iextnd, srow,
     +					scol, iret )
		    END IF
C
C*		    Compute weighting factor and search radius.
C
		    IF ( iret .eq. 0 )
     +		    CALL OA_WFSR  ( deltan, search, weight, srad, iret )
C
C*		    Initialize the grid.
C
		    IF  ( iret .eq. 0 )  THEN
			CALL OA_IGRD  ( ngrid, kex, key, kexy,
     +		                        iextnd, iglevl, igcord,
     +				        gsflag, gsdttm, gsparm,
     +                                  data ( ipgrid ), iret )
	            END IF
C
C*		    Compute differences from initial guess, if any.
C
		    IF  ( iret .eq. 0 )  THEN
			IF  ( gsflag )  THEN
			    CALL OA_GINT  ( ngrid, nstn, stid, data,
     +					    srow, scol, kex, key, qcntl,
     +					    data (ipgrid), iextnd,
     +					    data (ipsint), rms, isn,
     +					    nqc, stnam, iret )
			  ELSE
			    CALL OA_SINT  ( ngrid, nstn, data, srow,
     +					    scol, kex, key,
     +					    data (ipgrid), iextnd,
     +					    data (ipsint), rms, isn,
     +					    iret )
			END IF
		    END IF
C
	            IF ( iret .eq. 0 .and. gsflag ) THEN
C
C*			Write station IDs to terminal.
C
			CALL OANSTN   ( gparm, ngrid, iglevl, stnam,
     +					nqc, qcntl, iret )
C
C*			Write guess field RMS values to terminal.
C
		        ipass = 0
			CALL OANRMS  ( ipass, gparm, iglevl, ngrid,
     +				       rms, isn, ier )
                    END IF
C
C*		    Check out grid points/stations within the blocking bound
C
                    IF ( iret .eq. 0 ) THEN
		        CALL OA_BNDINB ( 'M', kexy, gelat, gelon, gpin, iret )
			CALL OA_BNDINB ( 'M', nstn, slat, slon, stnin, iret )
		    END IF
C
C*
                    IF ( iret .eq. 0 ) THEN

C
C*			Do analysis passes.
C
			DO  ipass = 1, npass
C
C*			    Adjust the weighting factor and search
C*			    radius after the first pass.
C
			    IF  ( ipass .eq. 2 )  THEN
				weight = weight * gamma
				srad   = srad   * gamma
			    END IF
C
C*                          Check for last pass. Use the "extrapolation"
C*                          procedure for all but the last pass. Let
C*                          the user determine what to do for the last
C*			    pass.
C
			    IF  ( ipass .eq. npass )  THEN
				eeee = extrap
			    ELSE
				eeee = .true.
			    END IF

C
C*			    Perform the analysis.
C
			    CALL OA_BARN  ( ngrid, weight, srad,
     +					    kexy, nstn, data (ipsint),
     +                                      slat, slon, gelat, gelon,
     +					    coslat, cosslt, extrap,
     +					    gsflag, gpin, stnin,
     +                                      isn, data (ipgrid), iret )
C
C*			    Interpolate analysis back to stations.
C
			    CALL OA_SINT  ( ngrid, nstn, data, srow,
     +					    scol, kex, key,
     +					    data (ipgrid), iextnd,
     +					    data (ipsint), rms, isn,
     +					    iret )
C
C*			    Write RMS values to terminal.
C
			    CALL OANRMS  ( ipass, gparm, iglevl, ngrid,
     +					   rms, isn, iret )
			END DO
C
C*			Write grid to grid file.
C
			CALL OA_WGRD  ( gdattm, ngrid, gparm,
     +					iglevl, igcord, data (ipgrid),
     +					kex, key, iextnd, iret )
		    END IF
	      END IF
	    END DO
C
C*	    Prompt for next analysis to be done.
C
	    CALL IP_DYNM  ( done, ier )
C
C*	    End of processing loop
C
	  END IF
	END DO
C
C*	Final error messages and exit from the TAE.
C
	IF  ( iperr .ne. 0 )  CALL ER_WMSG ( 'OABSND', iperr, ' ', ier )
	CALL IP_EXIT  ( iret )
C*
	END