text:
! ###########################################################
! #                                                         #
! #                    THE LIDORT FAMILY                    #
! #                                                         #
! #      (LInearized Discrete Ordinate Radiative Transfer)  #
! #       --         -        -        -         -          #
! #                                                         #
! ###########################################################

! ###########################################################
! #                                                         #
! #  Author :      Robert. J. D. Spurr                      #
! #                                                         #
! #  Address :     RT Solutions, Inc.                       #
! #                9 Channing Street                        #
! #                Cambridge, MA 02138, USA                 #
! #                                                         #
! #  Tel:          (617) 492 1183                           #
! #  Email :        rtsolutions@verizon.net                 #
! #                                                         #
! #  This Version :   3.7 F90                               #
! #  Release Date :   June 2014                             #
! #                                                         #
! #       NEW: THERMAL SUPPLEMENT INCLUDED    (3.2)         #
! #       NEW: OUTGOING SPHERICITY CORRECTION (3.2)         #
! #       NEW: TOTAL COLUMN JACOBIANS         (3.3)         #
! #       VLIDORT COMPATIBILITY               (3.4)         #
! #       THREADED/OPTIMIZED F90 code         (3.5)         #
! #       EXTERNAL SS / NEW I/O STRUCTURES    (3.6)         #
! #                                                         #
! #       Surface-leaving, BRDF Albedo-scaling     (3.7)    #
! #       Taylor series, BBF Jacobians, ThreadSafe (3.7)    #
! #                                                         #
! ###########################################################

!    #####################################################
!    #                                                   #
!    #   This Version of LIDORT comes with a GNU-style   #
!    #   license. Please read the license carefully.     #
!    #                                                   #
!    #####################################################

      module LIDORT_Sup_SS_def

!  Version 3.7, Internal threading removed, 02 May 2014

!  This module contains the following structures,
!  with intents :

!      LIDORT_Sup_SS_def  Intent(InOut)

      USE LIDORT_PARS, only : fpk, MAX_USER_LEVELS, MAX_GEOMETRIES, &
                              MAX_DIRECTIONS

      implicit none

! #####################################################################
! #####################################################################

      type LIDORT_Sup_SS

!  SS Intensity Results at all angles and optical depths

      REAL(fpk), dimension ( MAX_USER_LEVELS, MAX_GEOMETRIES, &
        MAX_DIRECTIONS ) :: TS_INTENSITY_SS

!  DB Intensity Results at all angles and optical depths

      REAL(fpk), dimension ( MAX_USER_LEVELS, MAX_GEOMETRIES ) :: &
        TS_INTENSITY_DB

      end type LIDORT_Sup_SS

! #####################################################################
! #####################################################################

!  EVERYTHING PUBLIC HERE

      PRIVATE
      PUBLIC :: LIDORT_Sup_SS

      end module LIDORT_Sup_SS_def

max_stars_repo_name: GEOS-ESM/AeroApps

max_issues_repo_name: GEOS-ESM/AeroApps

max_forks_repo_name: GEOS-ESM/AeroApps


text:
!====================================================================
!-----------------------------------------------------------------------
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-----------------------------------------------------------------------
!BOI
! !MODULE: m_VaiUtil -- Factory derived utilities for handling data from Vaisala rawinsondes
!
! !DESCRIPTION:
!     This module contains some routines for handling data from Vaisala
!     rawinsondes.  The utilities are based on algorithms implemented by
!     the factory as described in Vaisala, 1983 with more recent versions
!     of the lookup tables.  The computed temperature ($T_Cor$) and
!     height ($Z_Cor$) corrections are given so $T_2 = T_1 - T_Cor$ and
!     $Z_2 = Z_1 - Z_Cor$ where $T_1$ and $T_2$ are the temperatures
!     before and after the corrections and $Z_1$ and $Z_2$ are similarly
!     defined for heights.
!
! !REFERENCES:
!    \begin{description}
!    \item Vaisala, 1983: PTU Process in Microcora (internal document).
!          Vaisala, Helsinki, Finland, 22~pp.
!    \end{description}
!
! !INTERFACE:
      module      m_VaiUtil
      implicit    NONE
      private	! except

c      public :: RS80Reg  ! Vaisala RS80 regression model
      public ::
     .  ! VaiCor,          ! Vaisala correction scheme
     .  ! VentF,           ! Ventilation factor for the sensor
     .  ! VaiTab,          ! Factory temperature bias correction tables
     .  ! SunAlt,          ! Vaisala's formulae to calculate the sun's
     .                    !   elevation angle.
     .   RHTtoDP,         ! Converts relative humidity/air temperature
     .                    !   to dew point and
     .   DPTtoRH          ! ... dew point/air temperature to relative
     .                    !   humidity using Vaisala's formulae.
      public ::           ! Integer codes denoting ...
     .   RS80,            ! ... the RS80 model
     .   RS80_86,         ! ... the 1986 version
     .   RS80_93,         ! ... the 1993 version
     .   RS80_57H,        ! ... the 1993 version (for US rawinsondes)
     .   RS80_57H_bug,    !    ... with the bug in the elapsed
     .   RS90             ! ... the RS90 model
      public ::           ! List of ...
     .   Vai_rkxList,     ! ... WMO codes of Vaisala raob instrument types
     .   rkx_RS80_57H,    ! Instrument code for Vaisala R80_57H (US NWS)
     .   rkx_RS80_Marwin  ! ... Vaisala RS80/DigiCora or Marwins (Canada)
      !interface VentF
      !   module procedure
     .!      VentF_        ! Ventilation factor for the entire profile
     .!!      VentF_,       ! Ventilation factor for the entire profile
     .!!      VentF_PTK     ! ... for one section at a time
      !end interface
      !interface SunAlt
      !   module procedure
     .!      SunAlt_SYMDH, ! Input time arguments with respect to launch
     .!      SunAlt_NYMD,  ! ... in absolute time in calendar format
     .!      SunAlt_SJHr   ! ... and in minutes since synoptic Julian hour
      !end interface
!
! !REVISION HISTORY:
!     22Apr2002  C. Redder  Original code
!     06Feb2003  C. Redder  Added the integer codes, RS80_57H and
!                           RS80_57H_bug.
!     19Mar2003  C. Redder  Removed the integer code RS80_57H_bug.
!     23Sep2003  C. Redder  Added the integer code RS80_57H_bug back.
!                           Made the public entity a generic interface.
!     20Nov2006  C. Redder  Added the public routines, RHTtoDH and
!                           DPT_RH.and the public constants, Vai_rkxList,
!                           rkx_RS80_57H and rkx_RS80_Marwin.
!     02May2007  C. Redder  Removed all code with proprietary info
!EOI
!-----------------------------------------------------------------

      integer, parameter ::
     .   RS80         = 1,
     .   RS80_86      = 2,
     .   RS80_93      = 3,
     .   RS80_57H     = 4,
     .   RS80_57H_bug = 5,
     .   RS90         = 6

      real,    parameter ::
     .   BugFact_57H  = 5.0 / 3.0

      real,    parameter ::
     .   a_Claus      =  150.0,
     .   b_Claus      = 2711.5,
     .   T0_Claus     =  273.16

!     WMO instrument type code for ...
!     --------------------------------
      integer, parameter ::
     .   rkx_RS80_57H     = 52, ! ... NWS RS80-57H
     .   rkx_RS80_Marwin  = 61

!     List of WMO instrument code for Vaisala rawinsondes
!     ---------------------------------------------------
      integer, parameter ::
     .   Vai_rkxListSz = 10
      integer, parameter ::
     .   Vai_rkxList ( Vai_rkxListSz )
     ,                 = (/ 37, 52, 60, 61, 62, 63, 71, 72, 73, 74 /)
      contains

!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: RHTtoDP () --- Converts relative humidity and air temperature to dew point using Vaisala's formulae.
!
! !DESCRIPTION:
!     This routine converts a set of humidity values from relative humidity
!     and air temperature to dew point using Vaisala's formulae.  Note:
!     code in this version has been replaced to protect proprietary info
!     The dew point is set to the air temperature (i.e RH is assumed to
!     be 100 percent)
!
! !INTERFACE:
      pure subroutine RHTtoDP ( RH, T, DP )
      implicit NONE
!
! !INPUT PARAMETERS:
      real,       intent (in) ::
     .   RH  (:), ! relative humidity (%)
     .   T   (:)  ! air temperature (deg K)
!
! !OUTPUT PARAMETERS:
      real,       intent (out) ::
     .   DP  (:)  ! dew point (deg K)
!
!     Note: The minimum size of the arrays determines the
!           number of values to convert.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     09Nov2006  C. Redder   Original code.
!
! EOP
!-------------------------------------------------------------------------

      integer :: iHum, NHum
      real    :: DPi, Ti, RHi, K, Tdel, x, logrh

      NHum    = min ( size ( RH ), size ( T ), size ( DP ))

      do iHum  = 1, NHum
         RHi   = RH ( iHum ) / 100.0
         Ti    = T  ( iHum )
         DPi   = Ti
         DP ( iHum ) = DPi
      end do

      return
      end subroutine RHTtoDP
!......................................................................

!-------------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: DPTtoRH () --- Converts dew point and air temperature to relative humidity using Vaisala's formulae.
!
! !DESCRIPTION:
!     This routine converts a set of humidity values from dew point
!     and air temperature to relative humidity using Vaisala's formulae
!     Note: code in this version has been replaced to protect
!     proprietary info.  The return RH is set 100 percent
!
! !INTERFACE:
      pure subroutine DPTtoRH ( DP, T, RH )
      implicit NONE
!
! !INPUT PARAMETERS:
      real,       intent (in) ::
     .   DP  (:), ! dew point (deg K)
     .   T   (:)  ! air temperature (deg K)
!
! !OUTPUT PARAMETERS:
      real,       intent (out) ::
     .   RH  (:)  ! relative humidity (%)
!
!     Note: The minimum size of the arrays determines the
!           number of values to convert.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     09Nov2006  C. Redder   Original code.
!
! EOP
!-------------------------------------------------------------------------

      integer :: iHum, NHum
      real    :: DPi, Ti, RHi, Tdel, x, RHS

      NHum    = min ( size ( DP ), size ( T ), size ( RH ))

      do iHum = 1, NHum
         DPi  = DP ( iHum )
         Ti   = T  ( iHum )
         RHi  = 100.0
         RH ( iHum ) = RHi

      end do

      return
      end subroutine DPTtoRH
!...................................................................
      end module m_VaiUtil
!====================================================================

ext: f

max_stars_repo_name: GEOS-ESM/GEOSadas

max_issues_repo_name: GEOS-ESM/GEOSadas

max_forks_repo_name: GEOS-ESM/GEOSadas


text:
AFC was started by former Campus Cinema employee & movie buff Users/JamesHirsh James Hirsh during the Fall of 2002.  After Hirsh graduated in 2003, the club was run by Rob Roy and others in the Pirate Ship.  The club used to meet every Wednesday at 8:30 pm in 2 Wellman where they would show alternative films.  There has been little mention of its activity as of late, but we can always hope the club will pop up again. The http://alternativefilmclub.tripod.com/ Alternative Film Club has exposed many a student to all sorts of cool, entertaining films.

Recently, SPAC has added to its organization application forms questions regarding film viewings: are going to show a film or not? And if you do, what is the purpose? And most importantly: do you have permission to show the film? Have you contacted the people who own the copyright? So, this said, the Alternative Film Club is not likely to be revived.

Film buffs, check out Retro Film Revival.  Sacramentos Crest Theatre also runs a yearly event called http://www.trashfilmorgy.com/ Trash Film Orgy.

Heres a list of movies screened at AFC:
  The 400 Blows  French masterpiece by François Truffaut
  101 Reykjavik  Baltasar Kormákur, Icelands answer to Almodóvar
  A Clockwork Orange
  Alice  Modern Czechoslovakian adaption of Alice in Wonderland  animation/live action
  All About My Mother  directed by Spanish director Pedro Almodóvar
  Barfly  Screenplay by CHARLES BUKOWSKI, starring Mickey Rourke and Faye Dunaway
  Belle de Jour
  Better Off Dead  Starring a very young John Cusack
  Big Trouble in Little China  Directed by John Carpenter, starring Kurt Russell
  Brazil
  Cecil B. Demented
  City of Lost Children  1995, Marc Caro & JeanPierre Jeunet, quintuplets, orphans, cyclops, and circus freakswhats not to like
  Crumb
  CryBaby  John Waters directed, Johnny Depp starred
  Daughters of Darkness  aka Le Rouge aux lèvres, Eurotrash Horror, 1971
  Dawn of the Dead  the original 1978 film by George A. Romero
  Dead Man  Starring Johnny Depp, Crispen Glover, and Iggy Pop
  Delicatessen  trapped in a hotel with nothing to eat...
  Eraserhead  Double feature w/Un Chien Andalou
  Faster, Pussycat! Kill! Kill!  Russ Meyer directed, 1965.
  Freaks  the film that ruined Tod Brownings career, 1932, FIRST AFC SCREENING (10/9/02)
  The Good, the Bad, and the Ugly  Directed by Sergio Leone  Clint Eastwoods first big break in this Spaghetti Western
  Harold & Maude  PreValentines Day Show (2/13/03)
  Hedwig and the Angry Inch
  InfraMan  also known as JungGwok chiuyan!
  Manhattan
  Matador  Pedro Almodóvar directed, 1986
  Meet the Feebles  Directed by Peter Jackson, best described as the Muppets on Crack
  Repoman
  Rock n Roll High School
  Six String Samurai  Movie about Guitarist warriors  crazy flick.
  Spider Baby
  Spirited Away  Japanese Cartoon Classic of the 1990s
  The Texas Chainsaw Massacre  PreHalloween Jamboree
  This Is Spinal Tap
  Twin Peaks: Original Pilot Episode, U.S. Television Version
  Un Chien Andalou  surrealist Salvador Dali/Luis Buñuel movie with famous eyeball cutting scene
  Valley Girl

As quoted in The California Aggie (10/28/02):

Irene Park: They show interesting movies, not like the kind you see in the theaters. They are just amusing.

Liz Rard: They show a good variety of films, more than just what is considered mainstream. They show stuff not everyone will like. Its good to be offended.

Rachel Maximo: Its a good chance to meet people and make friends. Its a club for the people. You get to see movies you havent seen before for free. So come and watch  you have nothing to lose.

Anneliese Kaufman: Its not formal; you dont have to be a member; you dont have to do anything. Just come and watch the movies.

  Now why dont we have an unofficial Alternative Film Club? The meetings could be held anywhere like an apartments apartment or somebodies suite dorm at the Cuarto Residence Halls or something. Id think that as long as we do it in this form then we could claim its for home and personal use Im only an incoming freshman but Id think there would have to be a way to get around the rules a little bit here. ~Users/NathanielJarrett

20050901 15:25:07 nbsp Well, you can only fit so many people in a cuarto dorm, and the sound and picture will probably suck. What you can do is find out when 2 Wellman is unoccupied, and hold renegade AFC showings in there. However, if someone else has reserved the room or needs to clean it, you get kicked out. Users/ArlenAbraham

20050901 15:33:22 nbsp while I was busy with Moving Day I came across an old flyer for the old AFC with James, from 20022003, I believe. :p I brought my copy of This is Spinal Tap for viewing once, the French subtitles strangely got left on. Users/IrenePark

20050914 14:20:37 nbsp Im just back from spending 5 years in Central Europe and the Balkans and have a ton of foreign films Id love to show.  Im good for the underground approach at that hall.  Shall we set a meeting date and see if we can get a few people to show up to at least talk the idea over? Users/AaronBurda

20050915 13:20:41 nbsp The problem with scheduling renegade meetings is that its hard to know what the schedule of the room is going to be free. Users/ArlenAbraham

DateTime() Paraphrasing a lot of what Users/IrenePark sent me in an email, unless we want to get into a lot of legal stuff about publicly showing a film, contacting copy right owners, etc. we have to make our showings a non public viewing but at the same time push the boundaries of that as far as we possibly can.  We wouldnt be able to do promotion of any event officially but word of mouth would probably more than suffice (as well as the wiki).  In terms of location, since we cant officially ask for permission to use some equipment (that would require copyright permission) wed have to do it with a nod and a wink from either some professor/graduate student who knows the schedule of a room and can tell us when nothing will be going on there for 3 hours.  As long as there is no promotion, no donations/fees, no major problems for the department (including cleaning up) and nothing is official with the clubs organization we may be able to find somebody to help us.  Other than that I think wed have to have a really small club of max 15 people and watch films at somebodies place (not a bad alternative, although somewhat restrictive). Users/AaronBurda
  Im not sure that it would be impossible to get copyright permission from studios, but then, I havent tried yet.  but I mean, what do those Anime clubs do when they show their stuff (assuming thats what they do)? Need to do more research on policies and who holds what copyrights, etc. Users/IrenePark
    Pretty much everything the anime club shows isnt even licensed in the US. Users/JevanGray Jevan
  Good news, I did a little googling and found out how to get public use films for universities.  http://www.swank.com/ is the company that most organizations use.  You can get some legal info at http://www.haverford.edu/av/copyright/pubperform.html  According to swank, almost all major US universities have an account with them.  I searched their film archive and it seems they have a quite diverse selection.  It kind of seemed that it doesnt take long for them to ship you the DVD once you order it (a week max).  There werent any prices online except for The passion of Christ which you can show at your church to less than a thousand people for $75 for one showing.  Hopefully that is fairly representative of the prices.  I sent them an email asking how to get an account, how to find out what the prices are and if UC Davis already has an account.  If this works out then we could definitely do everything official and borrow an auditorium. Users/AaronBurda
    Swank is where the http://resnet.ucdavis.edu/Cable/movies.htm Student Housing Movie Channel gets their flicks. Users/JevanGray Jevan

20050915 22:55:11 nbsp Swank seems a bit extreem for a film club. Maybe what youre looking to do, Aaron, is revive Campus Cinema... Users/ArlenAbraham

  I think we have three option, any of which I would be cool for doing, the first is just going to somebodies apartment and watching a good film, people could take turns picking the film.  The problem of course is finding somebody with a large enough room, decent television and where we wont be disturbed.  Second we could do an underground showing in a free classroom/auditorium.  As discussed this has its downsides but may also be doable.  Third we can actually get the film from Swank and do a legit minor public showing, this would be feasible if we had at least 15 people, everybody paid $5 and presumably getting permission for a room then should be fairly easy.  This assumes the films are only $75 for minor public showings, which I think may not be the case.  Or lastly, we could do option three but just for The passion of Christ and show it over and over again each month..... ;) If Im missing anything....put it up.  Users/AaronBurda

20050917 09:48:56 nbsp What medium does swank give you? Is it a 35mm reel? Id be willing to pay $5 to see something in 35, but i dont (currently) know how to run a projector. That being said, someone at my IET Mediaworks place of work could probably teach me. Users/ArlenAbraham
  I would imagine that it would be DVD but that is just a guess.  We could probably get 35mm but it would be a lot more expensive.  When I think about it, its probably best to start with a minimalist approach (my initial enthusiasm for swank aside) and just get together and watch a few films in somebodies living room.  When we get to the point where its crowded we can look at expanding our little club. Users/AaronBurda

20050920 10:00:38 nbsp Since were starting out small, do we want to set a date/pick a film/pick a location for a first meeting? If we all show up at lecture hall A and theres a class or something, we can always walk to lecture hall B. Also, do we plan on doing any nonwiki/nonwordofmouth advertising? Users/ArlenAbraham
  Hi Arlen, sorry for not replying sooner.  A couple of friends of mine at the Graduate School of Managment have formed a small group that will be showing films using one of the classrooms and projectors.  The School didnt ask anything about copyright issues and it is in a classroom so hopefully that qualifies as a nonpublic showing.  Anyway, we watched one film last night (with popcorn and drinks) and everything seemed to go ok.  About eight people from the GSM showed up and a couple more have expressed interest.  I am going to start posting dates when well be having films on my wiki home page so if anybody is interested just show up (or contact me and Ill give you more info).  The films are picked each week by someone who thinks they have something good to show.  The GSM up to this point has said its fine, although they wanted to think about it so we may get the boot in the future... Users/AaronBurda

20051016 21:19:45 nbsp I came across this jewel and felt I had to share it with you, my Wiki friends. Read Rogers moving essay, then look at the printerfriendly (text) listing of the 100 greatest films: http://rogerebert.suntimes.com/apps/pbcs.dll/section?categorygreatmovies_first100 Users/SteveDavison

go here to see when rooms are available: http://cevs.ucdavis.edu/dept_cont/space/

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
Warren Adelbert Westgate (born Plainfield, NH, 12 September 1904, died Davis, CA, 20 November 1989) was a local businessman and genealogist. He and his wife Dorothy Esther Small (24 February 190521 August 1992) are both buried in the Plainfield Cemetery, Plainfield, NH, with his parents and many ancestors and cousins.

He donated his genealogical library to the Davis Genealogy Club.

He was Davis Citizen of the Year in 1972


text:
      subroutine static(a,b,n)
      real a(100,200), b(100,200)
      integer m, n, i, j, k
      do 1 i=3,n,2
          m = 2*n-1
          do 2 j=1,n-2*i
              if(4*i .gt. 2*j-3 .and. i-m .lt. n) then
                  do 3 k=i+1,n
                      a(n-j,i+j-m) = sqrt(b(2*i-1,3*j+1) + 1.)/2.
3                 continue
              end if
2         continue
1      continue
       end


text:
      subroutine intrp(nk, x, y, f, fx, fy, fxy, xx, yy, e, ex, ey, fl)
c
c***********************************************************************
c     interpolate eos tables using monotonized bicubic hermite
c     polynomials
c.......................................................................
c     called by: eos, opac
c***********************************************************************
c
      include'titan.imp'
      include'titan.par'
c
c.......................................................................
c     input:
      dimension x(nk), y(nk)
      dimension f(mxe, mye), fx(mxe, mye), fy(mxe, mye), fxy(mxe, mye)
c.......................................................................
c     output:
      dimension xx(nk), yy(nk), e(nk), ex(nk), ey(nk), fl(nk)
c.......................................................................
c     internal:
      dimension xi(mgr), yi(mgr), ii(mgr), jj(mgr)
c
      dimension f00(mgr), fx00(mgr), fy00(mgr), fxy00(mgr),
     .          f01(mgr), fx01(mgr), fy01(mgr), fxy01(mgr),
     .          f10(mgr), fx10(mgr), fy10(mgr), fxy10(mgr),
     .          f11(mgr), fx11(mgr), fy11(mgr), fxy11(mgr)
c
      dimension h1 (mgr), h2 (mgr), h3 (mgr), h4 (mgr),
     .          hx1(mgr), hx2(mgr), hx3(mgr), hx4(mgr)
c
      dimension g1 (mgr), g2 (mgr), g3 (mgr), g4 (mgr),
     .          gy1(mgr), gy2(mgr), gy3(mgr), gy4(mgr)
c
c-----------------------------------------------------------------------
c     assemble data needed for interpolation
c-----------------------------------------------------------------------
c
      do 1 k = 1, nk
c
c     forbid points off edges of table
c
      xx(k) = max( xmine, min( x(k), xmaxe ) )
      yy(k) = max( ymine, min( y(k), ymaxe ) )
c
c     flag points off edges of table
c
      fl(k) = cvmgt( 1.0D0, 0.0D0, x(k) .ne. xx(k) .or. y(k) .ne. yy(k))
c
c     compute indices of lower left corner of the cell
c
      ii(k) = min( int((xx(k) - xmine) / dxe + 1.00001D0), mxe - 1 )
      jj(k) = min( int((yy(k) - ymine) / dye + 1.00001D0), mye - 1 )
c
c     compute coordinates (xi, yi) relative to lower left corner of
c     cell in units of cell dimensions
c
      xi(k) = (xx(k) - xmine) / dxe - float( ii(k) - 1 )
      yi(k) = (yy(k) - ymine) / dye - float( jj(k) - 1 )
c
c     assemble f, fx, fy, fxy at corners of each cell
c
      f  00(k) = f  (ii(k)    , jj(k)    )
      fx 00(k) = fx (ii(k)    , jj(k)    )
      fy 00(k) = fy (ii(k)    , jj(k)    )
      fxy00(k) = fxy(ii(k)    , jj(k)    )
c
      f  01(k) = f  (ii(k)    , jj(k) + 1)
      fx 01(k) = fx (ii(k)    , jj(k) + 1)
      fy 01(k) = fy (ii(k)    , jj(k) + 1)
      fxy01(k) = fxy(ii(k)    , jj(k) + 1)
c
      f  10(k) = f  (ii(k) + 1, jj(k)    )
      fx 10(k) = fx (ii(k) + 1, jj(k)    )
      fy 10(k) = fy (ii(k) + 1, jj(k)    )
      fxy10(k) = fxy(ii(k) + 1, jj(k)    )
c
      f  11(k) = f  (ii(k) + 1, jj(k) + 1)
      fx 11(k) = fx (ii(k) + 1, jj(k) + 1)
      fy 11(k) = fy (ii(k) + 1, jj(k) + 1)
      fxy11(k) = fxy(ii(k) + 1, jj(k) + 1)
c
    1 continue
c
c-----------------------------------------------------------------------
c     evaluate interpolant
c-----------------------------------------------------------------------
c
      do 2 k = 1, nk
c
c     evaluate basis functions at (xi, yi)
c
      h 2(k) = - (2.0D0 * xi(k) - 3.0D0 ) * xi(k)**2
      g 2(k) = - (2.0D0 * yi(k) - 3.0D0 ) * yi(k)**2
      h 1(k) =    1.0D0 - h2(k)
      g 1(k) =    1.0D0 - g2(k)
      h 3(k) = ( (xi(k) - 2.0D0) * xi(k) + 1.0D0 ) * xi(k) * dxe
      g 3(k) = ( (yi(k) - 2.0D0) * yi(k) + 1.0D0 ) * yi(k) * dye
      h 4(k) =   (xi(k) - 1.0D0) * xi(k)**2 * dxe
      g 4(k) =   (yi(k) - 1.0D0) * yi(k)**2 * dye
      hx2(k) = - 6.0D0 * (xi(k) - 1.0D0) * xi(k) / dxe
      gy2(k) = - 6.0D0 * (yi(k) - 1.0D0) * yi(k) / dye
      hx1(k) = - hx2(k)
      gy1(k) = - gy2(k)
      hx3(k) = (3.0D0 * xi(k) - 4.0D0) * xi(k) + 1.0D0
      gy3(k) = (3.0D0 * yi(k) - 4.0D0) * yi(k) + 1.0D0
      hx4(k) = (3.0D0 * xi(k) - 2.0D0) * xi(k)
      gy4(k) = (3.0D0 * yi(k) - 2.0D0) * yi(k)
c
c     compute e, ex, and ey at (xx, yy)
c
      e (k) = g 1(k) * ( h 1(k) * f  00(k) + h 2(k) * f  10(k)
     .                 + h 3(k) * fx 00(k) + h 4(k) * fx 10(k) )
     .      + g 2(k) * ( h 1(k) * f  01(k) + h 2(k) * f  11(k)
     .                 + h 3(k) * fx 01(k) + h 4(k) * fx 11(k) )
     .      + g 3(k) * ( h 1(k) * fy 00(k) + h 2(k) * fy 10(k)
     .                 + h 3(k) * fxy00(k) + h 4(k) * fxy10(k) )
     .      + g 4(k) * ( h 1(k) * fy 01(k) + h 2(k) * fy 11(k)
     .                 + h 3(k) * fxy01(k) + h 4(k) * fxy11(k) )
c
      ex(k) = g 1(k) * ( hx1(k) * f  00(k) + hx2(k) * f  10(k)
     .                 + hx3(k) * fx 00(k) + hx4(k) * fx 10(k) )
     .      + g 2(k) * ( hx1(k) * f  01(k) + hx2(k) * f  11(k)
     .                 + hx3(k) * fx 01(k) + hx4(k) * fx 11(k) )
     .      + g 3(k) * ( hx1(k) * fy 00(k) + hx2(k) * fy 10(k)
     .                 + hx3(k) * fxy00(k) + hx4(k) * fxy10(k) )
     .      + g 4(k) * ( hx1(k) * fy 01(k) + hx2(k) * fy 11(k)
     .                 + hx3(k) * fxy01(k) + hx4(k) * fxy11(k) )
c
      ey(k) = gy1(k) * ( h 1(k) * f  00(k) + h 2(k) * f  10(k)
     .                 + h 3(k) * fx 00(k) + h 4(k) * fx 10(k) )
     .      + gy2(k) * ( h 1(k) * f  01(k) + h 2(k) * f  11(k)
     .                 + h 3(k) * fx 01(k) + h 4(k) * fx 11(k) )
     .      + gy3(k) * ( h 1(k) * fy 00(k) + h 2(k) * fy 10(k)
     .                 + h 3(k) * fxy00(k) + h 4(k) * fxy10(k) )
     .      + gy4(k) * ( h 1(k) * fy 01(k) + h 2(k) * fy 11(k)
     .                 + h 3(k) * fxy01(k) + h 4(k) * fxy11(k) )
c
    2 continue
c
      return
      end

max_stars_repo_name: matthewturk/lca-titan

max_issues_repo_name: matthewturk/lca-titan

max_forks_repo_name: matthewturk/lca-titan


text:
! RUN: %S/test_symbols.sh %s %t %f18
! Forward references in pointer initializers and TBP bindings.

!DEF: /m Module
module m
 implicit none
 abstract interface
  !DEF: /m/iface ABSTRACT, PUBLIC (Subroutine) Subprogram
  subroutine iface
  end subroutine
 end interface
 !DEF: /m/op1 POINTER, PUBLIC ObjectEntity REAL(4)
 real, pointer :: op1
 !DEF: /m/op2 POINTER, PUBLIC ObjectEntity REAL(4)
 !DEF: /m/null INTRINSIC, PUBLIC, PURE (Function) ProcEntity
 real, pointer :: op2 => null()
 !DEF: /m/op3 POINTER, PUBLIC ObjectEntity REAL(4)
 !DEF: /m/x PUBLIC, TARGET ObjectEntity REAL(4)
 real, pointer :: op3 => x
 !DEF: /m/op4 POINTER, PUBLIC ObjectEntity REAL(4)
 !DEF: /m/y PUBLIC, TARGET ObjectEntity REAL(4)
 real, pointer :: op4 => y(1)
 !REF: /m/iface
 !DEF: /m/pp1 EXTERNAL, POINTER, PUBLIC (Subroutine) ProcEntity
 procedure(iface), pointer :: pp1
 !REF: /m/iface
 !DEF: /m/pp2 EXTERNAL, POINTER, PUBLIC (Subroutine) ProcEntity
 !REF: /m/null
 procedure(iface), pointer :: pp2 => null()
 !REF: /m/iface
 !DEF: /m/pp3 EXTERNAL, POINTER, PUBLIC (Subroutine) ProcEntity
 !DEF: /m/ext1 EXTERNAL, PUBLIC (Subroutine) ProcEntity
 procedure(iface), pointer :: pp3 => ext1
 !REF: /m/iface
 !DEF: /m/pp4 EXTERNAL, POINTER, PUBLIC (Subroutine) ProcEntity
 !DEF: /m/ext2 EXTERNAL, PUBLIC (Subroutine) Subprogram
 procedure(iface), pointer :: pp4 => ext2
 !REF: /m/iface
 !DEF: /m/pp5 EXTERNAL, POINTER, PUBLIC (Subroutine) ProcEntity
 !DEF: /m/ext3 EXTERNAL, PUBLIC (Subroutine) ProcEntity
 procedure(iface), pointer :: pp5 => ext3
 !REF: /m/iface
 !DEF: /m/pp6 EXTERNAL, POINTER, PUBLIC (Subroutine) ProcEntity
 !DEF: /m/modproc1 PUBLIC (Subroutine) Subprogram
 procedure(iface), pointer :: pp6 => modproc1
 !DEF: /m/t1 PUBLIC DerivedType
 type :: t1
  !DEF: /m/t1/opc1 POINTER ObjectEntity REAL(4)
  real, pointer :: opc1
  !DEF: /m/t1/opc2 POINTER ObjectEntity REAL(4)
  !REF: /m/null
  real, pointer :: opc2 => null()
  !DEF: /m/t1/opc3 POINTER ObjectEntity REAL(4)
  !REF: /m/x
  real, pointer :: opc3 => x
  !DEF: /m/t1/opc4 POINTER ObjectEntity REAL(4)
  !REF: /m/y
  real, pointer :: opc4 => y(1)
  !REF: /m/iface
  !DEF: /m/t1/ppc1 NOPASS, POINTER (Subroutine) ProcEntity
  procedure(iface), nopass, pointer :: ppc1
  !REF: /m/iface
  !DEF: /m/t1/ppc2 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/null
  procedure(iface), nopass, pointer :: ppc2 => null()
  !REF: /m/iface
  !DEF: /m/t1/ppc3 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/ext1
  procedure(iface), nopass, pointer :: ppc3 => ext1
  !REF: /m/iface
  !DEF: /m/t1/ppc4 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/ext2
  procedure(iface), nopass, pointer :: ppc4 => ext2
  !REF: /m/iface
  !DEF: /m/t1/ppc5 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/ext3
  procedure(iface), nopass, pointer :: ppc5 => ext3
  !REF: /m/iface
  !DEF: /m/t1/ppc6 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/modproc1
  procedure(iface), nopass, pointer :: ppc6 => modproc1
 contains
  !DEF: /m/t1/b2 NOPASS ProcBinding
  !REF: /m/ext2
  procedure, nopass :: b2 => ext2
  !DEF: /m/t1/b3 NOPASS ProcBinding
  !REF: /m/ext3
  procedure, nopass :: b3 => ext3
  !DEF: /m/t1/b4 NOPASS ProcBinding
  !REF: /m/modproc1
  procedure, nopass :: b4 => modproc1
 end type
 !DEF: /m/pdt1 PUBLIC DerivedType
 !DEF: /m/pdt1/k TypeParam INTEGER(4)
 type :: pdt1(k)
  !REF: /m/pdt1/k
  integer, kind :: k
  !DEF: /m/pdt1/opc1 POINTER ObjectEntity REAL(4)
  real, pointer :: opc1
  !DEF: /m/pdt1/opc2 POINTER ObjectEntity REAL(4)
  !REF: /m/null
  real, pointer :: opc2 => null()
  !DEF: /m/pdt1/opc3 POINTER ObjectEntity REAL(4)
  !REF: /m/x
  real, pointer :: opc3 => x
  !DEF: /m/pdt1/opc4 POINTER ObjectEntity REAL(4)
  !REF: /m/y
  !REF: /m/pdt1/k
  real, pointer :: opc4 => y(k)
  !REF: /m/iface
  !DEF: /m/pdt1/ppc1 NOPASS, POINTER (Subroutine) ProcEntity
  procedure(iface), nopass, pointer :: ppc1
  !REF: /m/iface
  !DEF: /m/pdt1/ppc2 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/null
  procedure(iface), nopass, pointer :: ppc2 => null()
  !REF: /m/iface
  !DEF: /m/pdt1/ppc3 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/ext1
  procedure(iface), nopass, pointer :: ppc3 => ext1
  !REF: /m/iface
  !DEF: /m/pdt1/ppc4 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/ext2
  procedure(iface), nopass, pointer :: ppc4 => ext2
  !REF: /m/iface
  !DEF: /m/pdt1/ppc5 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/ext3
  procedure(iface), nopass, pointer :: ppc5 => ext3
  !REF: /m/iface
  !DEF: /m/pdt1/ppc6 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/modproc1
  procedure(iface), nopass, pointer :: ppc6 => modproc1
 contains
  !DEF: /m/pdt1/b2 NOPASS ProcBinding
  !REF: /m/ext2
  procedure, nopass :: b2 => ext2
  !DEF: /m/pdt1/b3 NOPASS ProcBinding
  !REF: /m/ext3
  procedure, nopass :: b3 => ext3
  !DEF: /m/pdt1/b4 NOPASS ProcBinding
  !REF: /m/modproc1
  procedure, nopass :: b4 => modproc1
 end type
 !REF: /m/t1
 !DEF: /m/t1x PUBLIC ObjectEntity TYPE(t1)
 type(t1) :: t1x
 !REF: /m/pdt1
 !DEF: /m/pdt1x PUBLIC ObjectEntity TYPE(pdt1(k=1_4))
 type(pdt1(1)) :: pdt1x
 !REF: /m/x
 !REF: /m/y
 real, target :: x, y(2)
 !REF: /m/ext1
 external :: ext1
 !REF: /m/iface
 !REF: /m/ext3
 procedure(iface) :: ext3
 interface
  !REF: /m/ext2
  subroutine ext2
  end subroutine
 end interface
 !DEF: /m/op10 POINTER, PUBLIC ObjectEntity REAL(4)
 !REF: /m/x
 real, pointer :: op10 => x
 !DEF: /m/op11 POINTER, PUBLIC ObjectEntity REAL(4)
 !REF: /m/y
 real, pointer :: op11 => y(1)
 !REF: /m/iface
 !DEF: /m/pp10 EXTERNAL, POINTER, PUBLIC (Subroutine) ProcEntity
 !REF: /m/ext1
 procedure(iface), pointer :: pp10 => ext1
 !REF: /m/iface
 !DEF: /m/pp11 EXTERNAL, POINTER, PUBLIC (Subroutine) ProcEntity
 !REF: /m/ext2
 procedure(iface), pointer :: pp11 => ext2
 !DEF: /m/t2 PUBLIC DerivedType
 type :: t2
  !DEF: /m/t2/opc10 POINTER ObjectEntity REAL(4)
  !REF: /m/x
  real, pointer :: opc10 => x
  !DEF: /m/t2/opc11 POINTER ObjectEntity REAL(4)
  !REF: /m/y
  real, pointer :: opc11 => y(1)
  !REF: /m/iface
  !DEF: /m/t2/ppc10 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/ext1
  procedure(iface), nopass, pointer :: ppc10 => ext1
  !REF: /m/iface
  !DEF: /m/t2/ppc11 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/ext2
  procedure(iface), nopass, pointer :: ppc11 => ext2
 contains
  !DEF: /m/t2/b10 NOPASS ProcBinding
  !REF: /m/ext2
  procedure, nopass :: b10 => ext2
  !DEF: /m/t2/b11 NOPASS ProcBinding
  !REF: /m/ext3
  procedure, nopass :: b11 => ext3
 end type
 !DEF: /m/pdt2 PUBLIC DerivedType
 !DEF: /m/pdt2/k TypeParam INTEGER(4)
 type :: pdt2(k)
  !REF: /m/pdt2/k
  integer, kind :: k
  !DEF: /m/pdt2/opc10 POINTER ObjectEntity REAL(4)
  !REF: /m/x
  real, pointer :: opc10 => x
  !DEF: /m/pdt2/opc11 POINTER ObjectEntity REAL(4)
  !REF: /m/y
  !REF: /m/pdt2/k
  real, pointer :: opc11 => y(k)
  !REF: /m/iface
  !DEF: /m/pdt2/ppc10 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/ext1
  procedure(iface), nopass, pointer :: ppc10 => ext1
  !REF: /m/iface
  !DEF: /m/pdt2/ppc11 NOPASS, POINTER (Subroutine) ProcEntity
  !REF: /m/ext2
  procedure(iface), nopass, pointer :: ppc11 => ext2
 contains
  !DEF: /m/pdt2/b10 NOPASS ProcBinding
  !REF: /m/ext2
  procedure, nopass :: b10 => ext2
  !DEF: /m/pdt2/b11 NOPASS ProcBinding
  !REF: /m/ext3
  procedure, nopass :: b11 => ext3
 end type
 !REF: /m/t2
 !DEF: /m/t2x PUBLIC ObjectEntity TYPE(t2)
 type(t2) :: t2x
 !REF: /m/pdt2
 !DEF: /m/pdt2x PUBLIC ObjectEntity TYPE(pdt2(k=1_4))
 type(pdt2(1)) :: pdt2x
contains
 !REF: /m/modproc1
 subroutine modproc1
 end subroutine
end module
!DEF: /ext1 (Subroutine) Subprogram
subroutine ext1
end subroutine
!DEF: /ext2 (Subroutine) Subprogram
subroutine ext2
end subroutine
!DEF: /ext3 (Subroutine) Subprogram
subroutine ext3
end subroutine
!DEF: /main MainProgram
program main
 !REF: /m
 use :: m
 !DEF: /main/pdt1 Use
 !DEF: /main/pdt1y ObjectEntity TYPE(pdt1(k=2_4))
 type(pdt1(2)) :: pdt1y
 !DEF: /main/pdt2 Use
 !DEF: /main/pdt2y ObjectEntity TYPE(pdt2(k=2_4))
 type(pdt2(2)) :: pdt2y
 print *, "compiled"
end program

max_stars_repo_name: MochalovaAn/llvm

max_issues_repo_name: MochalovaAn/llvm

max_forks_repo_name: MochalovaAn/llvm


text:
C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 04.03.01/asfset                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE ASFSET (ASFIX, ASFTAB, START, END)

C  ASFSET is used to set a sequence of ASFs to values specified in
C  an indicated row of the ASF table.

C  Input parameters:
C    ASFIX     : the row (1-5) of the table from which values are taken
C    ASFTAB    : table containing ASF values
C    START,END : first,last column in the table (corresponding to aspect
C                identifier) from which values are taken.

C aspect identifier
      INTEGER    PLN,      PEDCI
      PARAMETER (PLN  = 0, PEDCI=17)

      INTEGER    ASFIX, IX, START, END, ASFTAB(5, PLN:PEDCI)

      DO 100 IX = START,END
         CALL PSIASF (IX, ASFTAB(ASFIX, IX))
100   CONTINUE

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 04.03.01/asfint                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE ASFINT (VIS, VISI, VICI, NUMLIN, NGPRIM)

C  ASFINT draws a set of fill areas and fill area sets to illustrate
C  the effect of various interior aspect source flags.

C  Input parameters:
C    VIS    : interior style to be displayed/suppressed
C    VISI   : interior style index to be displayed/suppressed
C    VICI   : interior color index to be displayed/suppressed
C    NUMLIN : number of primitives to display
C  Output parameters:
C    NGPRIM : which primitive is drawn differently

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

C aspect identifier
      INTEGER    PTXCI,    PIS,      PISI,     PICI,     PEDFG
      PARAMETER (PTXCI=10, PIS  =11, PISI =12, PICI =13, PEDFG=14)

C aspect source
C                bundled     individual
      INTEGER    PBUNDL,     PINDIV
      PARAMETER (PBUNDL = 0, PINDIV = 1)

C interior style
      INTEGER    PHOLLO,   PSOLID,   PPATTR,   PHATCH,   PISEMP
      PARAMETER (PHOLLO=0, PSOLID=1, PPATTR=2, PHATCH=3, PISEMP=4)
C off/on switch for edge flag and error handling mode
      INTEGER    POFF,     PON
      PARAMETER (POFF = 0, PON = 1)

C aspect visibility
      INTEGER    DISPLY,     SUPPRS
      PARAMETER (DISPLY = 0, SUPPRS = 1)

      INTEGER    VIS  (DISPLY:SUPPRS), NPTS(1), IBSW, IPRIM, NEXT
      INTEGER    VISI (DISPLY:SUPPRS), VICI (DISPLY:SUPPRS)
      INTEGER    IX, NUMLIN,NGPRIM, RNDINT, STYSRC,IIXSRC,COLSRC
      INTEGER    P1(10),P2(10),P3(10)

      REAL       XA(10),YA(10),ZA(10), YTOP,YLOC,YINCR

C  use IBSW to switch individual/bundled
      IBSW = PINDIV+PBUNDL
C  primitive to be drawn incorrectly
      NGPRIM = RNDINT (1,NUMLIN)
      YINCR = 1.0 / (NUMLIN+1)
      YTOP  = 1-YINCR
      YLOC = YTOP
      CALL NUMLAB (NUMLIN, 0.15, YTOP, YINCR)
      IPRIM = 1
      XA(1) = 0.2
      XA(2) = 0.2
      XA(3) = 0.8
      XA(4) = 0.8
      ZA(1) = 0.5
      ZA(2) = 0.5
      ZA(3) = 0.5
      ZA(4) = 0.5
C  set edge flag = OFF
      CALL PSIASF (PEDFG, PINDIV)
      CALL PSEDFG (POFF)
      NPTS(1) = 4
C  ensure both individual and bundle are picked for each aspect
      CALL RNPERM (NUMLIN, P1)
      CALL RNPERM (NUMLIN, P2)
      CALL RNPERM (NUMLIN, P3)

C  loop to draw primitives
      DO 100 IX = 1,NUMLIN
C  randomly pick source for aspects:
         STYSRC = MOD (P1(IX), 2)
         IIXSRC = MOD (P2(IX), 2)
         COLSRC = MOD (P3(IX), 2)

C  set bundle #ix to displayed aspects, for BUNDLED source
C               and suppressed aspects, for INDIVIDUAL source
         CALL PSIR (WKID, IX, VIS(STYSRC), VISI(IIXSRC), VICI(COLSRC))
         CALL PSII (IX)
C  set individual attributes
C                    to displayed aspects, for INDIVIDUAL source
C                  and suppressed aspects, for BUNDLED source
         CALL PSIS  (VIS (IBSW-STYSRC))
         CALL PSISI (VISI(IBSW-IIXSRC))
         CALL PSICI (VICI(IBSW-COLSRC))
C  set ASF flags in accordance with: stysrc, iixsrc, colsrc
         CALL PSIASF (PIS,  STYSRC)
         CALL PSIASF (PISI, IIXSRC)
         CALL PSIASF (PICI, COLSRC)

         IF (IX .EQ. NGPRIM) THEN
C  set ASF flag NOT in accordance with typsrc
            CALL PSIASF (PIS,  IBSW-STYSRC)
            CALL PSIASF (PISI, IBSW-IIXSRC)
            CALL PSIASF (PICI, IBSW-COLSRC)
            NEXT = IPRIM
         ELSE
            NEXT = IPRIM+1
         ENDIF

         YA(1) = YLOC + 0.3*YINCR
         YA(2) = YLOC - 0.3*YINCR
         YA(3) = YLOC - 0.3*YINCR
         YA(4) = YLOC + 0.3*YINCR

         IF (IPRIM .EQ. 1) THEN
            CALL PFA (4, XA,YA)
         ELSEIF (IPRIM .EQ. 2) THEN
            CALL PFA3 (4, XA,YA,ZA)
         ELSEIF (IPRIM .EQ. 3) THEN
            CALL PFAS (1, NPTS, XA,YA)
         ELSEIF (IPRIM .EQ. 4) THEN
            CALL PFAS3 (1, NPTS, XA,YA,ZA)
         ELSE
            CALL PFA (4, XA,YA)
         ENDIF
         YLOC = YLOC-YINCR
         IPRIM = NEXT

C  next ix
100   CONTINUE
      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 04.03.01/intinh                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE INTINH (ASFTAB, START, END, PERM)

C  INTINH creates the structure network for testing interior ASFs.

C  Input parameters:
C    ASFTAB    : table containing ASF values
C    START,END : first,last column in the table (corresponding to aspect
C                identifier) from which values are taken.
C  Output parameters:
C    PERM      : permutation of locations used for structure network

C aspect identifier
      INTEGER    PLN,      PEDFG,    PEDCI
      PARAMETER (PLN  = 0, PEDFG=14, PEDCI=17)

C aspect source
C                bundled     individual
      INTEGER    PBUNDL,     PINDIV
      PARAMETER (PBUNDL = 0, PINDIV = 1)

C composition type
C                preconcatenate  postconcatenate  replace
      INTEGER    PCPRE,          PCPOST,          PCREPL
      PARAMETER (PCPRE = 0,      PCPOST = 1,      PCREPL = 2)

C off/on switch for edge flag and error handling mode
      INTEGER    POFF,     PON
      PARAMETER (POFF = 0, PON = 1)

      INTEGER    START,END, ASFTAB(5, PLN:PEDCI), PERM(14), ERRIND
      INTEGER    IX, EXPDX(14), SIZ

      REAL       XACT(4),XEXP(4),XFORM(3,3), YLOCEL

C  x-location of actual/expected interiors
      CALL SETRVS ('0.2,0.2,0.5,0.5', XACT, SIZ)
      CALL SETRVS ('0.6,0.6,0.9,0.9', XEXP, SIZ)

C  randomize order of interiors
      CALL RN1SHF (14, PERM)

C  set edge flag = OFF
      CALL PSIASF (PEDFG, PINDIV)
      CALL PSEDFG (POFF)

C  set up CSS as described above
      CALL LOCINT (PERM(1), XACT)
      CALL PEXST  (102)
      CALL LOCINT (PERM(9), XACT)
      CALL ASFSET (2, ASFTAB, START,END)
      CALL LOCINT (PERM(10), XACT)
      CALL XFINH  (PERM)

C  execute 104
      CALL PEXST (104)
C  now, cancel out transformation ...
      CALL IDMAT (3, XFORM)
      CALL PSLMT (XFORM, PCREPL)

      CALL LOCINT (PERM(13), XACT)
      CALL LOCINT (PERM(14), XACT)
      CALL PEXST (105)
      CALL PCLST

C  structure #102
      CALL POPST (102)
      CALL LOCINT (PERM(2), XACT)
      CALL ASFSET (3, ASFTAB, START,END)
      CALL PEXST (103)
      CALL LOCINT (PERM(8), XACT)
      CALL PCLST

C  structure #103
      CALL POPST (103)
      CALL LOCINT (PERM(3), XACT)
      CALL ASFSET (4, ASFTAB, START,END)
      CALL LOCINT (PERM(4), XACT)
      CALL PEXST (104)
      CALL LOCINT (PERM(7), XACT)
      CALL PCLST

C  structure #104
      CALL POPST (104)
C  polymarker 5 / 11
      CALL LOCINT (PERM(5), XACT)
      CALL ASFSET (5, ASFTAB, START,END)
C  polymarker 6 / 12
      CALL LOCINT (PERM(6), XACT)
      CALL PCLST

C  Expected attributes: structure #105
      CALL POPST (105)
C  values for expected ASFs:
      CALL SETVAL ('1,1,3,4,4,5,4,3,1,2,2,5,2,4', EXPDX)
      DO 400 IX =1,14
         CALL ASFSET (EXPDX(IX), ASFTAB, START,END)
         CALL LOCINT (PERM(IX), XEXP)
400   CONTINUE

C  draw labels
      CALL NUMLAB (14, 0.15, YLOCEL(1), 1.0/15)
      CALL PCLST

      END


text:
C
C-----------------------------------------------------------------------
C
C   Model for the plasmaspheric electron temperature based on Akebono
C   TED data:
C     I. Kutiev, K. Oyama, T. Abe, and P. Marinov, Plasamsphere
C         electron temperature model based on Akebono data, Advances in
C         Space Research 33, 975-979, 2004
C
C   This file includes the model subroutine TE3ARG and a short driver
C   program
C
C-----------------------------------------------------------------------
C   Subroutine TE3ARG and main program
C
C   Examples:
C      IN: TLOC, GMLAT, HEIGHT     OUT: TLOC, GMLAT, Height, Te
C               14,-50,1000        14.00   -50.00  1000.00   5283.16
C               14,-70,5000        14.00   -70.00  5000.00   3935.66
C               14,-71,5000        14.00   -71.00  5000.00    3935.7 warning 1
C               14,70,5000         14.00    70.00  5000.00   3935.66
C               14,-80,0           14.00   -80.00     0.00    2764.0 warning 2
C               warning 1 indicates one input parameter out of range
C               warning 2 indicates two input parameters out of range
C-----------------------------------------------------------------------
C
C     2007/01/10
C     2005/07/17
C     2002/04/28
C   		Pencho G. Marinov
C   		Institute for Parallel Processing
C   		Bulgarian Academy of Science
C   		E-mail: pencho@bas.bg
C
C     1) The Polynomial Approximation
C
C     2) 3-dimensioned X_space
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
      PROGRAM PGMIK
C
      IMPLICIT REAL*4 (A-H,O-Z)
      IMPLICIT INTEGER*2 (I-N)
C
      COMMON /BLBAS/ XL(3),XR(3),SL(3),SR(3),NBAS(2,3),MBAS(3)
      COMMON /BLDAT/ BUFF(50)
      COMMON /BLWRK/ WA(216),WB(216),WC(6,6,6)
      COMMON /BLCFN/ Z(216),A(216),CFN(6,6,6),NCFN(20)
      COMMON /BLEPS/ ERS(20), NITER(20), O, E
      COMMON /BLIOT/ NINP1, NINP2, NOUT1, NOUT2, NTAB1, NTAB2
C
      LOGICAL IOCHECK
      CHARACTER*64 NAME(10), NAMP(10)
      integer*4 n,n0
c
      data NR, NW, npgm /1,2,4/
C
      DATA  NAME(1)/'AKEBONO.INP'/
      DATA  NAME(2)/'AKEBONO.OUT'/
      DATA  NAME(3)/'AKEBONO.INF'/
      DATA  NAME(4)/'AKEBONO.CFN'/
      DATA  NAMP(7)/'(1X,A)                  '/
      DATA  NAMP(8)/'(1X,3F9.2, F10.2  )     '/
      DATA  NAMP(9)/'(1X,3F9.2,F10.1,8H warning,I2)'/
C
         n=0
         n0=0
         write(*,*) 'LT [0.0 - 24.0], GMLAT [-70 to +70], HEIGHT ',
     &   '[1000-10,000 km] (# to end)'
C
  200 CONTINUE
         READ (* , *, ERR=201, END=201) TLOC, GMLAT, HEIGHT
         n=n+1
         call TE3ARG(TLOC, GMLAT, HEIGHT, TE, ierr)
         if (ierr.GT.0) then
            n0=n0+1
            WRITE( *,NAMP(9)) TLOC, GMLAT, HEIGHT, TE, ierr
         else
            WRITE(* ,NAMP(8)) TLOC, GMLAT, HEIGHT, TE
         endif
         GOTO 200
  201 CONTINUE
C
      write(*,*) n , ' - rows processed  '
      write(*,*) n0, ' - warnings occured '
C
 301  continue
      STOP '  '
C
      END
C
C
       SUBROUTINE TE3ARG(TLOC,GMLAT,HEIGHT,TE,ierr)
C--------------------------------------------------------------------------
C      Input parameters are:
C          TLOC solar local time in hours (0-24)
C          GMLAT magnetic latitude in degrees (-70 - +70)
C          HEIGHT altitude in km (1000 - 10,000)
C          If input parameters is outside valid range it will be set to the
C          nearest range boundary, e.g., +80 to +70
C      Output parameters are:
C          TE  electron temperature in K
C          ierr  # of cases of input parameter ouside valid range
C--------------------------------------------------------------------------
C
C
      IMPLICIT REAL*4 (A-H,O-Z)
      IMPLICIT INTEGER*2  (I-N)
C
      COMMON /BLBAS/ XL(3),XR(3),SL(3),SR(3),NBAS(2,3),MBAS(3)
      COMMON /BLDAT/ BUFF(50)
      COMMON /BLCFN/ Z(216),A(216),CFN(6,6,6),NCFN(20)
      COMMON /BLEPS/ ERS(20), NITER(20), O, E
C
      CHARACTER*64 FORMD,FORME
C
      FFL(V)=(2.0D0-V-3*V*V+2*V**3)*0.5D0
      FFR(V)=(      V+3*V*V-2*V**3)*0.5D0
C
      A(11) = TLOC
      A(12) = GMLAT
      A(13) = HEIGHT
C
C     Test if input data are in correct range.
C          if NOT then ierr>0
C
         ierr=0
         A(1)=A(11)
         A(2)=A(12)
         A(3)=A(13)
         IF (A(11).LT.(0.0)) THEN
            A(1)=0.0
            ierr=ierr+1
         ENDIF
         IF (A(11).GT.(24.)) THEN
            A(1)=24.0
            ierr=ierr+1
         ENDIF
         IF ( (A(12).LT.XL(2)).AND.(A(12).LT.O) ) A(2)=-A(12)
         IF (A( 2).GT.XR(2)) THEN
            A(2)=XR(2)
            ierr=ierr+1
         ENDIF
         IF (A(13).LT.XL(3)) THEN
            A(3)=XL(3)
            ierr=ierr+1
         ENDIF
         IF (A(13).GT.XR(3)) THEN
            A(3)=XR(3)
            ierr=ierr+1
         ENDIF
C
         DO J=2,3
            BUFF(J)=SL(J)+(A(J)-XL(J))/(XR(J)-XL(J))*(SR(J)-SL(J))
         ENDDO
         BUFF(1)=SL(1)
         R1 = R(BUFF)
         BUFF(1)=SR(1)
         R2 = R(BUFF)
         IF ((A(1)-9.0)*(16.0-A(1)).GE.O) THEN
            BUFF(4) = R2
            GOTO 202
         ENDIF
         IF ( (A(1).GE.(22.0)).OR.(A(1).LE.(4.0)) ) THEN
            BUFF(4) = R1
            GOTO 202
         ENDIF
         IF ((A(1)-4.0)*(9.0-A(1)).GE.O) THEN
            SS = (A(1)-4.0)/5.0
            BUFF(4) = R1*FFL(SS)+R2*FFR(SS)
            GOTO 202
         ENDIF
         IF ((A(1)-16.0)*(22.0-A(1)).GE.O) THEN
            SS = (A(1)-16.0)/6.0
            BUFF(4) = R2*FFL(SS)+R1*FFR(SS)
            GOTO 202
         ENDIF
C
  202 CONTINUE
         A   (4)=BUFF(4)
         A  (14)=   A(4)*FLOAT(MBAS(1))
         TE = A(14)
C
C
      RETURN
      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
      REAL*4 FUNCTION R(S)
C
      IMPLICIT REAL*4 (A-H,O-Z)
      IMPLICIT INTEGER*2  (I-N)
C
      COMMON /BLCFN/ Z(6,6,6),A(216),CFN(6,6,6),NCFN(20)
      COMMON /BLEPS/ ERS(20), NITER(20), O, E
      DIMENSION S(5)
C
      R=O
      CALL PVGB(S)
              DO  I3 = 1, NCFN(3)
                  DO  I2 = 1, NCFN(2)
                      DO  I1 = 1, NCFN(1)
                          R=R+Z(I1,I2,I3)*CFN(I1,I2,I3)
                      END DO
                  END DO
              END DO
C
      RETURN
      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C     NBAS  1 2 3  4 5 6  7 8 9
C     NB1   1 1 1  2 2 2  3 3 3    1= S**   2=Tn  3= sin cos
C     NB2   1 2 3  1 2 3  1 2 3    1=0,1,2,3... 2=0,2,4... 3=0,1,3,5...
C
C
      SUBROUTINE PVGB(S)
C
      IMPLICIT REAL*4 (A-H,O-Z)
      IMPLICIT INTEGER*2  (I-N)
C
      COMMON /BLBAS/ XL(3),XR(3),SL(3),SR(3),NBAS(2,3),MBAS(3)
      COMMON /BLWRK/ WA(36,6),WB(216),WC(6,6,6)
      COMMON /BLCFN/ Z(6,6,6),A(216),CFN(6,6,6),NCFN(20)
      COMMON /BLEPS/ ERS(20), NITER(20), O, E
C
      DIMENSION S(5)
C
      DO  I=1,3
          CALL PVGB1( S(I), WA(1,I), NCFN(I), NBAS(1,I), NBAS(2,I) )
      END DO
C
      WB(4)=E
              DO  I3 = 1, NCFN(3)
                  WB(3)=WB(4)*WA(I3,3)
                  DO  I2 = 1, NCFN(2)
                      WB(2)=WB(3)*WA(I2,2)
                      DO  I1 = 1, NCFN(1)
                          WB(1)=WB(2)*WA(I1,1)
                          Z(I1,I2,I3)=WB(1)
                      END DO
                  END DO
              END DO
C
      RETURN
      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
      SUBROUTINE PVGB1(S,T,N,NBAS1,NBAS2)
C
C
C     NBAS  1 2 3  4 5 6  7 8 9
C     NB1   1 1 1  2 2 2  3 3 3    1= S**   2=Tn  3= sin cos
C     NB2   1 2 3  1 2 3  1 2 3    1=0,1,2,3... 2=0,2,4... 3=0,1,3,5...
C
      IMPLICIT REAL*4 (A-H,O-Z)
      IMPLICIT INTEGER*2  (I-N)
C
      COMMON /BLEPS/ ERS(20), NITER(20), O, ONE
      DIMENSION T(5)
C
      GOTO (10,20,30),NBAS1
  10  T(1)=ONE
      GOTO (11,13,14),NBAS2
  11  DO 12 I=2,N
  12  T(I)=T(I-1)*S
      RETURN
  13  T(2)=S*S
      GOTO 15
  14  T(2)=S
  15  SS=S*S
      DO 16 I=3,N
  16  T(I)=T(I-1)*SS
      RETURN
  20  T(1)=ONE
      T(2)=S
      SS=S+S
      NN=N
      IF(NBAS2.GT.1) NN=N+N
      DO 21 I=3,NN
  21  T(I)=T(I-1)*SS-T(I-2)
      GOTO (26,22,24),NBAS2
  22  DO 23 I=2,N
      J=2*I-1
  23  T(I)=T(J)
      GOTO 26
  24  DO 25 I=2,N
      J=2*I-2
  25  T(I)=T(J)
  26  RETURN
  30  T(1)=ONE
      SS= SIN(S)
      SC= COS(S)
      NN=N
      IF(NBAS2.GT.1) NN=N+N
      T(2)=SS
      T(3)=SC
      DO 31 I=4,NN,2
      T(I)  =T(I-2)*SC+T(I-1)*SS
  31  T(I+1)=T(I-1)*SC-T(I-2)*SS
      GOTO (36,32,34),NBAS2
  32  DO 33 I=2,N
      J=2*I-1
  33  T(I)=T(J)
      GOTO 36
  34  DO 35 I=2,N
      J=2*I-2
  35  T(I)=T(J)
  36  RETURN
      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
      BLOCK DATA PMIK
C
      IMPLICIT REAL*4 (A-H,O-Z)
      IMPLICIT INTEGER*2  (I-N)
C
      COMMON /BLBAS/ XL(3),XR(3),SL(3),SR(3),NBAS(2,3),MBAS(3)
      COMMON /BLDAT/ BUFF(50)
      COMMON /BLWRK/ WA(216),WB(216),WC(6,6,6)
      COMMON /BLCFN/ Z(216),A(216),CFN(6,6,6),NCFN(20)
      COMMON /BLEPS/ ERS(20), NITER(20), O, E
      COMMON /BLIOT/ NINP1, NINP2, NOUT1, NOUT2, NTAB1, NTAB2
C
      DATA NITER/20*0/,ERS/20*.0E0/,O/0.0E0/,E/1.000E0/
      DATA NINP1, NINP2 /1,2/
      DATA NOUT1, NOUT2 /5,6/
      DATA NTAB1, NTAB2 /3,4/
C
      DATA XL/1.0, -70.0, 1000. /
      DATA XR/13.,  70.0, 10000./
      DATA SL/0.0, -1.00, -1.00 /
      DATA SR/1.0,  1.00,  1.00 /
      DATA NBAS/ 1, 1, 2,  2, 2, 1 /
      DATA MBAS/1000, 1, 0 /
      DATA NCFN/ 2, 3, 4, 0, 0, 1, 2, 6, 24, 0, 24, 9*0 /
      DATA CFN/ 0.312742E+01, 0.267892E+01, 4*0.0,
     *         -0.142170E+00,-0.935806E+00, 4*0.0,
     *         -0.719833E+00,-0.372147E+00,22*0.0,
     *          0.323231E+00, 0.683911E+00, 4*0.0,
     *         -0.797365E+00,-0.605986E+00, 4*0.0,
     *         -0.100220E+00, 0.527238E+00,22*0.0,
     *         -0.127842E+00,-0.321196E+00, 4*0.0,
     *         -0.676206E-01, 0.212179E+00, 4*0.0,
     *          0.136602E+00, 0.126485E+00,22*0.0,
     *          0.149113E+00, 0.217611E+00, 4*0.0,
     *          0.166502E+00, 0.223654E+00, 4*0.0,
     *          0.834719E-01,-0.402023E-01,22*0.0,72*0.0/
      END

ext: for


text:
      subroutine rg(nm,n,a,wr,wi,matz,z,iv1,fv1,ierr)
c
      integer n,nm,is1,is2,ierr,matz
      double precision a(nm,n),wr(n),wi(n),z(nm,n),fv1(n)
      integer iv1(n)
c
c     this subroutine calls the recommended sequence of
c     subroutines from the eigensystem subroutine package (eispack)
c     to find the eigenvalues and eigenvectors (if desired)
c     of a real general matrix.
c
c     on input
c
c        nm  must be set to the row dimension of the two-dimensional
c        array parameters as declared in the calling program
c        dimension statement.
c
c        n  is the order of the matrix  a.
c
c        a  contains the real general matrix.
c
c        matz  is an integer variable set equal to zero if
c        only eigenvalues are desired.  otherwise it is set to
c        any non-zero integer for both eigenvalues and eigenvectors.
c
c     on output
c
c        wr  and  wi  contain the real and imaginary parts,
c        respectively, of the eigenvalues.  complex conjugate
c        pairs of eigenvalues appear consecutively with the
c        eigenvalue having the positive imaginary part first.
c
c        z  contains the real and imaginary parts of the eigenvectors
c        if matz is not zero.  if the j-th eigenvalue is real, the
c        j-th column of  z  contains its eigenvector.  if the j-th
c        eigenvalue is complex with positive imaginary part, the
c        j-th and (j+1)-th columns of  z  contain the real and
c        imaginary parts of its eigenvector.  the conjugate of this
c        vector is the eigenvector for the conjugate eigenvalue.
c
c        ierr  is an integer output variable set equal to an error
c           completion code described in the documentation for hqr
c           and hqr2.  the normal completion code is zero.
c
c        iv1  and  fv1  are temporary storage arrays.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      if (n .le. nm) go to 10
      ierr = 10 * n
      go to 50
c
   10 call  balanc(nm,n,a,is1,is2,fv1)
      call  elmhes(nm,n,is1,is2,a,iv1)
      if (matz .ne. 0) go to 20
c     .......... find eigenvalues only ..........
      call  hqr(nm,n,is1,is2,a,wr,wi,ierr)
      go to 50
c     .......... find both eigenvalues and eigenvectors ..........
   20 call  eltran(nm,n,is1,is2,a,iv1,z)
      call  hqr2(nm,n,is1,is2,a,wr,wi,z,ierr)
      if (ierr .ne. 0) go to 50
      call  balbak(nm,n,is1,is2,fv1,n,z)
   50 return
      end


text:
      SUBROUTINE SPLINT(XA,YA,Y2A,N,X,Y)
      DIMENSION XA(N),YA(N),Y2A(N)
      KLO=1
      KHI=N
 1    IF (KHI-KLO.GT.1) THEN
		K=(KHI+KLO)/2
		IF(XA(K).GT.X) THEN
			KHI=K
		ELSE
			KLO=K
		ENDIF
	GOTO 1
	ENDIF
	H=XA(KHI)-XA(KLO)
	IF (H.EQ.0.) PAUSE 'BAD XA INPUT'
	A=(XA(KHI)-X)/H
	B=(X-XA(KLO))/H
	Y=A*YA(KLO)+B*YA(KHI)+
     *		((A**3-A)*Y2A(KLO)+(B**3-B)*Y2A(KHI))*(H**2)/6.
       RETURN
       END

max_stars_repo_name: apthorpe/sioseis

max_issues_repo_name: henkart/sioseis

max_forks_repo_name: henkart/sioseis


text:
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! test that empty contained subprograms compile
!
PROGRAM test

   IMPLICIT NONE

   INTEGER :: m, n
   REAL :: x, y
   real result(1),expect(1)
   data expect/1/

   result(1) = 0
   CALL input
   CALL Write
   CALL inputs
   call check(result,expect,1)

CONTAINS

   SUBROUTINE Input
   END SUBROUTINE Input

   SUBROUTINE Write
      result(1) = 1
   END SUBROUTINE

   SUBROUTINE Inputs
   END SUBROUTINE Inputs
END PROGRAM test

max_stars_repo_name: abrahamtovarmob/flang

max_issues_repo_name: abrahamtovarmob/flang

max_forks_repo_name: abrahamtovarmob/flang


text:
 SUBROUTINE POLATES2(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
                     IGDTNUMO,IGDTMPLO,IGDTLENO, &
                     MI,MO,KM,IBI,LI,GI,  &
                     NO,RLAT,RLON,IBO,LO,GO,IRET)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 74685 $
!
! SUBPROGRAM:  POLATES2   INTERPOLATE SCALAR FIELDS (NEIGHBOR)
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM PERFORMS NEIGHBOR INTERPOLATION
!           FROM ANY GRID TO ANY GRID FOR SCALAR FIELDS.
!           OPTIONS ALLOW CHOOSING THE WIDTH OF THE GRID SQUARE
!           (IPOPT(1)) TO SEARCH FOR VALID DATA, WHICH DEFAULTS TO 1
!           (IF IPOPT(1)=-1).  ODD WIDTH SQUARES ARE CENTERED ON
!           THE NEAREST INPUT GRID POINT; EVEN WIDTH SQUARES ARE
!           CENTERED ON THE NEAREST FOUR INPUT GRID POINTS.
!           SQUARES ARE SEARCHED FOR VALID DATA IN A SPIRAL PATTERN
!           STARTING FROM THE CENTER.  NO SEARCHING IS DONE WHERE
!           THE OUTPUT GRID IS OUTSIDE THE INPUT GRID.
!           ONLY HORIZONTAL INTERPOLATION IS PERFORMED.
!           THE CODE RECOGNIZES THE FOLLOWING PROJECTIONS, WHERE
!           "IGDTNUMI/O" IS THE GRIB 2 GRID DEFINTION TEMPLATE NUMBER
!           FOR THE INPUT AND OUTPUT GRIDS, RESPECTIVELY:
!             (IGDTNUMI/O=00) EQUIDISTANT CYLINDRICAL
!             (IGDTNUMI/O=01) ROTATED EQUIDISTANT CYLINDRICAL. "E" AND
!                             NON-"E" STAGGERED
!             (IGDTNUMI/O=10) MERCATOR CYLINDRICAL
!             (IGDTNUMI/O=20) POLAR STEREOGRAPHIC AZIMUTHAL
!             (IGDTNUMI/O=30) LAMBERT CONFORMAL CONICAL
!             (IGDTNUMI/O=40) GAUSSIAN CYLINDRICAL
!           AS AN ADDED BONUS THE NUMBER OF OUTPUT GRID POINTS
!           AND THEIR LATITUDES AND LONGITUDES ARE ALSO RETURNED.
!           ON THE OTHER HAND, THE OUTPUT CAN BE A SET OF STATION POINTS
!           IF IGDTNUMO<0, IN WHICH CASE THE NUMBER OF POINTS
!           AND THEIR LATITUDES AND LONGITUDES MUST BE INPUT.
!           INPUT BITMAPS WILL BE INTERPOLATED TO OUTPUT BITMAPS.
!           OUTPUT BITMAPS WILL ALSO BE CREATED WHEN THE OUTPUT GRID
!           EXTENDS OUTSIDE OF THE DOMAIN OF THE INPUT GRID.
!           THE OUTPUT FIELD IS SET TO 0 WHERE THE OUTPUT BITMAP IS OFF.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
! 1999-04-08  IREDELL  SPLIT IJKGDS INTO TWO PIECES
! 2001-06-18  IREDELL  INCLUDE SPIRAL SEARCH OPTION
! 2006-01-04  GAYNO    MINOR BUG FIX
! 2007-10-30  IREDELL  SAVE WEIGHTS AND THREAD FOR PERFORMANCE
! 2012-06-26  GAYNO    FIX OUT-OF-BOUNDS ERROR. SEE NCEPLIBS
!                      TICKET #9.
! 2015-01-27  GAYNO    REPLACE CALLS TO GDSWIZ WITH NEW MERGED
!                      VERSION OF GDSWZD.
! 2015-07-13  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAYS
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAYS.
!
! USAGE:    CALL POLATES2(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
!                         IGDTNUMO,IGDTMPLO,IGDTLENO, &
!                         MI,MO,KM,IBI,LI,GI,  &
!                         NO,RLAT,RLON,IBO,LO,GO,IRET)
!
!   INPUT ARGUMENT LIST:
!     IPOPT    - INTEGER (20) INTERPOLATION OPTIONS
!                IPOPT(1) IS WIDTH OF SQUARE TO EXAMINE IN SPIRAL SEARCH
!                (DEFAULTS TO 1 IF IPOPT(1)=-1)
!     IGDTNUMI - INTEGER GRID DEFINITION TEMPLATE NUMBER - INPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE:
!                  00 - EQUIDISTANT CYLINDRICAL
!                  01 - ROTATED EQUIDISTANT CYLINDRICAL.  "E"
!                       AND NON-"E" STAGGERED
!                  10 - MERCATOR CYCLINDRICAL
!                  20 - POLAR STEREOGRAPHIC AZIMUTHAL
!                  30 - LAMBERT CONFORMAL CONICAL
!                  40 - GAUSSIAN EQUIDISTANT CYCLINDRICAL
!     IGDTMPLI - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY -
!                INPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATES FOR COMPLETE DEFINITION.
!     IGDTLENI - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - INPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTNUMO - INTEGER GRID DEFINITION TEMPLATE NUMBER - OUTPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.  IGDTNUMO<0
!                MEANS INTERPOLATE TO RANDOM STATION POINTS.
!                OTHERWISE, SAME DEFINITION AS "IGDTNUMI".
!     IGDTMPLO - INTEGER (IGDTLENO) GRID DEFINITION TEMPLATE ARRAY -
!                OUTPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATES FOR COMPLETE DEFINITION.
!     IGDTLENO - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - OUTPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     MI       - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF INPUT GRID FIELDS IF KM=1
!     MO       - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF OUTPUT GRID FIELDS IF KM=1
!     KM       - INTEGER NUMBER OF FIELDS TO INTERPOLATE
!     IBI      - INTEGER (KM) INPUT BITMAP FLAGS
!     LI       - LOGICAL*1 (MI,KM) INPUT BITMAPS (IF SOME IBI(K)=1)
!     GI       - REAL (MI,KM) INPUT FIELDS TO INTERPOLATE
!     NO       - INTEGER NUMBER OF OUTPUT POINTS (ONLY IF IGDTNUMO<0)
!     RLAT     - REAL (NO) OUTPUT LATITUDES IN DEGREES (IF IGDTNUMO<0)
!     RLON     - REAL (NO) OUTPUT LONGITUDES IN DEGREES (IF IGDTNUMO<0)
!
!   OUTPUT ARGUMENT LIST:
!     NO       - INTEGER NUMBER OF OUTPUT POINTS (ONLY IF IGDTNUMO>=0)
!     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES (IF IGDTNUMO>=0)
!     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES (IF IGDTNUMO>=0)
!     IBO      - INTEGER (KM) OUTPUT BITMAP FLAGS
!     LO       - LOGICAL*1 (MO,KM) OUTPUT BITMAPS (ALWAYS OUTPUT)
!     GO       - REAL (MO,KM) OUTPUT FIELDS INTERPOLATED
!     IRET     - INTEGER RETURN CODE
!                0    SUCCESSFUL INTERPOLATION
!                2    UNRECOGNIZED INPUT GRID OR NO GRID OVERLAP
!                3    UNRECOGNIZED OUTPUT GRID
!
! SUBPROGRAMS CALLED:
!   GDSWZD       GRID DESCRIPTION SECTION WIZARD
!   IJKGDS0      SET UP PARAMETERS FOR IJKGDS1
!   IJKGDS1      RETURN FIELD POSITION FOR A GIVEN GRID POINT
!   POLFIXS      MAKE MULTIPLE POLE SCALAR VALUES CONSISTENT
!   CHECK_GRIDS2 DETERMINE IF INPUT OR OUTPUT GRIDS HAVE CHANGED
!                BETWEEN CALLS TO THIS ROUTINE.
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 USE GDSWZD_MOD
!
 IMPLICIT NONE
!
 INTEGER,        INTENT(IN   )        :: IGDTNUMI, IGDTLENI
 INTEGER,        INTENT(IN   )        :: IGDTMPLI(IGDTLENI)
 INTEGER,        INTENT(IN   )        :: IGDTNUMO, IGDTLENO
 INTEGER,        INTENT(IN   )        :: IGDTMPLO(IGDTLENO)
 INTEGER,               INTENT(IN   ) :: IPOPT(20)
 INTEGER,               INTENT(IN   ) :: MI,MO,KM
 INTEGER,               INTENT(IN   ) :: IBI(KM)
 INTEGER,               INTENT(INOUT) :: NO
 INTEGER,               INTENT(  OUT) :: IRET, IBO(KM)
!
 LOGICAL*1,             INTENT(IN   ) :: LI(MI,KM)
 LOGICAL*1,             INTENT(  OUT) :: LO(MO,KM)
!
 REAL,                  INTENT(IN   ) :: GI(MI,KM)
 REAL,                  INTENT(INOUT) :: RLAT(MO),RLON(MO)
 REAL,                  INTENT(  OUT) :: GO(MO,KM)
!
 REAL,                  PARAMETER     :: FILL=-9999.
!
 INTEGER                              :: IJKGDSA(20)
 INTEGER                              :: I1,J1,IXS,JXS
 INTEGER                              :: MSPIRAL,N,K,NK
 INTEGER                              :: NV,IJKGDS1
 INTEGER                              :: MX,KXS,KXT,IX,JX,NX
 INTEGER,                       SAVE  :: NOX=-1,IRETX=-1
 INTEGER,           ALLOCATABLE,SAVE  :: NXY(:)
!
 LOGICAL                              :: SAME_GRIDI, SAME_GRIDO
!
 REAL,              ALLOCATABLE,SAVE  :: RLATX(:),RLONX(:)
 REAL,              ALLOCATABLE,SAVE  :: XPTSX(:),YPTSX(:)
 REAL                                 :: XPTS(MO),YPTS(MO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SET PARAMETERS
 IRET=0
 MSPIRAL=MAX(IPOPT(1),1)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 CALL CHECK_GRIDS2(IGDTNUMI,IGDTMPLI,IGDTLENI,  &
                   IGDTNUMO,IGDTMPLO,IGDTLENO, &
                   SAME_GRIDI,SAME_GRIDO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SAVE OR SKIP WEIGHT COMPUTATION
 IF(IRET.EQ.0.AND.(IGDTNUMO.LT.0.OR..NOT.SAME_GRIDI.OR..NOT.SAME_GRIDO))THEN
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES.
   IF(IGDTNUMO.GE.0) THEN
     CALL GDSWZD(IGDTNUMO,IGDTMPLO,IGDTLENO, 0,MO,FILL,XPTS,YPTS,RLON,RLAT,NO)
     IF(NO.EQ.0) IRET=3
   ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  LOCATE INPUT POINTS
   CALL GDSWZD(IGDTNUMI,IGDTMPLI,IGDTLENI,-1,NO,FILL,XPTS,YPTS,RLON,RLAT,NV)
   IF(IRET.EQ.0.AND.NV.EQ.0) IRET=2
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  ALLOCATE AND SAVE GRID DATA
   IF(NOX.NE.NO) THEN
     IF(NOX.GE.0) DEALLOCATE(RLATX,RLONX,XPTSX,YPTSX,NXY)
     ALLOCATE(RLATX(NO),RLONX(NO),XPTSX(NO),YPTSX(NO),NXY(NO))
     NOX=NO
   ENDIF
   IRETX=IRET
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE WEIGHTS
   IF(IRET.EQ.0) THEN
     CALL IJKGDS0(IGDTNUMI,IGDTMPLI,IGDTLENI,IJKGDSA)
!$OMP PARALLEL DO PRIVATE(N) SCHEDULE(STATIC)
     DO N=1,NO
       RLONX(N)=RLON(N)
       RLATX(N)=RLAT(N)
       XPTSX(N)=XPTS(N)
       YPTSX(N)=YPTS(N)
       IF(XPTS(N).NE.FILL.AND.YPTS(N).NE.FILL) THEN
         NXY(N)=IJKGDS1(NINT(XPTS(N)),NINT(YPTS(N)),IJKGDSA)
       ELSE
         NXY(N)=0
       ENDIF
     ENDDO
   ENDIF
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  INTERPOLATE OVER ALL FIELDS
 IF(IRET.EQ.0.AND.IRETX.EQ.0) THEN
   IF(IGDTNUMO.GE.0) THEN
     NO=NOX
     DO N=1,NO
       RLON(N)=RLONX(N)
       RLAT(N)=RLATX(N)
     ENDDO
   ENDIF
   DO N=1,NO
     XPTS(N)=XPTSX(N)
     YPTS(N)=YPTSX(N)
   ENDDO
!$OMP PARALLEL DO PRIVATE(NK,K,N,I1,J1,IXS,JXS,MX,KXS,KXT,IX,JX,NX) SCHEDULE(STATIC)
   DO NK=1,NO*KM
     K=(NK-1)/NO+1
     N=NK-NO*(K-1)
     GO(N,K)=0
     LO(N,K)=.FALSE.
     IF(NXY(N).GT.0) THEN
       IF(IBI(K).EQ.0.OR.LI(NXY(N),K)) THEN
         GO(N,K)=GI(NXY(N),K)
         LO(N,K)=.TRUE.
! SPIRAL AROUND UNTIL VALID DATA IS FOUND.
       ELSEIF(MSPIRAL.GT.1) THEN
         I1=NINT(XPTS(N))
         J1=NINT(YPTS(N))
         IXS=SIGN(1.,XPTS(N)-I1)
         JXS=SIGN(1.,YPTS(N)-J1)
         DO MX=2,MSPIRAL**2
           KXS=SQRT(4*MX-2.5)
           KXT=MX-(KXS**2/4+1)
           SELECT CASE(MOD(KXS,4))
           CASE(1)
             IX=I1-IXS*(KXS/4-KXT)
             JX=J1-JXS*KXS/4
           CASE(2)
             IX=I1+IXS*(1+KXS/4)
             JX=J1-JXS*(KXS/4-KXT)
           CASE(3)
             IX=I1+IXS*(1+KXS/4-KXT)
             JX=J1+JXS*(1+KXS/4)
           CASE DEFAULT
             IX=I1-IXS*KXS/4
             JX=J1+JXS*(KXS/4-KXT)
           END SELECT
           NX=IJKGDS1(IX,JX,IJKGDSA)
           IF(NX.GT.0) THEN
             IF(LI(NX,K)) THEN
               GO(N,K)=GI(NX,K)
               LO(N,K)=.TRUE.
               EXIT
             ENDIF
           ENDIF
         ENDDO
       ENDIF
     ENDIF
   ENDDO
   DO K=1,KM
     IBO(K)=IBI(K)
     IF(.NOT.ALL(LO(1:NO,K))) IBO(K)=1
   ENDDO
   IF(IGDTNUMO.EQ.0) CALL POLFIXS(NO,MO,KM,RLAT,IBO,LO,GO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 ELSE
   IF(IRET.EQ.0) IRET=IRETX
   IF(IGDTNUMO.GE.0) NO=0
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE POLATES2
!
 SUBROUTINE CHECK_GRIDS2(IGDTNUMI,IGDTMPLI,IGDTLENI, &
                         IGDTNUMO,IGDTMPLO,IGDTLENO, &
                         SAME_GRIDI, SAME_GRIDO)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  CHECK_GRIDS2   CHECK GRID INFORMATION
!   PRGMMR: GAYNO       ORG: W/NMC23       DATE: 2015-07-13
!
! ABSTRACT: DETERMINE WHETHER THE INPUT OR OUTPUT GRID SPECS
!           HAVE CHANGED.
!
! PROGRAM HISTORY LOG:
! 2015-07-13  GAYNO     INITIAL VERSION
!
! USAGE:  CALL CHECK_GRIDS2(IGDTNUMI,IGDTMPLI,IGDTLENI,IGDTNUMO,IGDTMPLO, &
!                           IGDTLENO, SAME_GRIDI, SAME_GRIDO)
!
!   INPUT ARGUMENT LIST:
!     IGDTNUMI - INTEGER GRID DEFINITION TEMPLATE NUMBER - INPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTMPLI - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY -
!                INPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTLENI - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - INPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTNUMO - INTEGER GRID DEFINITION TEMPLATE NUMBER - OUTPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTMPLO - INTEGER (IGDTLENO) GRID DEFINITION TEMPLATE ARRAY -
!                OUTPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTLENO - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - OUTPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!
!   OUTPUT ARGUMENT LIST:
!     SAME_GRIDI  - WHEN TRUE, THE INPUT GRID HAS NOT CHANGED BETWEEN CALLS.
!     SAME_GRIDO  - WHEN TRUE, THE OUTPUT GRID HAS NOT CHANGED BETWEEN CALLS.
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,        INTENT(IN   ) :: IGDTNUMI, IGDTLENI
 INTEGER,        INTENT(IN   ) :: IGDTMPLI(IGDTLENI)
 INTEGER,        INTENT(IN   ) :: IGDTNUMO, IGDTLENO
 INTEGER,        INTENT(IN   ) :: IGDTMPLO(IGDTLENO)
!
 LOGICAL,        INTENT(  OUT) :: SAME_GRIDI, SAME_GRIDO
!
 INTEGER, SAVE                 :: IGDTNUMI_SAVE=-9999
 INTEGER, SAVE                 :: IGDTLENI_SAVE=-9999
 INTEGER, SAVE                 :: IGDTMPLI_SAVE(1000)=-9999
 INTEGER, SAVE                 :: IGDTNUMO_SAVE=-9999
 INTEGER, SAVE                 :: IGDTLENO_SAVE=-9999
 INTEGER, SAVE                 :: IGDTMPLO_SAVE(1000)=-9999
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SAME_GRIDI=.FALSE.
 IF(IGDTNUMI==IGDTNUMI_SAVE)THEN
   IF(IGDTLENI==IGDTLENI_SAVE)THEN
     IF(ALL(IGDTMPLI==IGDTMPLI_SAVE(1:IGDTLENI)))THEN
       SAME_GRIDI=.TRUE.
     ENDIF
   ENDIF
 ENDIF
!
 IGDTNUMI_SAVE=IGDTNUMI
 IGDTLENI_SAVE=IGDTLENI
 IGDTMPLI_SAVE(1:IGDTLENI)=IGDTMPLI
 IGDTMPLI_SAVE(IGDTLENI+1:1000)=-9999
!
 SAME_GRIDO=.FALSE.
 IF(IGDTNUMO==IGDTNUMO_SAVE)THEN
   IF(IGDTLENO==IGDTLENO_SAVE)THEN
     IF(ALL(IGDTMPLO==IGDTMPLO_SAVE(1:IGDTLENO)))THEN
       SAME_GRIDO=.TRUE.
     ENDIF
   ENDIF
 ENDIF
!
 IGDTNUMO_SAVE=IGDTNUMO
 IGDTLENO_SAVE=IGDTLENO
 IGDTMPLO_SAVE(1:IGDTLENO)=IGDTMPLO
 IGDTMPLO_SAVE(IGDTLENO+1:1000)=-9999
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE CHECK_GRIDS2

max_stars_repo_name: noaa-ocs-modeling/PaHM

max_issues_repo_name: noaa-ocs-modeling/PaHM


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module provides a function to deal with prescribed displacement.

module m_fstr_AddBC
  implicit none
contains

  !>  Add Essential Boundary Conditions
  !------------------------------------------------------------------------------------------*
  subroutine fstr_AddBC(cstep,hecMESH,hecMAT,fstrSOLID,fstrPARAM,fstrMAT,iter,conMAT)
    !------------------------------------------------------------------------------------------*
    use m_fstr
    use fstr_matrix_con_contact
    use m_addContactStiffness
    use mContact
    use m_static_LIB_1d
    use m_utilities
    integer, intent(in)                  :: cstep !< current step
    type(hecmwST_local_mesh)             :: hecMESH !< hecmw mesh
    type(hecmwST_matrix)                 :: hecMAT !< hecmw matrix
    type(fstr_solid)                     :: fstrSOLID !< fstr_solid
    type(fstr_param)                     :: fstrPARAM !< analysis control parameters
    type(fstrST_matrix_contact_lagrange) :: fstrMAT !< type fstrST_matrix_contact_lagrange
    integer(kind=kint)                   :: iter !< NR iterations
    type(hecmwST_matrix), optional       :: conMAT !< hecmw matrix for contact only

    integer(kind=kint) :: ig0, ig, ityp, idofS, idofE, idof, iS0, iE0, ik, in
    real(kind=kreal)   :: RHS, factor
    integer(kind=kint) :: idof1, idof2, ndof, i, grpid

    !for rotation
    integer(kind=kint) :: n_rot, rid, n_nodes
    type(tRotInfo)     :: rinfo
    real(kind=kreal)   :: theta, normal(3), direc(3), ccoord(3), cdiff(3), cdiff0(3)
    real(kind=kreal)   :: cdisp(3), cddisp(3)

    !
    ndof = hecMAT%NDOF
    factor = fstrSOLID%FACTOR(2)-fstrSOLID%FACTOR(1)

    if( cstep<=fstrSOLID%nstep_tot .and. fstrSOLID%step_ctrl(cstep)%solution==stepVisco ) then
      factor = 0.d0
      if( fstrSOLID%FACTOR(1) < 1.d-10 ) factor = 1.d0
    endif
    if( iter>1 ) factor=0.d0

    n_rot = fstrSOLID%BOUNDARY_ngrp_rot
    if( n_rot > 0 ) call fstr_RotInfo_init(n_rot, rinfo)

    !   ----- Prescibed displacement Boundary Conditions
    do ig0 = 1, fstrSOLID%BOUNDARY_ngrp_tot
      grpid = fstrSOLID%BOUNDARY_ngrp_GRPID(ig0)
      if( .not. fstr_isBoundaryActive( fstrSOLID, grpid, cstep ) ) cycle
      ig   = fstrSOLID%BOUNDARY_ngrp_ID(ig0)
      RHS  = fstrSOLID%BOUNDARY_ngrp_val(ig0)
      !
      RHS= RHS*factor
      !
      ityp = fstrSOLID%BOUNDARY_ngrp_type(ig0)
      idofS = ityp/10
      idofE = ityp - idofS*10
      !
      iS0 = hecMESH%node_group%grp_index(ig-1) + 1
      iE0 = hecMESH%node_group%grp_index(ig  )

      if( fstrSOLID%BOUNDARY_ngrp_rotID(ig0) > 0 ) then ! setup rotation information
        rid = fstrSOLID%BOUNDARY_ngrp_rotID(ig0)
        if( .not. rinfo%conds(rid)%active ) then
          rinfo%conds(rid)%active = .true.
          rinfo%conds(rid)%center_ngrp_id = fstrSOLID%BOUNDARY_ngrp_centerID(ig0)
          rinfo%conds(rid)%torque_ngrp_id = ig
        endif
        do idof=idofS,idofE
          if( idof>ndof ) then
            rinfo%conds(rid)%vec(idof-ndof) = RHS
          else
            rinfo%conds(rid)%vec(idof) = RHS
          endif
        enddo
        cycle
      endif

      !
      do ik = iS0, iE0
        in = hecMESH%node_group%grp_item(ik)
        !
        do idof = idofS, idofE
          if(present(conMAT)) then
            call hecmw_mat_ass_bc(hecMAT, in, idof, RHS, conMAT)
          else
            call hecmw_mat_ass_bc(hecMAT, in, idof, RHS)
          endif
          if( fstr_is_contact_active() .and. fstrPARAM%solution_type == kstSTATIC   &
              .and. fstrPARAM%contact_algo == kcaSLagrange ) then
            if(present(conMAT)) then
              call fstr_mat_ass_bc_contact(conMAT,fstrMAT,in,idof,RHS)
            else
              call fstr_mat_ass_bc_contact(hecMAT,fstrMAT,in,idof,RHS)
            endif
          endif

        enddo
      enddo
    enddo

    !Apply rotational boundary condition
    do rid = 1, n_rot
      if( .not. rinfo%conds(rid)%active ) cycle
      cdiff = 0.d0
      cdiff0 = 0.d0
      cddisp = 0.d0

      if( factor > 0.d0 ) then
        ig = rinfo%conds(rid)%center_ngrp_id
        do idof = 1, ndof
          ccoord(idof) = hecmw_ngrp_get_totalvalue(hecMESH, ig, ndof, idof, hecMESH%node)
          cdisp(idof) = hecmw_ngrp_get_totalvalue(hecMESH, ig, ndof, idof, fstrSOLID%unode)
          cddisp(idof) = hecmw_ngrp_get_totalvalue(hecMESH, ig, ndof, idof, hecMAT%B)
        enddo
        ccoord(1:ndof) = ccoord(1:ndof) + cdisp(1:ndof)
      endif

      ig = rinfo%conds(rid)%torque_ngrp_id
      iS0 = hecMESH%node_group%grp_index(ig-1) + 1
      iE0 = hecMESH%node_group%grp_index(ig  )
      do ik = iS0, iE0
        in = hecMESH%node_group%grp_item(ik)
        if( factor > 0.d0 ) then
          cdiff0(1:ndof) = hecMESH%node(ndof*(in-1)+1:ndof*in)+fstrSOLID%unode(ndof*(in-1)+1:ndof*in)-ccoord(1:ndof)
          cdiff(1:ndof) = cdiff0(1:ndof)
          call rotate_3dvector_by_Rodrigues_formula(rinfo%conds(rid)%vec(1:ndof),cdiff(1:ndof))
        endif
        do idof = 1, ndof
          RHS = cdiff(idof)-cdiff0(idof)+cddisp(idof)
          if(present(conMAT)) then
            call hecmw_mat_ass_bc(hecMAT, in, idof, RHS, conMAT)
          else
            call hecmw_mat_ass_bc(hecMAT, in, idof, RHS)
          endif
          if( fstr_is_contact_active() .and. fstrPARAM%solution_type == kstSTATIC   &
              .and. fstrPARAM%contact_algo == kcaSLagrange ) then
            if(present(conMAT)) then
              call fstr_mat_ass_bc_contact(conMAT,fstrMAT,in,idof,RHS)
            else
              call fstr_mat_ass_bc_contact(hecMAT,fstrMAT,in,idof,RHS)
            endif
          endif
        enddo
      enddo
    enddo
    if( n_rot > 0 ) call fstr_RotInfo_finalize(rinfo)

    !
    !   ------ Truss element Diagonal Modification
    call truss_diag_modify(hecMAT,hecMESH)

    !
    !   ------ Equation boundary conditions
    do ig0=1,fstrSOLID%n_fix_mpc
      if( fstrSOLID%mpc_const(ig0) == 0.d0 ) cycle
      ! we need to confirm if it is active in curr step here
      RHS = fstrSOLID%mpc_const(ig0)*factor
      hecMESH%mpc%mpc_const(ig0) = RHS
    enddo

  end subroutine fstr_AddBC

end module m_fstr_AddBC


text:
      program test
      use hdf5
      integer:: error
      CALL h5open_f(error)
      CALL h5close_f(error)

      end

max_stars_repo_name: MRedies/FLEUR

max_issues_repo_name: MRedies/FLEUR

max_forks_repo_name: MRedies/FLEUR


text:
	SUBROUTINE MS_OPNC ( climtm, iflsrc, stntbl, iadstn, maxtim,
     +			     iflno, iret )
C************************************************************************
C* MS_OPNC								*
C*									*
C* This subroutine gets the file number for the climatology file.  If   *
C* necessary, a new file will be opened.                                *
C*									*
C* MS_OPNC ( CLIMTM, IFLSRC, STNTBL, IADSTN, MAXTIM, IFLNO, IRET )      *
C*									*
C* Input parameters:							*
C*	CLIMTM  	CHAR*	 	GEMPAK climatology time         *
C*	IFLSRC		INTEGER		File source			*
C*	STNTBL		CHAR*		Station table			*
C*	IADSTN		INTEGER		Max num of additional stations	*
C*	MAXTIM		INTEGER		Max num of times for land data	*
C*									*
C* Output parameters:							*
C*	IFLNO		INTEGER		Climate file number             *
C*	IRET		INTEGER		Return code			*
C*                                        0 = normal return             *
C*					 -4 = climo file not found      *
C*                                       -6 = climo file open error     *
C**									*
C* Log:									*
C* D. Kidwell/NCEP	 9/00	From MM_OPNC                            *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	climtm, stntbl
C*
	CHARACTER	filnam*72, parms(MMPARM)*4
C------------------------------------------------------------------------
	iret = 0
C
C*	Get the path to the climatology file.
C
	CALL FL_MFIL ( 'climo', climtm, filnam, ierr )
	IF ( ierr .ne. 0 ) THEN
	    CALL DC_WLOG ( 4, 'FL', ierr, climtm, ier )
	    iret = -4
	    RETURN
	END IF
C
C* 	Get the unit number.  Open a new file if necessary.
C
	CALL DC_FCYL ( filnam, iflsrc, stntbl, iadstn, maxtim, iflno,
     +		       nparm, parms, ierr )
C
C*	Check that the file was opened properly.
C
	IF ( ierr .ne. 0 ) THEN
	    CALL DC_WLOG ( 0, 'SF', ierr, filnam, ier )
	    iret = -6
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
! { dg-do run }
! Transformational functions for zero-sized array and array sections
! Contributed by Francois-Xavier Coudert  <coudert@clipper.ens.fr>

subroutine test_cshift
  real :: tempn(1), tempm(1,2)
  real,allocatable :: foo(:),bar(:,:),gee(:,:)
  tempn = 2.0
  tempm = 1.0
  allocate(foo(0),bar(2,0),gee(0,7))
  if (any(cshift(foo,dim=1,shift=1)/= 0)) call abort
  if (any(cshift(tempn(2:1),dim=1,shift=1)/= 0)) call abort
  if (any(cshift(bar,shift=(/1,-1/),dim=1)/= 0)) call abort
  if (any(cshift(bar,shift=(/1,-1/),dim=2)/= 0)) call abort
  if (any(cshift(gee,shift=(/1,-1/),dim=1)/= 0)) call abort
  if (any(cshift(gee,shift=(/1,-1/),dim=2)/= 0)) call abort
  if (any(cshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) call abort
  if (any(cshift(tempm(5:4,:),shift=(/1,-1/),dim=2)/= 0)) call abort
  if (any(cshift(tempm(:,5:4),shift=(/1,-1/),dim=1)/= 0)) call abort
  if (any(cshift(tempm(:,5:4),shift=(/1,-1/),dim=2)/= 0)) call abort
  deallocate(foo,bar,gee)
end

subroutine test_eoshift
  real :: tempn(1), tempm(1,2)
  real,allocatable :: foo(:),bar(:,:),gee(:,:)
  tempn = 2.0
  tempm = 1.0
  allocate(foo(0),bar(2,0),gee(0,7))
  if (any(eoshift(foo,dim=1,shift=1)/= 0)) call abort
  if (any(eoshift(tempn(2:1),dim=1,shift=1)/= 0)) call abort
  if (any(eoshift(bar,shift=(/1,-1/),dim=1)/= 0)) call abort
  if (any(eoshift(bar,shift=(/1,-1/),dim=2)/= 0)) call abort
  if (any(eoshift(gee,shift=(/1,-1/),dim=1)/= 0)) call abort
  if (any(eoshift(gee,shift=(/1,-1/),dim=2)/= 0)) call abort
  if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) call abort
  if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2)/= 0)) call abort
  if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1)/= 0)) call abort
  if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2)/= 0)) call abort

  if (any(eoshift(foo,dim=1,shift=1,boundary=42.0)/= 0)) call abort
  if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=42.0)/= 0)) call abort
  if (any(eoshift(bar,shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort
  if (any(eoshift(bar,shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort
  if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort
  if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort
  if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort
  if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort
  if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort
  if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort

  if (any(eoshift(foo,dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort
  if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort
  if (any(eoshift(bar,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
  if (any(eoshift(bar,shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
  if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
  if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
  if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
  if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
  if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
  if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
  deallocate(foo,bar,gee)
end

subroutine test_transpose
  character(len=1) :: tempn(1,2)
  character(len=1),allocatable :: foo(:,:), bar(:,:)
  integer :: tempm(1,2)
  integer,allocatable :: x(:,:), y(:,:)
  tempn = 'a'
  allocate(foo(3,0),bar(-2:-4,7:9))
  tempm = -42
  allocate(x(3,0),y(-2:-4,7:9))
  if (any(transpose(tempn(-7:-8,:)) /= 'b')) call abort
  if (any(transpose(tempn(:,9:8)) /= 'b')) call abort
  if (any(transpose(foo) /= 'b')) call abort
  if (any(transpose(bar) /= 'b')) call abort
  if (any(transpose(tempm(-7:-8,:)) /= 0)) call abort
  if (any(transpose(tempm(:,9:8)) /= 0)) call abort
  if (any(transpose(x) /= 0)) call abort
  if (any(transpose(y) /= 0)) call abort
  deallocate(foo,bar,x,y)
end

subroutine test_reshape
  character(len=1) :: tempn(1,2)
  character(len=1),allocatable :: foo(:,:), bar(:,:)
  integer :: tempm(1,2)
  integer,allocatable :: x(:,:), y(:,:)
  tempn = 'b'
  tempm = -42
  allocate(foo(3,0),bar(-2:-4,7:9),x(3,0),y(-2:-4,7:9))

  if (size(reshape(tempn(-7:-8,:),(/3,3/),pad=(/'a'/))) /= 9 .or. &
      any(reshape(tempn(-7:-8,:),(/3,3/),pad=(/'a'/)) /= 'a')) call abort
  if (size(reshape(tempn(-7:-8,:),(/3,3,3/),pad=(/'a'/))) /= 27 .or. &
      any(reshape(tempn(-7:-8,:),(/3,3,3/),pad=(/'a'/)) /= 'a')) call abort
  if (size(reshape(tempn(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. &
      any(reshape(tempn(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) call abort
  if (size(reshape(foo,(/3,3/),pad=(/'a'/))) /= 9 .or. &
      any(reshape(foo,(/3,3/),pad=(/'a'/)) /= 'a')) call abort
  if (size(reshape(foo,(/3,3,3/),pad=(/'a'/))) /= 27 .or. &
      any(reshape(foo,(/3,3,3/),pad=(/'a'/)) /= 'a')) call abort
  if (size(reshape(foo,(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. &
      any(reshape(foo,(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) call abort
  if (size(reshape(bar,(/3,3/),pad=(/'a'/))) /= 9 .or. &
      any(reshape(bar,(/3,3/),pad=(/'a'/)) /= 'a')) call abort
  if (size(reshape(bar,(/3,3,3/),pad=(/'a'/))) /= 27 .or. &
      any(reshape(bar,(/3,3,3/),pad=(/'a'/)) /= 'a')) call abort
  if (size(reshape(bar,(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. &
      any(reshape(bar,(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) call abort

  if (size(reshape(tempm(-7:-8,:),(/3,3/),pad=(/7/))) /= 9 .or. &
      any(reshape(tempm(-7:-8,:),(/3,3/),pad=(/7/)) /= 7)) call abort
  if (size(reshape(tempm(-7:-8,:),(/3,3,3/),pad=(/7/))) /= 27 .or. &
      any(reshape(tempm(-7:-8,:),(/3,3,3/),pad=(/7/)) /= 7)) call abort
  if (size(reshape(tempm(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. &
      any(reshape(tempm(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) call abort
  if (size(reshape(x,(/3,3/),pad=(/7/))) /= 9 .or. &
      any(reshape(x,(/3,3/),pad=(/7/)) /= 7)) call abort
  if (size(reshape(x,(/3,3,3/),pad=(/7/))) /= 27 .or. &
      any(reshape(x,(/3,3,3/),pad=(/7/)) /= 7)) call abort
  if (size(reshape(x,(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. &
      any(reshape(x,(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) call abort
  if (size(reshape(y,(/3,3/),pad=(/7/))) /= 9 .or. &
      any(reshape(y,(/3,3/),pad=(/7/)) /= 7)) call abort
  if (size(reshape(y,(/3,3,3/),pad=(/7/))) /= 27 .or. &
      any(reshape(y,(/3,3,3/),pad=(/7/)) /= 7)) call abort
  if (size(reshape(y,(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. &
      any(reshape(y,(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) call abort

  deallocate(foo,bar,x,y)
end

subroutine test_pack
  integer :: tempn(1,5)
  integer,allocatable :: foo(:,:)
  tempn = 2
  allocate(foo(0,1:7))
  if (size(pack(foo,foo/=0)) /= 0 .or. any(pack(foo,foo/=0) /= -42)) call abort
  if (size(pack(foo,foo/=0,(/1,3,4,5,1,0,7,9/))) /= 8 .or. &
      sum(pack(foo,foo/=0,(/1,3,4,5,1,0,7,9/))) /= 30) call abort
  if (size(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0)) /= 0 .or. &
      any(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0) /= -42)) call abort
  if (size(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0,(/1,3,4,5,1,0,7,9/))) /= 8 .or. &
      sum(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0,(/1,3,4,5,1,0,7,9/))) /= 30) &
    call abort
  if (size(pack(foo,.true.)) /= 0 .or. any(pack(foo,.true.) /= -42)) &
    call abort
  if (size(pack(foo,.true.,(/1,3,4,5,1,0,7,9/))) /= 8 .or. &
      sum(pack(foo,.true.,(/1,3,4,5,1,0,7,9/))) /= 30) call abort
  if (size(pack(tempn(:,-4:-5),.true.)) /= 0 .or. &
      any(pack(foo,.true.) /= -42)) call abort
  if (size(pack(tempn(:,-4:-5),.true.,(/1,3,4,5,1,0,7,9/))) /= 8 .or. &
      sum(pack(tempn(:,-4:-5),.true.,(/1,3,4,5,1,0,7,9/))) /= 30) call abort
  deallocate(foo)
end

subroutine test_unpack
  integer :: tempn(1,5), tempv(5)
  integer,allocatable :: foo(:,:), bar(:)
  tempn = 2
  tempv = 5
  allocate(foo(0,1:7),bar(0:-1))
  if (any(unpack(tempv,tempv/=0,tempv) /= 5) .or. &
      size(unpack(tempv,tempv/=0,tempv)) /= 5) call abort
  if (any(unpack(tempv(1:0),tempv/=0,tempv) /= 5) .or. &
      size(unpack(tempv(1:0),tempv/=0,tempv)) /= 5) call abort
  if (any(unpack(tempv,tempv(1:0)/=0,tempv) /= -47)) call abort
  if (any(unpack(tempv(5:4),tempv(1:0)/=0,tempv) /= -47)) call abort
  if (any(unpack(bar,foo==foo,foo) /= -47)) call abort
  deallocate(foo,bar)
end

subroutine test_spread
  real :: tempn(1)
  real,allocatable :: foo(:)
  tempn = 2.0
  allocate(foo(0))
  if (any(spread(1,dim=1,ncopies=0) /= -17.0) .or. &
      size(spread(1,dim=1,ncopies=0)) /= 0) call abort
  if (any(spread(foo,dim=1,ncopies=1) /= -17.0) .or. &
      size(spread(foo,dim=1,ncopies=1)) /= 0) call abort
  if (any(spread(tempn(2:1),dim=1,ncopies=1) /= -17.0) .or. &
      size(spread(tempn(2:1),dim=1,ncopies=1)) /= 0) call abort
  deallocate(foo)
end

program test
  call test_cshift
  call test_eoshift
  call test_transpose
  call test_unpack
  call test_spread
  call test_pack
  call test_reshape
end

max_stars_repo_name: vidkidz/crossbridge

max_issues_repo_name: vidkidz/crossbridge

max_forks_repo_name: vidkidz/crossbridge