text:
*DECK QWGTS
      REAL FUNCTION QWGTS (X, A, B, ALFA, BETA, INTEGR)
C***BEGIN PROLOGUE  QWGTS
C***SUBSIDIARY
C***PURPOSE  This function subprogram is used together with the
C            routine QAWS and defines the WEIGHT function.
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (QWGTS-S, DQWGTS-D)
C***KEYWORDS  ALGEBRAICO-LOGARITHMIC, END POINT SINGULARITIES,
C             WEIGHT FUNCTION
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***SEE ALSO  QK15W
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   810101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  QWGTS
C
      REAL A,ALFA,B,BETA,BMX,X,XMA
      INTEGER INTEGR
C***FIRST EXECUTABLE STATEMENT  QWGTS
      XMA = X-A
      BMX = B-X
      QWGTS = XMA**ALFA*BMX**BETA
      GO TO (40,10,20,30),INTEGR
   10 QWGTS = QWGTS*LOG(XMA)
      GO TO 40
   20 QWGTS = QWGTS*LOG(BMX)
      GO TO 40
   30 QWGTS = QWGTS*LOG(XMA)*LOG(BMX)
   40 RETURN
      END


text:
program write_many_files
implicit none
integer, parameter           :: iu = 10, nobs = 1000, nfiles = 3
character (len=*), parameter :: prefix = "temp_", suffix = ".txt"
integer                      :: i
real                         :: x(nobs)
character (len=100)          :: fname
do i=1,nfiles
   call random_number(x)
   write (fname,"(a,i0,a)") prefix,i,suffix       ! set file name
   open (unit=iu,file=trim(fname),action="write") ! connect file to unit
   write (iu,*) minval(x),maxval(x),sum(x)/nobs   ! write data
   close (iu)                                     ! close unit
end do
end program write_many_files
! creates files temp_1.txt, temp_2.txt, temp_3.txt

max_stars_repo_name: awvwgk/FortranTip

max_issues_repo_name: awvwgk/FortranTip

max_forks_repo_name: awvwgk/FortranTip


text:
************************************************************************
* This file contains initialization routines for the NSDEF2 solver.
************************************************************************

************************************************************************
* Initialize vector structures for Navier-Stokes solver
*
* This routine allocates memory for necessary vectors and
* initializes the VECDAT structures on all levels, which are used
* for solving the Navier Stokes equation in all cases.
*
* In:
*   NLMIN   : Minimum level in TRIAS
*   NLMAX   : Maximum level in TRIAS
*   TRIAS   : array [1..SZTRIA,1..NNLEV] of integer
*             Triangulation structures on all levels.
*   IASMBL : array [1..SZASMI] of integer
*   DASMBL : array [1..SZASMD] of double
*            Integer and double prec. parameter block that controls the
*            discretization. This tells all assembly-routines how to
*            set up the nonlinearity in the system matrices, which
*            cubature formula to use, etc.
*
* Out:
*   VECDAT  : array [1..SZN2VI,1..NNLEV] of integer
*             TNS2DVectorParams structure that defines the vector
*             structure. VECDAT(.,NLMIN..NLMAX) is filled with data.
************************************************************************

      SUBROUTINE ININSV (NLMIN,NLMAX,TRIAS,IASMBL,DASMBL,
     *                   VECDAT)

      IMPLICIT NONE

      INCLUDE 'stria.inc'

      INCLUDE 'sassembly.inc'
      INCLUDE 'slinsol.inc'
      INCLUDE 'slinsol2dns.inc'

      INCLUDE 'cbasicmg.inc'

C     parameters

      INTEGER NLMIN,NLMAX,TRIAS(SZTRIA,NNLEV),IASMBL(*)
      INTEGER VECDAT(SZN2VI,NNLEV)
      DOUBLE PRECISION DASMBL(*)

C     Functions to get the number of DOF's

      INTEGER NDFGX
      EXTERNAL NDFGX

C     local variables

      INTEGER I,NUP

C     Loop through all essential levels:

      DO I=NLMIN,NLMAX

C       At first clear the structure for level I

        CALL LCL3(VECDAT(1,I),SZN2VI)

C       Get the number of unknowns for velocity and pressure.
C       This is done with the central element routine which calculates
C       the global number of DOF's.

        IF ((IASMBL(OIELEMT).EQ.0).OR.(IASMBL(OIELEMT).EQ.2)) THEN
          VECDAT(ONU,I) = NDFGX(31,TRIAS(1,I))
        ELSE IF ((IASMBL(OIELEMT).EQ.1).OR.(IASMBL(OIELEMT).EQ.3)) THEN
          VECDAT(ONU,I) = NDFGX(30,TRIAS(1,I))
        END IF
        VECDAT(ONP,I) = NDFGX(10,TRIAS(1,I))

C       Summing these values results in the number of unknowns:

        NUP = 2*VECDAT(ONU,I)+VECDAT(ONP,I)
        VECDAT(ONEQV,I) = NUP

C       Allocate solution vector

        CALL ZNEW(NUP,1,VECDAT(OLSOL,I),'DSOL  ')

C       Allocate RHS vector

        CALL ZNEW(NUP,1,VECDAT(OLRHS,I),'DRHS  ')

C       Allocate auxiliary vector

        CALL ZNEW(NUP,1,VECDAT(OLTMP,I),'DAUX  ')

      END DO

      END

************************************************************************
* Release vector structures for Navier-Stokes solver
*
* This routine releases memory that was allocated by ININSV.
*
* In:
*   NLMIN   : Minimum level in TRIAS
*   NLMAX   : Maximum level in TRIAS
*   VECDAT  : array [1..SZN2VI,1..NNLEV] of integer
*             TNS2DVectorParams structure that defines the vector
*             structure.
*
* Out:
*  VECDAT(.,NLMIN..NLMAX) is released.
************************************************************************

      SUBROUTINE DONNSV (NLMIN,NLMAX,VECDAT)

      IMPLICIT NONE

      INCLUDE 'stria.inc'

      INCLUDE 'sassembly.inc'
      INCLUDE 'slinsol.inc'
      INCLUDE 'slinsol2dns.inc'

      INCLUDE 'cbasicmg.inc'

C     parameters

      INTEGER NLMIN,NLMAX,TRIAS(SZTRIA,NNLEV)
      INTEGER VECDAT(SZN2VI,NNLEV)

C     local variables

      INTEGER I

C     Loop through all essential levels:

      DO I=NLMAX,NLMIN,-1

C       Release auxiliary vector

        CALL ZDISP(0,VECDAT(OLTMP,I),'DAUX  ')

C       Release RHS vector

        CALL ZDISP(0,VECDAT(OLRHS,I),'DRHS  ')

C       Release solution vector

        CALL ZDISP(0,VECDAT(OLSOL,I),'DSOL  ')

      END DO

      END

ext: f

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_licenses: Intel Unlicense


text:
Freshmen should check out the Freshman Guide for advice on existence.

As at all other schools, freshmen are first year students and are a species of undergraduate students (Subgraduatera freshmanense). Freshmen at Campus UC Davis often live in the dorms where they sometimes mate and have been known to successfully Pregnancy breed on occasion, at times giving birth on the nest floor.  Prior to spring, their primary mating season, both males and females often present with a dark Freshman Stripe stripe.

Claims that the proper plural form is Freshmans rather than Freshmen (by analogy with, e.g., Musselmans) have gone almost entirely unnoticed. The proper collective noun is a gaggle of freshmen, unless someone can come up with a better one.

The term freshman is considered sexist by some; however, it is generally accepted that the masculine tense is the neutral. Firstyear student is the politically correct nomenclature, but Freshpeople is a much more fun phrase. Only The California Aggie The Aggie uses Firstyear student.

One of many nomenclatures is a gaggle of Freshmen.BR
nbspUsage: A gaggle of Freshmen huddled on the sidewalk beside AM/PM hoping they could find 40 Ounce Meal Plan someone to buy.

Also freshmen are more likely to commit dormcest than any other species.

Freshmen may be seen on the weekends flocking towards the Gilmore and Bixby highrises for the notorious floor parties and Free Beer free booze found therein.

 How to spot a Freshman
  Afflicted with the Freshman Stripe.
  Wear dormrelated accessories such as those blue Aggie Card necklace holders (lanyard).
  Huddle together like penguins around the intersection of Russell Russell Blvd and La Rue Road, bound for AM/PM, Frat Parties, The Graduate The Grad and who knows what else.
  Working their way toward the Freshman Fifteen.
  Attempt to ride in the opposite direction or through Bicycles bike Bike Circle circles during the first week of school or even the UC Davis Fall Welcome Fall Welcome.
  Unable to find Navins Copy Shop (this also applies to Transfer Students).
   They bring their backpack with them when they go to buy books at the UCD Bookstore bookstore.
                   Backpacks are now allowed in the bookstore, as of 2010(ish)
   When lost they will ask anyone who appears to know where they are going for Map directions.
   They can be heard asking do you know where a party is tonight? down on Frat Row.
   In the first week of Fall Quarter, introduce themselves in class to people sitting next to them and ask What is your major? and What Residence Halls dorm do you live in?
   Can sometimes be found outside of Aggie Liquor giggling while an upperclassman is inside buying them their first case.

 Freshman Rules and Traditions
All freshmen must follow these Aggie traditions:

Note:  If the freshmen win the class football game, they are allowed to remove their dinks early  otherwise, theyre kept on until Picnic Day.
Freshman rules are enforced by the ASUF Vigilance Committee.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
-makelib ies_lib/xil_defaultlib \
  "../../../../pwm_0/src/pwm.vhd" \
  "../../../../pwm_0/sim/pwm_0.vhd" \
-endlib


text:
      SUBROUTINE DSSIZE ( NAMFIL, NCOLS, NTERMS, NSTRGS, NWDTRM )
C
C   DSSIZE DETERMINES THE SIZE OF A GIVEN MATRIX FILE
C      NCOLS  = NUMBER OF COLUMNS
C      NTERMS = TOTAL NUMBER OF NON-ZERO TERMS IN MATRIX
C      NSTRGS = TOTAL NUMBER OF STRINGS OF CONSECUTIVE TERMS IN MATRIX
C      NWDTRM = NUMBER OF WORDS PER TERM
C
      INCLUDE 'DSIOF.COM'
      COMMON / ZZZZZZ / MEM( 4 )
      INTEGER   MCB(7)
      CALL GETURN( NAMFIL )
      IF ( IFILEX .EQ. 0 ) GO TO 701
      MCB( 1 ) = NAMFIL
      CALL RDTRL ( MCB )
      NCOLS  = MCB( 2 )
      NSTRGS = FCB( 16, IFILEX )
      NTERMS = FCB( 17, IFILEX )
      NWDTRM = 2
      IF ( MCB( 5 ) .EQ. 1 ) NWDTRM = 1
      IF ( MCB( 5 ) .EQ. 4 ) NWDTRM = 4
      GO TO 777
701   NTERMS = 0
      NSTRGS = 0
      NCOLS  = 0
      NWDTRM = 0
777   CONTINUE
      RETURN
      END


text:
-ovmhome ../../..

../../../src/ovm_pkg.sv
test.sv


text:
      subroutine watbal

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine computes the daily water balance for each HRU
!!    changes in storage should equal water losses from the system
!!    write statements can be uncommented for model debugging

!!    this subroutine will give errors for HRUs receiving irrigation water
!!    from reaches or reservoirs

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    aird(:)     |mm H2O        |amount of water applied to HRU on current
!!                               |day
!!    bsprev      |mm H2O        |surface runoff lagged from prior day
!!    bss(1,:)    |mm H2O        |amount of lateral flow lagged
!!    bssprev     |mm H2O        |lateral flow lagged from prior day of
!!                               |simulation
!!    curyr       |none          |current year of simulation
!!    deepst(:)   |mm H2O        |depth of water in deep aquifer
!!    deepstp     |mm H2O        |depth of water in deep aquifer in HRU
!!    ep_day      |mm H2O        |actual amount of transpiration that occurs on
!!                               |day in HRU
!!    es_day      |mm H2O        |actual amount of evaporation (from soil) that
!!                               |occurs on day in HRU
!!    etday       |mm H2O        |actual amount of evapotranspiration that
!!                               |occurs on day in HRU
!!    gw_q(:)     |mm H2O        |groundwater contribution to streamflow from
!!                               |HRU on current day
!!    gwseep      |mm H2O        |amount of water recharging deep aquifer on
!!                               |current day
!!    iida        |julian date   |current day of simulation
!!    inflpcp     |mm H2O        |amount of precipitation that infiltrates into
!!                               |soil (enters soil)
!!    ihru        |none          |HRU number
!!    latq(:)     |mm H2O        |amount of water in lateral flow in HRU for the
!!                               |day
!!    precipday   |mm H2O        |precipitation for the day in HRU
!!    qday        |mm H2O        |surface runoff loading to main channel for
!!                               |day in HRU (includes effects of transmission
!!                               |losses)
!!    qtile       |mm H2O        |drainage tile flow for day in HRU
!!    rchrg(:)    |mm H2O        |amount of water recharging both aquifers on
!!                               |current day in HRU
!!    revapday    |mm H2O        |amount of water moving from the shallow
!!                               |aquifer into the soil profile or being taken
!!                               |up by plant roots in the shallow aquifer
!!    sepbtm(:)   |mm H2O        |seepage leaving the bottom of the soil profile
!!                               |on day in HRU
!!    shallst(:)  |mm H2O        |depth of water in shallow aquifer
!!    shallstp    |mm H2O        |depth of water in shallow aquifer in HRU on
!!                               |previous day
!!    sno_hru(:)  |mm H2O        |amount of water stored as snow
!!    snoev       |mm H2O        |amount of water in snow lost through
!!                               |sublimation on current day in HRU
!!    snofall     |mm H2O        |amount of precipitation falling as freezing
!!                               |rain/snow on day in HRU
!!    snomlt      |mm H2O        |amount of water in snow melt for the day in
!!                               |HRU
!!    snoprev     |mm H2O        |amount of water stored as snow on previous day
!!    sol_sw(:)   |mm H2O        |amount of water stored in soil profile on any
!!                               |given day
!!    subp(:)     |mm H2O        |precipitation for the day in HRU
!!    surf_bs(1,:)|mm H2O        |amount of surface runoff lagged over one
!!                               |day
!!    swprev      |mm H2O        |amount of water stored in soil profile in the
!!                               |HRU on the previous day
!!    tloss       |mm H2O        |amount of water removed from surface runoff
!!    twlpnd      |mm H2O        |water lost through seepage from ponds on day
!!                               |in HRU
!!    twlwet      |mm H2O        |water lost through seepage from wetlands on
!!                               |day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    dstor       |mm H2O        |change in storage (snow, soil, shallow
!!                               |and deep aquifers)
!!    h2oloss     |mm H2O        |net movement of water out of system
!!    j           |none          |HRU number
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Abs

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j
      real :: dstor, h2oloss

      j = 0
      j = ihru

      dstor = 0.
      h2oloss = 0.

      if (ievent == 0) then
          dstor = sno_hru(j) - snoprev + sol_sw(j) - swprev +
     &        shallst(j) - shallstp + deepst(j) - deepstp +
     &        surf_bs(1,j) - bsprev + bss(1,j) - bssprev
      else
         dstor = sno_hru(j) - snoprev + sol_sw(j) - swprev +
     &        shallst(j) - shallstp + deepst(j) - deepstp +
     &        hhsurf_bs(1,j,nstep) - bsprev + bss(1,j) - bssprev
      endif

!!   subtraction of snoev term in h2oloss variable removed
!!   this term is already included in the variable:
!!        etday = ep_day + es_day + canev
!!   es_day includes the value of the variable snoev (see etact.f routine)
!$$$$$$       h2oloss = subp(j) - qday - latq(j) - etday - gw_q(j) -            &
!$$$$$$      &          revapday + twlpnd + twlwet + aird(j) + rchrg(j) - qtile &
!$$$$$$      &          - sepbtm(j)
      h2oloss = subp(j) - qday - latq(j) - qtile - etday - gw_q(j)
     &          + aird(j) - revapday + rchrg(j) - sepbtm(j) - tloss

!$$$$$$       write (17,100) iida, sno_hru(j), sol_sw(j), shallst(j), deepst(j),&
!$$$$$$      &                precipday, snofall, snomlt, snoev, inflpcp, qday, &
!$$$$$$      &                sepbtm(j), latq(j), es_day, ep_day, rchrg(j),     &
!$$$$$$      &                gw_q(j), revapday, gwseep, tloss
!$$$$$$
!$$$$$$       write (17,100) iida, dstor, h2oloss
!     if (Abs(dstor - h2oloss) > 0.001) then
!       write (17,101) j, iida, curyr, dstor - h2oloss
!     endif

!$$$$$$  100  format (i4, 20f8.3)
 101  format (' Water Balance Problem - Subbassin', i6,' Day/Year',2i4,
     *  f10.5,' mm')
      return
      end


text:
	subroutine rdkttbl(rc_kt,mxkt,
     &	  ktname,ktunit,ktdesc,ktmvar,istat)

	use m_inpak90, only : lablin,rdnext,getwrd,str2rn,getstr
	use m_stdio,   only : stderr

	implicit none

c  Inputs
c ========
	character*(*) rc_kt	! table label
	integer mxkt		! size of the storage arrays

c  Outputs
c =========
	character*(*) ktname(mxkt)	! variable names
	character*(*) ktunit(mxkt)	! variable units
	character*(*) ktdesc(mxkt)	! variable descriptions
	logical ktmvar(mxkt,mxkt)	! multi-variate flags
	integer istat		! input status code

c  Local Parameters and Variables
c ================================

	character*7 myname
	parameter(myname='rdkttbl')

	include "realvals.h"

c	..Locals
	character*64 str
	integer ios
	integer l,k,ls,ln
	integer ikt,jkt
	real val

	integer lnblnk
	external lnblnk

	real a
	logical NotAnInt
	NotAnInt(a)=abs(a-nint(a)).gt.rfrcval

c	..Locate the table and check the status
c	========================================
	call lablin(trim(rc_kt))
	call rdnext(ios)
	if(ios.eq.2) then
	  write(stderr,'(3a)') myname,
     &	    ': table not found, ',trim(rc_kt)
	  istat=-1
	  return	! bad news to the parent
	endif

	istat=0		! if normal return

	do ikt=1,mxkt
	  ktname(ikt)=' '
	  ktunit(ikt)=' '
	  ktdesc(ikt)=' '
	  do jkt=1,mxkt
	    ktmvar(ikt,jkt)=.false.
	  end do
	end do

c	..Processe the table line by line

	do while(ios.eq.0)

c	  ..Process the line token by token

c  #1	  ..The first token is the code number of the variable.  It is
c ====	  the number used in the input data "delta" (innovation vector)
c	  for a given variable.

	  call getwrd(ios,str)		! kt
	  if(ios.ne.0) then
	    write(stderr,'(2a,i4)') myname,
     &	      ': unexpected error from getwrd(), ios =',ios
	    istat=1
	    return	! bad news to the parent
	  endif

	  val=str2rn(str,ios)
	  if(ios.ne.0) then
	    l=max(lnblnk(str),1)
	    write(stderr,'(4a)') myname,
     &	      ': expecting a number, but "',str(1:l),'"'
	    istat=1
	    return	! bad news to the parent
	  endif

	  if(NotAnInt(val)) then
	    l=max(lnblnk(str),1)
	    write(stderr,'(4a)') myname,
     &		': expecting an integer, but "',str(1:l),'"'
	    istat=1
	    return	! bad news to the parent
	  endif

	  ikt=nint(val)
	  if(ikt.le.0 .or. ikt.gt.mxkt) then
	    l=max(lnblnk(str),1)
	    write(stderr,'(2a,i3,3a)') myname,
     &		': expecting kt value 1 to ',mxkt,', but "',
     &		str(1:l),'"'
	    istat=1
	    return	! bad news to the parent
	  endif

c	  ..Duplicate entry found
c	  =======================
	  if(ktname(ikt).ne.' ') then
	    write(stderr,'(2a,i3,2a)') myname,
     &	      ': kt =',ikt,' is already defined, ',ktname(ikt)
	    istat=1
	    return
	  endif

c  #2	  ..The second token is the name of the variable.  It should be
c ====    used in the program to relate kt number (#1) to a certain
c	  variable.

	  call getwrd(ios,str)
	  if(ios.ne.0) then
	    write(stderr,'(2a)') myname,
     &	      ': missing variable name'
	    istat=2
	    return	! bad news to the parent
	  endif
	  ktname(ikt)=str

c  #3	  ..The third token is the unit of the variable.  It may have
c ====	  not been used in the program, but for reference only.

	  call getwrd(ios,str)
	  if(ios.ne.0) then
	    write(stderr,'(2a)') myname,
     &	      ': missing variable unit'
	    istat=3
	    return	! bad news to the parent
	  endif
	  ktunit(ikt)=str

c  #4	  ..The fourth token is a description of the variable.  It is
c ====	  expected to be a "$" terminated string, or for the future,
c	  maybe a quoted string.

	  call getstr(ios,str)
	  if(ios.ne.0) str='?'
	  ktdesc(ikt)=str

c  #5	  ..Token #5 and beyond are multi-variate flags.  Each entry
c ====	  may be "0" or "1", or "F" or "T" in either lower or upper
c	  cases.  Spaces between entries are allowed.  The program will
c	  keep reading until upto nkt entries are read.

	  call getwrd(ios,str)
	  jkt=0			! for jkt=1,ikt
	  do while(ios.eq.0.and.jkt.lt.ikt)
	    ls=lnblnk(str)	! if ios=0, ls>0
	    ln=min(ls,ikt-jkt)	! only need upto the first ikt entries
	    do k=1,ln
	      jkt=jkt+1
	      if(str(k:k).eq.'0'.or.
     &		  str(k:k).eq.'F'.or.str(k:k).eq.'f') then
		ktmvar(ikt,jkt)=.false.
		ktmvar(jkt,ikt)=.false.
	      elseif(str(k:k).eq.'1'.or.
     &		  str(k:k).eq.'T'.or.str(k:k).eq.'t') then
		ktmvar(ikt,jkt)=.true.
		ktmvar(jkt,ikt)=.true.
	      else
		write(stderr,'(4a)') myname,
     &		  ': invalid multi-variate flag, "',str(1:ls),'"'
		istat=5
		return
	      endif
	    end do
	    call getwrd(ios,str)
	  end do

	  if(jkt.lt.ikt-1) then
	    write(stderr,'(2a,2(i2,a))') myname,
     &	      ': incomplete multi-variate flag, (jkt=',jkt,
     &	      ') < (ikt=',ikt,')'
	    istat=5
	    return

	  elseif(jkt.eq.ikt-1) then
	    ktmvar(ikt,ikt)=.true.

	  else if(jkt.ge.ikt) then	! use ktmvar(nkt,nkt) as a check
	    if(.not.ktmvar(ikt,ikt)) then
	      write(stderr,'(2a,l2)') myname,
     &		': invalid diagonal flag value, ',ktmvar(ikt,ikt)
	      istat=5
	      return
	    endif
	  endif

	  call rdnext(ios)
	end do

	end

max_stars_repo_name: GEOS-ESM/AeroApps

max_forks_repo_name: GEOS-ESM/AeroApps


!***********************************/
!	Name:1段階目の計算を行うにあたって必要な情報を作成する
!	Alias:DataFabrication4FirstStep
!	Description:初回の計算をさもループ計算の途中であったかのように振る舞わせる → データ捏造っぽさみ → fabrication(偽造)
!	Type:
!	Input:
!	Output:
!	Note:
!	Author:Akitaka Toyota
!	Date:2017.12.27
!	Update:
!	Other:
!***********************************/
subroutine DataFabrication4FirstStep(UG,MG,CC)
    use StructVar_Mod
    use LoopVar_Mod

    implicit none
    type(UnstructuredGrid), intent(in) :: UG
    type(MoveGrid), intent(inout) :: MG
    type(CellCenter), intent(inout) :: CC

    !MG%NSR%C%NextCoordsInG(:,1:3) = UG%CD%Cell(:,1:3)
    MG%NSR%C%NextCoordsInG(:,4) = 1.0d0

    !MG%NSR%P%NextCoordsInG(:,1:3) = UG%CD%Point(:,1:3)
    MG%NSR%P%NextCoordsInG(:,4) = 1.0d0

    do iCell=UG%GI%RealCells+1, UG%GI%AllCells
        CC%ConservedQuantity(:,iCell,1,1) = CC%ConservedQuantity(:,UG%VC%Cell(iCell,1),1,1)
    end do

!    do iCell=1, UG%GI%RealCells
!        MG%IS(iCell)%InfluenceDepth = 0
!    end do

return
end subroutine DataFabrication4FirstStep


text:
! Find out that the number being looked for Simple_Xwing must exist for
! all the possible combinations available for both the cages (VERY IMP !!)

SUBROUTINE Simple_XWing

  USE global_variables
  IMPLICIT NONE

  INTEGER :: i_row1,i_row2,j_column,i
  INTEGER,DIMENSION(9) :: temp_array1,temp_array2,temp_array3
  INTEGER :: inumber,jnumber,temp_number1,temp_number2,temp_number3
  INTEGER :: cell_ij_numbers,cell_ij_logic_number
  INTEGER,DIMENSION(2) :: xwing1_column,xwing2_column
  INTEGER,DIMENSION(2) :: xwing1_row,xwing2_row
  INTEGER :: j_column1,j_column2,i_row,i_row3,j_column3
  INTEGER :: j,cage1h_real,ncells1,icell,row1,col1
  INTEGER :: row_temp1,col_temp1,cage_temp1,cage_temp2
  INTEGER :: cage2h_real,ncells2,jcell,row2,col2
  INTEGER :: vertical_cage11,vertical_cage12
  INTEGER :: vertical_cage21,vertical_cage22
  INTEGER :: vicell,vncells1,vrow1,vcol1
  INTEGER :: horizontal_cage11,horizontal_cage12
  INTEGER :: horizontal_cage21,horizontal_cage22
  INTEGER :: check_number
  INTEGER,DIMENSION(9) :: temp_array_new
  INTEGER :: ncount

  DO i=1,nhorizontal_cages
    cage1h_real=horizontal_cages(i)
    ncells1=cage_no_of_cells(cage1h_real)
    temp_array1=0
    DO icell=1,ncells1
      row1=cage_to_cells(cage1h_real,icell,1)
      col1=cage_to_cells(cage1h_real,icell,2)
!      cage_temp1=cell_to_cage(row1,col1,1)
!      cage_temp2=cell_to_cage(row1,col1,2)
!      IF (cage_temp1 .eq. cage1h_real) THEN
!        vertical_cage11 = cage_temp2
!      ELSE IF (cage_temp2 .eq. cage1h_real) THEN
!        vertical_cage11 = cage_temp1
!      ELSE
!        write(*,*) 'SOMETHING IS wrong: Find_2permutation_horizontalcage -1'
!        STOP
!      END IF
       IF (sudoku(row1,col1) .ne. 0) CYCLE
       cell_ij_numbers=sudoku_logic_values(row1,col1)
       DO inumber=1,cell_ij_numbers
	 cell_ij_logic_number=sudoku_logic(row1,col1,inumber)
	 temp_array1(cell_ij_logic_number) = temp_array1(cell_ij_logic_number)+1
       END DO
     END DO
     DO jnumber=1,9
       temp_number1=0
       xwing1_column=0
       xwing1_row=0
       IF (temp_array1(jnumber) .eq. 2) THEN
!------------------------------------------------------------------------
!------- check that jnumber must exist for all possible combinations for
!------- this cage ------------------------------------------------------
	 check_number=0
	 ncount=0
	 temp_array_new=0
         CALL check_sure_number(cage1h_real,jnumber,check_number,ncount,temp_array_new)
!         IF (ncount .eq. 0) THEN
!           write(*,*) 'SOMETHING IS WRONG - check sure number'
!           STOP
!         END IF
	 IF (check_number .eq. 0) CYCLE
!------------------------------------------------------------------------
	 DO icell=1,ncells1
	   row1=cage_to_cells(cage1h_real,icell,1)
	   col1=cage_to_cells(cage1h_real,icell,2)
	   cell_ij_numbers=sudoku_logic_values(row1,col1)
	   DO inumber=1,cell_ij_numbers
	     cell_ij_logic_number=sudoku_logic(row1,col1,inumber)
	     IF (cell_ij_logic_number .eq. jnumber) THEN
	       temp_number1=temp_number1+1
	       xwing1_column(temp_number1)=col1
	       xwing1_row(temp_number1)=row1
	     END IF
	   END DO
          END DO

          row_temp1=xwing1_row(1)
	  col_temp1=xwing1_column(1)
	  cage_temp1=cell_to_cage(row_temp1,col_temp1,1)
	  cage_temp2=cell_to_cage(row_temp1,col_temp1,2)
	  IF (cage_temp1 .eq. cage1h_real) THEN
	    vertical_cage11=cage_temp2
	  ELSE IF (cage_temp2 .eq. cage1h_real) THEN
	    vertical_cage11=cage_temp1
	  ELSE
	    write(*,*) 'SOMETHING IS wronge'
	    STOP
	  END IF

          row_temp1=xwing1_row(2)
          col_temp1=xwing1_column(2)
          cage_temp1=cell_to_cage(row_temp1,col_temp1,1)
          cage_temp2=cell_to_cage(row_temp1,col_temp1,2)
          IF (cage_temp1 .eq. cage1h_real) THEN
            vertical_cage12=cage_temp2
          ELSE IF (cage_temp2 .eq. cage1h_real) THEN
            vertical_cage12=cage_temp1
          ELSE
            write(*,*) 'SOMETHING IS wronge'
            STOP
          END IF

	  DO j=i+1,nhorizontal_cages
	    cage2h_real=horizontal_cages(j)
	    ncells2=cage_no_of_cells(cage2h_real)
	    temp_array2=0
	    DO jcell=1,ncells2
	      row2=cage_to_cells(cage2h_real,jcell,1)
	      col2=cage_to_cells(cage2h_real,jcell,2)
	      IF (sudoku(row2,col2) .ne. 0) CYCLE
	      cell_ij_numbers=sudoku_logic_values(row2,col2)
	      DO inumber=1,cell_ij_numbers
		cell_ij_logic_number=sudoku_logic(row2,col2,inumber)
		temp_array2(cell_ij_logic_number)=temp_array2(cell_ij_logic_number)+1
	      END DO
	    END DO

	    temp_number2=0
	    xwing2_column=0
	    IF (temp_array2(jnumber) .ne. 2) CYCLE
!------------------------------------------------------------------------
!------- check that jnumber must exist for all possible combinations for
!------- this cage ------------------------------------------------------
            check_number=0
	    ncount=0
	    temp_array_new=0
            CALL check_sure_number(cage2h_real,jnumber,check_number,ncount,temp_array_new)
!         IF (ncount .eq. 0) THEN
!           write(*,*) 'SOMETHING IS WRONG - check sure number'
!           STOP
!         END IF
            IF (check_number .eq. 0) CYCLE
!------------------------------------------------------------------------
	    DO jcell=1,ncells2
	      row2=cage_to_cells(cage2h_real,jcell,1)
	      col2=cage_to_cells(cage2h_real,jcell,2)
	      cell_ij_numbers=sudoku_logic_values(row2,col2)
	      DO inumber=1,cell_ij_numbers
		cell_ij_logic_number=sudoku_logic(row2,col2,inumber)
		IF (cell_ij_logic_number .eq. jnumber) THEN
		  temp_number2=temp_number2+1
		  xwing2_column(temp_number2)=col2
		  xwing2_row(temp_number2)=row2
		END IF
	      END DO
            END DO

            row_temp1=xwing2_row(1)
            col_temp1=xwing2_column(1)
            cage_temp1=cell_to_cage(row_temp1,col_temp1,1)
            cage_temp2=cell_to_cage(row_temp1,col_temp1,2)
            IF (cage_temp1 .eq. cage2h_real) THEN
              vertical_cage21=cage_temp2
            ELSE IF (cage_temp2 .eq. cage2h_real) THEN
              vertical_cage21=cage_temp1
            ELSE
              write(*,*) 'SOMETHING IS wrong'
              STOP
            END IF

            row_temp1=xwing2_row(2)
            col_temp1=xwing2_column(2)
            cage_temp1=cell_to_cage(row_temp1,col_temp1,1)
            cage_temp2=cell_to_cage(row_temp1,col_temp1,2)
            IF (cage_temp1 .eq. cage2h_real) THEN
              vertical_cage22=cage_temp2
            ELSE IF (cage_temp2 .eq. cage2h_real) THEN
              vertical_cage22=cage_temp1
            ELSE
              write(*,*) 'SOMETHING IS wrong'
              STOP
            END IF

! Check if two Xwing1_row and xwing2_row are the same for both the columns
            IF ((vertical_cage11 .eq. vertical_cage21) .AND. &
			(vertical_cage12 .eq. vertical_cage22)) THEN
	       ! We have simple Xwing.. Remove this number from other squares
	       ! of the 2 columns (vertical_cage11 and vertical_cage12)
	       vncells1=cage_no_of_cells(vertical_cage11)
	       DO vicell=1,vncells1
		 temp_number3=0
		 temp_array3=0
		 vrow1=cage_to_cells(vertical_cage11,vicell,1)
		 vcol1=cage_to_cells(vertical_cage11,vicell,2)
		 IF (sudoku(vrow1,vcol1) .ne. 0) CYCLE
		 IF (vrow1 .eq. xwing1_row(1)) CYCLE
		 IF (vrow1 .eq. xwing2_row(1)) CYCLE
		 cell_ij_numbers=sudoku_logic_values(vrow1,vcol1)
		 DO inumber=1,cell_ij_numbers
		   cell_ij_logic_number=sudoku_logic(vrow1,vcol1,inumber)
		   IF (cell_ij_logic_number .eq. jnumber) CYCLE
		   temp_number3=temp_number3+1
		   temp_array3(temp_number3)=cell_ij_logic_number
		 END DO
		 DO inumber=1,cell_ij_numbers
		   sudoku_logic(vrow1,vcol1,inumber)=0
		 END DO
		 sudoku_logic_values(vrow1,vcol1)=temp_number3
		 DO inumber=1,temp_number3
		   sudoku_logic(vrow1,vcol1,inumber)=temp_array3(inumber)
		 END DO
	       END DO

               vncells1=cage_no_of_cells(vertical_cage12)
               DO vicell=1,vncells1
                 temp_number3=0
                 temp_array3=0
                 vrow1=cage_to_cells(vertical_cage12,vicell,1)
                 vcol1=cage_to_cells(vertical_cage12,vicell,2)
                 IF (sudoku(vrow1,vcol1) .ne. 0) CYCLE
                 IF (vrow1 .eq. xwing1_row(1)) CYCLE
                 IF (vrow1 .eq. xwing2_row(1)) CYCLE
                 cell_ij_numbers=sudoku_logic_values(vrow1,vcol1)
                 DO inumber=1,cell_ij_numbers
                   cell_ij_logic_number=sudoku_logic(vrow1,vcol1,inumber)
                   IF (cell_ij_logic_number .eq. jnumber) CYCLE
                   temp_number3=temp_number3+1
                   temp_array3(temp_number3)=cell_ij_logic_number
                 END DO
                 DO inumber=1,cell_ij_numbers
                   sudoku_logic(vrow1,vcol1,inumber)=0
                 END DO
                 sudoku_logic_values(vrow1,vcol1)=temp_number3
                 DO inumber=1,temp_number3
                   sudoku_logic(vrow1,vcol1,inumber)=temp_array3(inumber)
                 END DO
               END DO
	     END IF
 	   END DO
	  END IF
	 END DO
       END DO

  DO i=1,nvertical_cages
    cage1h_real=vertical_cages(i)
    ncells1=cage_no_of_cells(cage1h_real)
    temp_array1=0
    DO icell=1,ncells1
      row1=cage_to_cells(cage1h_real,icell,1)
      col1=cage_to_cells(cage1h_real,icell,2)
!      cage_temp1=cell_to_cage(row1,col1,1)
!      cage_temp2=cell_to_cage(row1,col1,2)
!      IF (cage_temp1 .eq. cage1h_real) THEN
!        vertical_cage11 = cage_temp2
!      ELSE IF (cage_temp2 .eq. cage1h_real) THEN
!        vertical_cage11 = cage_temp1
!      ELSE
!        write(*,*) 'SOMETHING IS wrong: Find_2permutation_horizontalcage -1'
!        STOP
!      END IF
       IF (sudoku(row1,col1) .ne. 0) CYCLE
       cell_ij_numbers=sudoku_logic_values(row1,col1)
       DO inumber=1,cell_ij_numbers
         cell_ij_logic_number=sudoku_logic(row1,col1,inumber)
         temp_array1(cell_ij_logic_number) = temp_array1(cell_ij_logic_number)+1
       END DO
     END DO
     DO jnumber=1,9
       temp_number1=0
       xwing1_column=0
       xwing1_row=0
       IF (temp_array1(jnumber) .eq. 2) THEN
!------------------------------------------------------------------------
!------- check that jnumber must exist for all possible combinations for
!------- this cage ------------------------------------------------------
         check_number=0
	 ncount=0
	 temp_array_new=0
         CALL check_sure_number(cage1h_real,jnumber,check_number,ncount,temp_array_new)
!         IF (ncount .eq. 0) THEN
!           write(*,*) 'SOMETHING IS WRONG - check sure number'
!           STOP
!         END IF
         IF (check_number .eq. 0) CYCLE
!------------------------------------------------------------------------
         DO icell=1,ncells1
           row1=cage_to_cells(cage1h_real,icell,1)
           col1=cage_to_cells(cage1h_real,icell,2)
           cell_ij_numbers=sudoku_logic_values(row1,col1)
           DO inumber=1,cell_ij_numbers
             cell_ij_logic_number=sudoku_logic(row1,col1,inumber)
             IF (cell_ij_logic_number .eq. jnumber) THEN
               temp_number1=temp_number1+1
               xwing1_column(temp_number1)=col1
               xwing1_row(temp_number1)=row1
             END IF
           END DO
          END DO

          row_temp1=xwing1_row(1)
          col_temp1=xwing1_column(1)
          cage_temp1=cell_to_cage(row_temp1,col_temp1,1)
          cage_temp2=cell_to_cage(row_temp1,col_temp1,2)
          IF (cage_temp1 .eq. cage1h_real) THEN
            horizontal_cage11=cage_temp2
          ELSE IF (cage_temp2 .eq. cage1h_real) THEN
            horizontal_cage11=cage_temp1
          ELSE
            write(*,*) 'SOMETHING IS wronge'
            STOP
          END IF

          row_temp1=xwing1_row(2)
          col_temp1=xwing1_column(2)
          cage_temp1=cell_to_cage(row_temp1,col_temp1,1)
          cage_temp2=cell_to_cage(row_temp1,col_temp1,2)
          IF (cage_temp1 .eq. cage1h_real) THEN
            horizontal_cage12=cage_temp2
          ELSE IF (cage_temp2 .eq. cage1h_real) THEN
            horizontal_cage12=cage_temp1
          ELSE
            write(*,*) 'SOMETHING IS wronge'
            STOP
          END IF

          DO j=i+1,nvertical_cages
            cage2h_real=vertical_cages(j)
            ncells2=cage_no_of_cells(cage2h_real)
            temp_array2=0
            DO jcell=1,ncells2
              row2=cage_to_cells(cage2h_real,jcell,1)
              col2=cage_to_cells(cage2h_real,jcell,2)
              IF (sudoku(row2,col2) .ne. 0) CYCLE
              cell_ij_numbers=sudoku_logic_values(row2,col2)
              DO inumber=1,cell_ij_numbers
                cell_ij_logic_number=sudoku_logic(row2,col2,inumber)
                temp_array2(cell_ij_logic_number)=temp_array2(cell_ij_logic_number)+1
              END DO
            END DO

            temp_number2=0
            xwing2_column=0
            IF (temp_array2(jnumber) .ne. 2) CYCLE
!------------------------------------------------------------------------
!------- check that jnumber must exist for all possible combinations for
!------- this cage ------------------------------------------------------
            check_number=0
	    ncount=0
	    temp_array_new=0
            CALL check_sure_number(cage2h_real,jnumber,check_number,ncount,temp_array_new)
!         IF (ncount .eq. 0) THEN
!           write(*,*) 'SOMETHING IS WRONG - check sure number'
!           STOP
!         END IF
            IF (check_number .eq. 0) CYCLE
!------------------------------------------------------------------------
            DO jcell=1,ncells2
              row2=cage_to_cells(cage2h_real,jcell,1)
              col2=cage_to_cells(cage2h_real,jcell,2)
              cell_ij_numbers=sudoku_logic_values(row2,col2)
              DO inumber=1,cell_ij_numbers
                cell_ij_logic_number=sudoku_logic(row2,col2,inumber)
                IF (cell_ij_logic_number .eq. jnumber) THEN
                  temp_number2=temp_number2+1
                  xwing2_column(temp_number2)=col2
                  xwing2_row(temp_number2)=row2
                END IF
              END DO
            END DO

            row_temp1=xwing2_row(1)
            col_temp1=xwing2_column(1)
            cage_temp1=cell_to_cage(row_temp1,col_temp1,1)
            cage_temp2=cell_to_cage(row_temp1,col_temp1,2)
            IF (cage_temp1 .eq. cage2h_real) THEN
              horizontal_cage21=cage_temp2
            ELSE IF (cage_temp2 .eq. cage2h_real) THEN
              horizontal_cage21=cage_temp1
            ELSE
              write(*,*) 'SOMETHING IS wrong'
              STOP
            END IF

            row_temp1=xwing2_row(2)
            col_temp1=xwing2_column(2)
            cage_temp1=cell_to_cage(row_temp1,col_temp1,1)
            cage_temp2=cell_to_cage(row_temp1,col_temp1,2)
            IF (cage_temp1 .eq. cage2h_real) THEN
              horizontal_cage22=cage_temp2
            ELSE IF (cage_temp2 .eq. cage2h_real) THEN
              horizontal_cage22=cage_temp1
            ELSE
              write(*,*) 'SOMETHING IS wrong'
              STOP
            END IF

! Check if two Xwing1_row and xwing2_row are the same for both the columns
            IF ((horizontal_cage11 .eq. horizontal_cage21) .AND. &
                        (horizontal_cage12 .eq. horizontal_cage22)) THEN
               ! We have simple Xwing.. Remove this number from other squares
               ! of the 2 columns (vertical_cage11 and vertical_cage12)
               vncells1=cage_no_of_cells(horizontal_cage11)
               DO vicell=1,vncells1
                 temp_number3=0
                 temp_array3=0
                 vrow1=cage_to_cells(horizontal_cage11,vicell,1)
                 vcol1=cage_to_cells(horizontal_cage11,vicell,2)
                 IF (sudoku(vrow1,vcol1) .ne. 0) CYCLE
                 IF (vcol1 .eq. xwing1_column(1)) CYCLE
                 IF (vcol1 .eq. xwing2_column(1)) CYCLE
                 cell_ij_numbers=sudoku_logic_values(vrow1,vcol1)
                 DO inumber=1,cell_ij_numbers
                   cell_ij_logic_number=sudoku_logic(vrow1,vcol1,inumber)
                   IF (cell_ij_logic_number .eq. jnumber) CYCLE
                   temp_number3=temp_number3+1
                   temp_array3(temp_number3)=cell_ij_logic_number
                 END DO
                 DO inumber=1,cell_ij_numbers
                   sudoku_logic(vrow1,vcol1,inumber)=0
                 END DO
                 sudoku_logic_values(vrow1,vcol1)=temp_number3
                 DO inumber=1,temp_number3
                   sudoku_logic(vrow1,vcol1,inumber)=temp_array3(inumber)
                 END DO
               END DO
               vncells1=cage_no_of_cells(horizontal_cage12)
               DO vicell=1,vncells1
                 temp_number3=0
                 temp_array3=0
                 vrow1=cage_to_cells(horizontal_cage12,vicell,1)
                 vcol1=cage_to_cells(horizontal_cage12,vicell,2)
                 IF (sudoku(vrow1,vcol1) .ne. 0) CYCLE
                 IF (vcol1 .eq. xwing1_column(1)) CYCLE
                 IF (vcol1 .eq. xwing2_column(1)) CYCLE
                 cell_ij_numbers=sudoku_logic_values(vrow1,vcol1)
                 DO inumber=1,cell_ij_numbers
                   cell_ij_logic_number=sudoku_logic(vrow1,vcol1,inumber)
                   IF (cell_ij_logic_number .eq. jnumber) CYCLE
                   temp_number3=temp_number3+1
                   temp_array3(temp_number3)=cell_ij_logic_number
                 END DO
                 DO inumber=1,cell_ij_numbers
                   sudoku_logic(vrow1,vcol1,inumber)=0
                 END DO
                 sudoku_logic_values(vrow1,vcol1)=temp_number3
                 DO inumber=1,temp_number3
                   sudoku_logic(vrow1,vcol1,inumber)=temp_array3(inumber)
                 END DO
               END DO
             END IF
           END DO
          END IF
         END DO
       END DO

END SUBROUTINE Simple_XWing

!--------------------------------------------------------

SUBROUTINE check_sure_number(cage1h_real,jnumber,check_number,ncount,temp_array_new)

  USE global_variables
  IMPLICIT NONE

  INTEGER :: cage1h_real,jnumber,check_number
  INTEGER,DIMENSION(naked_list_max,4,2) :: naked_list
  INTEGER,DIMENSION(9) :: naked_values
  INTEGER, pointer :: pa(:,:,:)
  INTEGER :: lower_state,cell_value,cage_cells,cage_sum_local
  INTEGER :: check1,total_permutations
  INTEGER :: j_cell,k_cell
  INTEGER,DIMENSION(9) :: temp_check,temp_array_new
  INTEGER :: temp_check_count,ii_cell,inaked,ncount
  INTEGER :: rowk,colk,inumber

		  check_number=0
                  cage_cells=cage_no_of_cells(cage1h_real)
                  cage_sum_local=cage_sum(cage1h_real)

                  temp_check=0
                  temp_check_count=0
                  DO ii_cell=1,cage_cells
                     rowk=cage_to_cells(cage1h_real,ii_cell,1)
                     colk=cage_to_cells(cage1h_real,ii_cell,2)
                     IF (sudoku(rowk,colk) .gt. 0) THEN
                        temp_check(sudoku(rowk,colk))=1
                        temp_check_count=temp_check_count+1
                     END IF
                  END DO
!                  naked_list=0
!                  naked_values=0
!                  CALL Naked_pairs(cage1h_real,naked_list,naked_values)
!                  DO inaked=1,9
!                    IF (naked_values(inaked) .eq. 1) THEN
!                        temp_check(inaked) = 1
!                         temp_check_count=temp_check_count+1
!                    END IF
!                  END DO

     IF (cage_cells .eq. 2) THEN
        pa => cell_2(3:17,:,:)
        lower_state = 3
        total_permutations=4
     ELSE IF (cage_cells .eq. 3) THEN
        pa => cell_3(6:24,:,:)
        lower_state = 6
        total_permutations=8
     ELSE IF (cage_cells .eq. 4) THEN
        pa => cell_4(10:30,:,:)
        lower_state = 10
        total_permutations=12
     ELSE IF (cage_cells .eq. 5) THEN
        pa => cell_5(15:35,:,:)
        lower_state = 15
        total_permutations=12
     ELSE IF (cage_cells .eq. 6) THEN
        pa => cell_6(21:39,:,:)
        lower_state = 21
        total_permutations=8
     ELSE IF (cage_cells .eq. 7) THEN
        pa => cell_7(28:42,:,:)
        lower_state = 28
        total_permutations=4
     ELSE IF (cage_cells .eq. 8) THEN
        pa => cell_8(36:44,:,:)
        lower_state = 36
        total_permutations=1
     ELSE IF (cage_cells .eq. 9) THEN
        pa => cell_9(45:45,:,:)
        lower_state = 45
        total_permutations=1
     ELSE
        write(*,*) 'cage cells not between 2 and 9'
        STOP
     END IF

                 temp_array_new=0
                 ncount=0
                 DO inumber=1,total_permutations
                   IF (pa(cage_sum_local-lower_state+1,inumber,1) .eq. 0) THEN
                     EXIT
                   END IF
                   check1=0
                   DO k_cell=1,cage_cells
                     cell_value=pa(cage_sum_local-lower_state+1,inumber,k_cell)
                     IF (temp_check(cell_value) .eq. 1) THEN
                        check1=check1+1
                     END IF
                   END DO
!                   IF (temp_check_count .gt. 1) THEN
                   IF (temp_check_count .ge. 1) THEN
                    IF (check1 .eq. temp_check_count) THEN
                     ncount=ncount+1
                     DO j_cell=1,cage_cells
                       cell_value=pa(cage_sum_local-lower_state+1,inumber,j_cell)
                       temp_array_new(cell_value)=temp_array_new(cell_value)+1
                     END  DO
                    END IF
                   END IF
                 END DO

		IF (ncount .gt. 0) THEN
                 IF (temp_array_new(jnumber) .eq. ncount) THEN
		   check_number = 1
		 END IF
		END IF

END SUBROUTINE check_sure_number

!--------------------------------------------------------

max_stars_repo_name: surendra-jain/kakuro-solver

max_issues_repo_name: surendra-jain/kakuro-solver

max_forks_repo_name: surendra-jain/kakuro-solver


! { dg-do compile }
! { dg-options "-fcoarray=single" }
!
! Contributed by Reinhold Bader
!
!
program def_and_ref
! compile only
  use, intrinsic :: iso_fortran_env
  implicit none
  type :: e
    integer(kind=atomic_int_kind) :: ia = 0
    logical(kind=atomic_logical_kind) :: la = .false.
  end type

  type(e) :: a[*]

  integer :: ival = 0
  logical :: lval = .false.

  if (this_image() == 1) then
    call atomic_define(a[num_images()]%ia, 4)
    call atomic_define(a[num_images()]%la, .true.)
  end if
  if (this_image() == num_images()) then
    do while (ival == 0 .or. .not. lval)
       call atomic_ref(ival, a%ia)
       call atomic_ref(lval, a%la)
    end do
    if (ival == 4 .and. lval) then
      write(*,*) 'OK'
    else
      write(*,*) 'FAIL: ival,lval =', ival, lval
    end if
  end if
end program


text:
program spacemarine

   use boxlib
   use multifab_module
   use bl_IO_module
   use ml_layout_module
   use problem_module
   use write_plotfile_module
   use advance_module
   use define_bc_module
   use make_new_grids_module
   use regrid_module
   use solvers, only: solver_init
   use source_module, only: source_init

   implicit none

   ! stuff you can set with the inputs file (otherwise use default values below)
   integer    :: max_levs, dim, nsteps, plot_int, n_cell, max_grid_size
   integer    :: amr_buf_width, cluster_minwidth, cluster_blocking_factor
   real(dp_t) :: cluster_min_eff
   integer    :: regrid_int
   integer    :: bc_x_lo, bc_x_hi, bc_y_lo, bc_y_hi, bc_z_lo, bc_z_hi

   ! dummy indices using for reading in inputs file
   integer :: un, farg, narg
   logical :: need_inputs_file, found_inputs_file
   character(len=128) :: inputs_file_name

   ! will be allocated with dim components
   integer       , allocatable :: lo(:), hi(:)
   logical       , allocatable :: is_periodic(:)
   real(dp_t)    , allocatable :: prob_lo(:), prob_hi(:)

  ! will be allocated with (dim,2) components
   integer       , allocatable :: phys_bc(:,:)

  ! will be allocated with max_levs components
   real(dp_t)    , allocatable :: dx(:)
   type(multifab), allocatable :: phi(:)

   integer    :: istep,i,n,nl,nlevs,nvars
   logical    :: new_grid
   real(dp_t) :: dt,time,start_time,run_time,run_time_IOproc

   type(box)         :: bx
   type(ml_boxarray) :: mba
   type(ml_layout)   :: mla
   type(layout), allocatable :: la_array(:)

   type(bc_tower) :: the_bc_tower

   namelist /probin/ max_levs, nvars, dim, nsteps, plot_int, n_cell, max_grid_size, amr_buf_width, &
        cluster_minwidth, cluster_blocking_factor, cluster_min_eff, regrid_int, &
        bc_x_lo, bc_x_hi, bc_y_lo, bc_y_hi, bc_z_lo, bc_z_hi

  ! if running in parallel, this will print out the number of MPI
  ! processes and OpenMP threads
   call boxlib_initialize()

   if( parallel_IOProcessor() ) call print_name()

  ! parallel_wtime() returns the number of wallclock-time seconds since
  ! the program began
   start_time = parallel_wtime()

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! default values - will get overwritten by the inputs file
   max_levs      = 4
   dim           = 2
   nvars         = 5        ! always include vz, even if not actually used
   nsteps        = 1000
   plot_int      = 100
   n_cell        = 32
 ! AMR stuff
   max_grid_size = n_cell/2
   amr_buf_width = 4
   cluster_minwidth = 4
   cluster_blocking_factor = 4
   cluster_min_eff = 0.8d0
   regrid_int = 4

  ! allowable options for this example are
  ! -1 = PERIODIC
  ! 12 = OUTLET (dphi/dn=0 at boundary)
  ! 15 = NO_SLIP_WALL (wall with fixed phi=1)
   bc_x_lo       = 15 ! NO_SLIP
   bc_x_hi       = 12 ! OUTLET
   bc_y_lo       = 15 ! NO_SLIP
   bc_y_hi       = 12 ! OUTLET
   bc_z_lo       = -1 ! PERIODIC
   bc_z_hi       = -1 ! PERIODIC

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  ! read inputs file and overwrite any default values
   narg = command_argument_count()
   need_inputs_file = .true.
   farg = 1
   if( narg >= 1 ) then
      call get_command_argument(farg, value = inputs_file_name)
      inquire(file = inputs_file_name, exist = found_inputs_file )
      if( found_inputs_file ) then
         farg = farg + 1
         un = unit_new()
         open(unit=un, file = inputs_file_name, status = 'old', action = 'read')
         read(unit=un, nml = probin)
         close(unit=un)
         need_inputs_file = .false.
      endif
   endif

  ! now that we have dim, we can allocate these
   allocate(lo(dim),hi(dim))
   allocate(is_periodic(dim))
   allocate(prob_lo(dim),prob_hi(dim))
   allocate(phys_bc(dim,2))

  ! now that we have max_levs, we can allocate these
   allocate(dx(max_levs))
   allocate(phi(max_levs))
   allocate(la_array(max_levs))

  ! put all the domain boundary conditions into phys_bc
   phys_bc(1,1) = bc_x_lo
   phys_bc(1,2) = bc_x_hi
   phys_bc(2,1) = bc_y_lo
   phys_bc(2,2) = bc_y_hi
   if(dim == 3) then
      phys_bc(3,1) = bc_z_lo
      phys_bc(3,2) = bc_z_hi
   endif

  ! build an array indicating periodicity in each direction
   is_periodic(:) = .false.
   do i=1,dim
      if(phys_bc(i,1) == -1 .and. phys_bc(i,2) .ne. -1) then
         call bl_error("Invalid BC's - both lo and hi need to be periodic")
      endif
      if(phys_bc(i,2) == -1 .and. phys_bc(i,1) .ne. -1) then
         call bl_error("Invalid BC's - both lo and hi need to be periodic")
      endif
      if(phys_bc(i,1) == -1 .and. phys_bc(i,2) == -1) then
         is_periodic(i) = .true.
      endif
   enddo

   call cluster_set_minwidth(cluster_minwidth)
   call cluster_set_blocking_factor(cluster_blocking_factor)
   call cluster_set_min_eff(cluster_min_eff)

  ! tell mba about max_levs and dimensionality of problem
   call ml_boxarray_build_n(mba,max_levs,dim)

  ! tell mba about the ref_ratio between levels
  ! mba%rr(n-1,i) is the refinement ratio between levels n-1 and n in direction i
  ! we use refinement ratio of 2 in every direction between all levels
   do n=2,max_levs
      mba%rr(n-1,:) = 2
   enddo

  ! physical problem is a box on (-1,-1) to (1,1)
   prob_lo(:) =  0.d0
   prob_hi(:) =  1.d0

  ! set grid spacing at each level
  ! the grid spacing is the same in each direction
   dx(1) = (prob_hi(1)-prob_lo(1)) / n_cell
   do n=2,max_levs
      dx(n) = dx(n-1) / mba%rr(n-1,1)
   enddo

  ! initialize the variables
   call solver_init(nvars)
   call source_init()

  ! tell the_bc_tower about max_levs, dim, and phys_bc
   call bc_tower_init(the_bc_tower,max_levs,dim,phys_bc)

  ! create a box from (0,0) to (n_cell-1,n_cell-1)
   lo(:) = 0
   hi(:) = n_cell-1
   bx = make_box(lo,hi)

  ! tell mba about the problem domain at each level
   mba%pd(1) = bx
   do n=2,max_levs
      mba%pd(n) = refine(mba%pd(n-1),mba%rr((n-1),:))
   enddo

  ! initialize the boxarray at level 1 to be one single box
   call boxarray_build_bx(mba%bas(1),bx)

  ! overwrite the boxarray at level 1 to respect max_grid_size
   call boxarray_maxsize(mba%bas(1),max_grid_size)

  ! build the level 1 layout
   call layout_build_ba(la_array(1),mba%bas(1),mba%pd(1),is_periodic)

  ! build the level 1 multifab with NVARs component and 2 ghost cell
   call multifab_build(phi(1),la_array(1),nvars,2)

  ! define level 1 of the_bc_tower
   call bc_tower_level_build(the_bc_tower,1,la_array(1))

  ! initialize phi on level 1
   call init_phi_on_level(phi(1),dx(1),prob_lo,nvars,the_bc_tower%bc_tower_array(1))

   nl = 1
   new_grid = .true.

   do while( (nl < max_levs) .and. (new_grid) )
     ! determine whether we need finer grids based on tagging criteria
     ! if so, return new_grid=T and the la_array(nl+1)
      call make_new_grids(new_grid,la_array(nl),la_array(nl+1),phi(nl),dx(nl), &
                          amr_buf_width,mba%rr(nl,1),nl,max_grid_size)

      if(new_grid) then
        ! tell mba about the finer level boxarray
         call copy(mba%bas(nl+1),get_boxarray(la_array(nl+1)))

        ! Build the level nl+1 data
         call multifab_build(phi(nl+1),la_array(nl+1),nvars,2)

        ! define level nl+1 of the_bc_tower
         call bc_tower_level_build(the_bc_tower,nl+1,la_array(nl+1))

        ! initialize phi on level nl+1
         call init_phi_on_level(phi(nl+1),dx(nl+1),prob_lo,nvars,the_bc_tower%bc_tower_array(nl+1))

        ! increment current level counter
         nl = nl+1
      endif
   enddo

  ! the current number of levels in the simulation is nlevs, not necessarily max_levs
   nlevs = nl

  ! destroy phi - we are going to build it again using the new multilevel
  ! layout after we have tested and reconfigured the grids due to proper nesting
   do n=1,nlevs
      call multifab_destroy(phi(n))
   enddo

   if(nlevs >= 3) then
     ! check for proper nesting
      call enforce_proper_nesting(mba,la_array,max_grid_size)
   endif

   do n=1,nlevs
      call destroy(la_array(n))
   enddo

  ! tell mla that there are nlevs levels, not max_levs
   call ml_layout_restricted_build(mla,mba,nlevs,is_periodic)

  ! this makes sure the boundary conditions are properly defined everywhere
   do n = 1,nlevs
      call bc_tower_level_build(the_bc_tower,n,mla%la(n))
   enddo

   do n=1,nlevs
      call multifab_build(phi(n),mla%la(n),nvars,2)
   enddo

   call init_phi(mla,phi,dx,prob_lo,nvars,the_bc_tower)

   call destroy(mba)

   istep = 0
   time = 0.d0

  ! choose a time step with a diffusive CFL of 0.9 base on resolution
  ! at max_levs, even if nlevs < max_levs
   dt = 0.9d0*dx(max_levs)**2/(2.d0*dim)

  ! write out plotfile 0
   !call regrid(mla,phi,nlevs,max_levs,dx,the_bc_tower,amr_buf_width,max_grid_size)
   call write_plotfile(mla,phi,istep,dx,nvars,time,prob_lo,prob_hi)
   !stop

   do istep=1,nsteps

     ! regrid
      if( istep > 1 .and. max_levs > 1 ) then
         if( regrid_int > 0 ) then
            if( (mod(istep-1,regrid_int) == 0) ) then
               call regrid(mla,phi,nlevs,max_levs,dx,the_bc_tower,amr_buf_width,max_grid_size)
            endif
         endif
      endif

     ! we only want one processor to write to screen
      if( parallel_IOProcessor() ) then
         print*,'Advancing time step',istep,'with dt=',dt
      endif

     ! advance phi & then update dt for the new
      call advance(mla,phi,dx,dt,nvars,the_bc_tower)
      time = time + dt
      call get_new_timestep(mla, phi, dx, dt)

      if(mod(istep,plot_int) == 0 .or. istep == nsteps) then
        ! write out plotfile
         call write_plotfile(mla,phi,istep,dx,nvars,time,prob_lo,prob_hi)
      endif
   enddo

  ! make sure to destroy the multifab or you'll leak memory
   do n=1,nlevs
      call destroy(phi(n))
   enddo
   call destroy(mla)
   call bc_tower_destroy(the_bc_tower)

  deallocate(lo,hi,is_periodic,prob_lo,prob_hi)

  ! deallocate temporary boxarrays and communication mappings
  call layout_flush_copyassoc_cache ()

  ! check for memory that should have been deallocated
  if( parallel_IOProcessor() ) then
     print*, 'MEMORY STATS AT END OF PROGRAM'
     print*, ' '
  endif
  call print(multifab_mem_stats(),    "    multifab")
  call print(fab_mem_stats(),         "         fab")
  call print(boxarray_mem_stats(),    "    boxarray")
  call print(layout_mem_stats(),      "      layout")
  call print(boxassoc_mem_stats(),    "    boxassoc")
  call print(fgassoc_mem_stats(),     "     fgassoc")
  call print(syncassoc_mem_stats(),   "   syncassoc")
  call print(copyassoc_mem_stats(),   "   copyassoc")
  call print(fluxassoc_mem_stats(),   "   fluxassoc")

  ! parallel_wtime() returns the number of wallclock-time seconds since
  ! the program began
  run_time = parallel_wtime() - start_time

  ! collect run_time from each processor and store the maximum
  call parallel_reduce(run_time_IOproc, run_time, MPI_MAX, &
                       proc = parallel_IOProcessorNode())

  if( parallel_IOProcessor() ) then
     print*,"Run time (s) =",run_time_IOproc
  endif

  call boxlib_finalize()

contains

  !> print name of code
  subroutine print_name()
    print*,">----------------------------------------------------------------------------<"
    print*,"||   _____                      __  __          _____  _____ _   _ ______   ||"
    print*,"||  / ____|                    |  \/  |   /\   |  __ \|_   _| \ | |  ____|  ||"
    print*,"|| | (___  _ __   __ _  ___ ___| \  / |  /  \  | |__) | | | |  \| | |__     ||"
    print*,"||  \___ \| '_ \ / _` |/ __/ _ \ |\/| | / /\ \ |  _  /  | | | . ` |  __|    ||"
    print*,"||  ____) | |_) | (_| | (_|  __/ |  | |/ ____ \| | \ \ _| |_| |\  | |____   ||"
    print*,"|| |_____/| .__/ \__,_|\___\___|_|  |_/_/    \_\_|  \_\_____|_| \_|______|  ||"
    print*,"||        | |                                                               ||"
    print*,"||        |_|                   By Kyle Kanos                               ||"
    print*,"||                                                                          ||"
    print*,">----------------------------------------------------------------------------<"

  end subroutine print_name

end program spacemarine

max_stars_repo_name: kylekanos/spaceMARINE

max_issues_repo_name: kylekanos/spaceMARINE

max_forks_repo_name: kylekanos/spaceMARINE


text:
module M {

  port P

  passive component A {

    output port pOut: P

  }

  passive component B {

    sync input port pIn: P

  }

  instance a: A base id 0x100
  instance b: B base id 0x200

  topology A {

    instance a
    instance b

    connections C {
      a.pOut -> b.pIn
    }

  }

  topology B { import A }

  topology C { import A }

  topology T {

    import B
    import C

  }

}

ext: fpp

max_stars_repo_name: kevin-f-ortega/fpp

max_issues_repo_name: kevin-f-ortega/fpp

max_forks_repo_name: kevin-f-ortega/fpp


text:
      SUBROUTINE dftcor(w,delta,a,b,endpts,corre,corim,corfac)
      REAL a,b,corfac,corim,corre,delta,w,endpts(8)
      REAL a0i,a0r,a1i,a1r,a2i,a2r,a3i,a3r,arg,c,cl,cr,s,sl,sr,t,t2,t4,
     *t6
      DOUBLE PRECISION cth,ctth,spth2,sth,sth4i,stth,th,th2,th4,tmth2,
     *tth4i
      th=w*delta
      if (a.ge.b.or.th.lt.0.d0.or.th.gt.3.1416d0)pause
     *'bad arguments to dftcor'
      if(abs(th).lt.5.d-2)then
        t=th
        t2=t*t
        t4=t2*t2
        t6=t4*t2
        corfac=1.-(11./720.)*t4+(23./15120.)*t6
        a0r=(-2./3.)+t2/45.+(103./15120.)*t4-(169./226800.)*t6
        a1r=(7./24.)-(7./180.)*t2+(5./3456.)*t4-(7./259200.)*t6
        a2r=(-1./6.)+t2/45.-(5./6048.)*t4+t6/64800.
        a3r=(1./24.)-t2/180.+(5./24192.)*t4-t6/259200.
        a0i=t*(2./45.+(2./105.)*t2-(8./2835.)*t4+(86./467775.)*t6)
        a1i=t*(7./72.-t2/168.+(11./72576.)*t4-(13./5987520.)*t6)
        a2i=t*(-7./90.+t2/210.-(11./90720.)*t4+(13./7484400.)*t6)
        a3i=t*(7./360.-t2/840.+(11./362880.)*t4-(13./29937600.)*t6)
      else
        cth=cos(th)
        sth=sin(th)
        ctth=cth**2-sth**2
        stth=2.d0*sth*cth
        th2=th*th
        th4=th2*th2
        tmth2=3.d0-th2
        spth2=6.d0+th2
        sth4i=1./(6.d0*th4)
        tth4i=2.d0*sth4i
        corfac=tth4i*spth2*(3.d0-4.d0*cth+ctth)
        a0r=sth4i*(-42.d0+5.d0*th2+spth2*(8.d0*cth-ctth))
        a0i=sth4i*(th*(-12.d0+6.d0*th2)+spth2*stth)
        a1r=sth4i*(14.d0*tmth2-7.d0*spth2*cth)
        a1i=sth4i*(30.d0*th-5.d0*spth2*sth)
        a2r=tth4i*(-4.d0*tmth2+2.d0*spth2*cth)
        a2i=tth4i*(-12.d0*th+2.d0*spth2*sth)
        a3r=sth4i*(2.d0*tmth2-spth2*cth)
        a3i=sth4i*(6.d0*th-spth2*sth)
      endif
      cl=a0r*endpts(1)+a1r*endpts(2)+a2r*endpts(3)+a3r*endpts(4)
      sl=a0i*endpts(1)+a1i*endpts(2)+a2i*endpts(3)+a3i*endpts(4)
      cr=a0r*endpts(8)+a1r*endpts(7)+a2r*endpts(6)+a3r*endpts(5)
      sr=-a0i*endpts(8)-a1i*endpts(7)-a2i*endpts(6)-a3i*endpts(5)
      arg=w*(b-a)
      c=cos(arg)
      s=sin(arg)
      corre=cl+c*cr-s*sr
      corim=sl+s*cr+c*sr
      return
      END

ext: for

max_stars_repo_path: NR-Functions/Numerical Recipes- Example & Functions/Functions/dftcor.for


! This file is part of fortran_tester
! Copyright 2015 Pierre de Buyl
! License: BSD

program test_tester_8
  use tester
  implicit none

  type(tester_t) :: test
  integer, parameter :: long_k = selected_int_kind(18)

  call test%init()

  call test%assert_equal([1_long_k, 2_long_k, huge(1_long_k)], [0_long_k, 2_long_k, huge(1_long_k)])

  call test%print()

end program test_tester_8


text:
SUBROUTINE TEST(N, OUT)
  ! Simple allocation test, allocate a real array of size N.
  INTEGER, INTENT(IN) :: N
  REAL, INTENT(OUT), ALLOCATABLE :: OUT(:)
  ! Local variables.
  INTEGER :: I
  ALLOCATE(OUT(1:I))
  DO I = 1, N
     OUT(I) = I
  END DO
END SUBROUTINE TEST

max_stars_repo_name: thlux/fmodpy

max_issues_repo_name: thlux/fmodpy

max_forks_repo_name: thlux/fmodpy


text:
      SUBROUTINE ARRTP3 (NSZ, XI,YI,ZI, XFRMT, XO,YO,ZO)

C  This subroutine transforms a list of 3D points according to the
C  given matrix.

C  Input parameters:
C    NSZ      : number of points
C    XI,YI,ZI : points to be transformed
C    XFRMT    : matrix containing transformation
C  Output parameters:
C    XO,YO,ZO : points after being transformed

      INTEGER     NSZ,IX

      REAL        XI(NSZ),YI(NSZ),ZI(NSZ), XFRMT(4,4),
     1            XO(NSZ),YO(NSZ),ZO(NSZ)

      DO 100 IX = 1,NSZ
         CALL ETP3 (XI(IX),YI(IX),ZI(IX), XFRMT, XO(IX),YO(IX),ZO(IX))
100   CONTINUE

      END


text:
      SUBROUTINE TLODSL (TREAL,TINT)
C
C     ECPT ENTRIES
C
C     ECPT ( 1) = ELEMENT ID                                    INTEGER
C     ECPT ( 2) = SCALAR INDEX NUMBER FOR GRID POINT 1          INTEGER
C     ECPT ( 3) = SCALAR INDEX NUMBER FOR GRID POINT 2          INTEGER
C     ECPT ( 4) = SCALAR INDEX NUMBER FOR GRID POINT 3          INTEGER
C     ECPT ( 5) = SCALAR INDEX NUMBER FOR GRID POINT 4          INTEGER
C     ECPT ( 6) = SCALAR INDEX NUMBER FOR GRID POINT 5          INTEGER
C     ECPT ( 7) = SCALAR INDEX NUMBER FOR GRID POINT 6          INTEGER
C     ECPT ( 8) = THETA                                         REAL
C     ECPT ( 9) = MATERIAL ID 1                                 INTEGER
C     ECPT (10) = THICKNESS T1 AT GRID POINT G1
C     ECPT (11) = THICKNESS T3 AT GRID POINT G3
C     ECPT (12) = THICKNESS T5 AT GRID POINT G5
C     ECPT (13) = MATERIAL ID 2                                 INTEGER
C     ECPT (14) = THICKNESS TBEND1 FOR BENDING AT GRID POINT G1
C     ECPT (15) = THICKNESS TBEND3 FOR BENDING AT GRID POINT G3
C     ECPT (16) = THICKNESS TBEND5 FOR BENDING AT GRID POINT G5
C     ECPT (17) = MATERIAL ID 3                                 INTEGER
C     ECPT (18) = THICKNESS TSHR1 FOR TRANSVERSE SHEAR AT GRID POINT G1
C     ECPT (19) = THICKNESS TSHR3 FOR TRANSVERSE SHEAR AT GRID POINT G3
C     ECPT (20) = THICKNESS TSHR5 FOR TRANSVERSE SHEAR AT GRID POINT G5
C     ECPT (21) = NON-STRUCTURAL MASS                           REAL
C     ECPT (22) = DISTANCE Z11 FOR STRESS CALCULATION  AT GRID POINT G1
C     ECPT (23) = DISTANCE Z21 FOR STRESS CALCULATION  AT GRID POINT G1
C     ECPT (24) = DISTANCE Z13 FOR STRESS CALCULATION  AT GRID POINT G3
C     ECPT (25) = DISTANCE Z23 FOR STRESS CALCULATION  AT GRID POINT G3
C     ECPT (26) = DISTANCE Z15 FOR STRESS CALCULATION  AT GRID POINT G5
C     ECPT (27) = DISTANCE Z25 FOR STRESS CALCULATION  AT GRID POINT G5
C
C     X1,Y1,Z1 FOR ALL SIX POINTS ARE  IN NASTRAN BASIC SYSTEM
C
C     ECPT (28) = CO-ORDINATE SYSTEM ID FOR GRID A              INTEGER
C     ECPT (29) = CO-ORDINATE X1                                REAL
C     ECPT (30) = CO-ORDINATE Y1                                REAL
C     ECPT (31) = CO-ORDINATE Z1                                REAL
C     ECPT (32) = CO-ORDINATE SYSTEM ID FOR GRID B              INTEGER
C     ECPT (33) = CO-ORDINATE X1                                REAL
C     ECPT (34) = CO-ORDINATE Y1                                REAL
C     ECPT (35) = CO-ORDINATE Z1                                REAL
C     ECPT (36) = CO-ORDINATE SYSTEM ID FOR GRID C              INTEGER
C     ECPT (37) = CO-ORDINATE X1                                REAL
C     ECPT (38) = CO-ORDINATE Y1                                REAL
C     ECPT (39) = CO-ORDINATE Z1                                REAL
C     ECPT (40) = CO-ORDINATE SYSTEM ID FOR GRID D              INTEGER
C     ECPT (41) = CO-ORDINATE X1                                REAL
C     ECPT (42) = CO-ORDINATE Y1                                REAL
C     ECPT (43) = CO-ORDINATE Z1                                REAL
C     ECPT (44) = CO-ORDINATE SYSTEM ID FOR GRID E              INTEGER
C     ECPT (45) = CO-ORDINATE X1                                REAL
C     ECPT (46) = CO-ORDINATE Y1                                REAL
C     ECPT (47) = CO-ORDINATE Z1                                REAL
C     ECPT (48) = CO-ORDINATE SYSTEM ID FOR GRID F              INTEGER
C     ECPT (49) = CO-ORDINATE X1                                REAL
C     ECPT (50) = CO-ORDINATE Y1                                REAL
C     ECPT (51) = CO-ORDINATE Z1                                REAL
C     EST  (52) = ELEMENT TEMPERATURE
C
      LOGICAL         NOGO,     NOTS,     UNIBEN,   UNITEM,   UNIMEM
      INTEGER         XU(32),   YU(32),   XV(32),   YV(32),   XW(32),
     1                YW(32),   RK(3),    SK(3),    ELID,     ESTID,
     2                TL(3),    UL(3),    QT(3),    PT(3),    XTHK(10),
     3                YTHK(10), SMALL(6), TINT(6),  ICS(6),   IEST(42),
     4                NL(6),    IND(6,3), ELTYPE,   SIL1,    INDEX(20,3)
      REAL            TREAL(6), G(9),     G1(3),    NAME(2),  F(14,14),
     1                XC(6),    YC(6),    ZC(6),    TS6(40),  EE(30),
     2                Q(6,6),   QQ(960),  CC(10),   CAB(3),   P3(30),
     3                P6(32),   P7(30),   P8(5),    P9(6),    PL(3),
     4                DD(3),    TRAND(9), PTEM(32), GE1(9),   EL(3),
     5                IVECT(3), JVECT(3), KVECT(3),
     6                QQQ(20,20),         QQQINV(360),        BALOTR(36)
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /TRIMEX/ EST(100)
      COMMON /ZZZZZZ/ PG(1)
      COMMON /SSGWRK/ IND,FAC,F,P3,P6,P7
      COMMON /EMGDIC/ ELTYPE,LDICT,NLOCS,ELID,ESTID
      COMMON /MATIN / MATID,MATFLG,ELTEMP,PLA34,SINTH,COSTH
      COMMON /MATOUT/ EM(6),RHOY,ALF(3),TREF,GSUBE,SIGTY,SIGCY,SIGSY,
     1                RJ11,RJ12,RJ22
      COMMON /SYSTEM/ IBUF,NOUT
      EQUIVALENCE     (C1,CC(1)),(C2,CC(2)),(C3,CC(3)),(C4,CC(4)),
     1                (C5,CC(5)),(C6,CC(6)),(C7,CC(7)),(C8,CC(8)),
     2                (C9,CC(9)),(C10,CC(10)),(IEST(1),EST(1)),
     3                (A,DISTA),(B,DISTB),(C,DISTC),(THK1,TBEND1),
     4                (THK2,TBEND3),(THK3,TBEND5)
      DATA    XU    / 0,1,0,2,1,0,26*0/,      YU/0,0,1,0,1,2,26*0    /,
     1        XV    / 6*0,0,1,0,2,1,0,20*0/ , YV/6*0,0,0,1,0,1,2,20*0/,
     2        XW    / 12*0,0,1,0,2,1,0,3,2,1,0,4,3,2,1,0,5,3,2,1,0   /,
     3        YW    / 12*0,0,0,1,0,1,2,0,1,2,3,0,1,2,3,4,0,2,3,4,5   /
      DATA    BLANK , NAME / 4H    ,  4HTRSH,4HL          /
      DATA    RK,SK / 0,1,0,  0,0,1/, DEGRA /0.0174532925 /
      DATA    XTHK  / 0,1,0,2,1,0,3,2,1,0/,  YTHK/ 0,0,1,0,1,2,0,1,2,3/
      DATA    TL    / 0,1,0/, UL/0,0,1/, PT/0,1,0/, QT/0,0,1/
C
C     COMPONENT CODE,ICODE,IS  111111  AND HAS A VALUE OF 63
C
      NOTS   = .FALSE.
      IDELE  = IEST(1)
      DO 109 I = 1,6
      NL(I)  = IEST(I+1)
  109 CONTINUE
      THETAM = EST (8)
      MATID1 = IEST(9)
      TMEM1  = EST(10)
      TMEM3  = EST(11)
      TMEM5  = EST(12)
      MATID2 = IEST(13)
      TBEND1 = (EST(14)*12.0)**0.3333333333
      TBEND3 = (EST(15)*12.0)**0.3333333333
      TBEND5 = (EST(16)*12.0)**0.3333333333
      MATID3 = IEST(17)
      TSHR1  = EST(18)
      TSHR3  = EST(19)
      TSHR5  = EST(20)
      NSM    = EST(21)
      J      = 0
      DO 120 I = 28,48,4
      J      = J + 1
      ICS(J) = IEST(I)
      XC(J)  = EST(I+1)
      YC(J)  = EST(I+2)
      ZC(J)  = EST(I+3)
  120 CONTINUE
C
C     IF TMEM3 OR TMEM5 EQUAL TO ZERO OR BLANK, THEY WILL BE
C     SET EQUAL TO TMEM1 SO ALSO FOR TSHR3,TSHR5,TBEND3 AND TBEND5
C
      T1PRIM = -TREAL(2)
      T3PRIM = -TREAL(2)
      T5PRIM = -TREAL(2)
      IF (TMEM3.EQ.0.0 .OR. TMEM3.EQ.BLANK) TMEM3 = TMEM1
      IF (TMEM5.EQ.0.0 .OR. TMEM5.EQ.BLANK) TMEM5 = TMEM1
      IF (TSHR3.EQ.0.0 .OR. TSHR3.EQ.BLANK) TSHR3 = TSHR1
      IF (TSHR5.EQ.0.0 .OR. TSHR5.EQ.BLANK) TSHR5 = TSHR1
      IF (TSHR1 .EQ. 0.0) NOTS = .TRUE.
      IF (TBEND3.EQ.0.0 .OR. TBEND3.EQ.BLANK) TBEND3 = TBEND1
      IF (TBEND5.EQ.0.0 .OR. TBEND5.EQ.BLANK) TBEND5 = TBEND1
      IF (T3PRIM.EQ.0.0 .OR. T3PRIM.EQ.BLANK) T3PRIM = T1PRIM
      IF (T5PRIM.EQ.0.0 .OR. T5PRIM.EQ.BLANK) T5PRIM = T1PRIM
      ELTEMP = EST(52)
      AVTHK  = (TBEND1 + TBEND3 + TBEND5)/3.0
      AVINER = AVTHK**3/12.0
      THETA1 = THETAM*DEGRA
      SINTH  = SIN(THETA1)
      COSTH  = COS(THETA1)
      IF (ABS(SINTH) .LE. 1.0E-06) SINTH = 0.0
C
C     EVALUTE MATERIAL PROPERTIES
C
      MATFLG = 2
      MATID  = MATID1
      IF (MATID .LE. 0) GO TO 122
      CALL MAT (IDELE)
C
      G11 = EM(1)
      G12 = EM(2)
      G13 = EM(3)
      G22 = EM(4)
      G23 = EM(5)
      G33 = EM(6)
      GM1 = EM(1)*ALF(1) + EM(2)*ALF(2) + EM(3)*ALF(3)
      GM2 = EM(2)*ALF(1) + EM(4)*ALF(2) + EM(5)*ALF(3)
      GM3 = EM(3)*ALF(1) + EM(5)*ALF(2) + EM(6)*ALF(3)
      G11PR = 0.0
      G22PR = 0.0
      G33PR = 0.0
  122 CONTINUE
      MATFLG = 2
      MATID  = MATID2
      IF (MATID .LE. 0) GO TO 149
      CALL MAT (IDELE)
      D11  = EM(1)
      D12  = EM(2)
      D13  = EM(3)
      D22  = EM(4)
      D23  = EM(5)
      D33  = EM(6)
      G(1) = EM(1)
      G(2) = EM(2)
      G(3) = EM(3)
      G(4) = EM(2)
      G(5) = EM(4)
      G(6) = EM(5)
      G(7) = EM(3)
      G(8) = EM(5)
      G(9) = EM(6)
C
C     IF  TINT(6).NE.1,G1 IS G AND T1PRIME IS ALPHA TIMES T1PRIME
C     IF  TINT(6).EQ.1,G1 IS G TIMES ALPHA AND T1PRIME IS T1PRIME
C
      IF  (TINT(6) .NE. 1) GO TO 147
C
C     G1 IS G TIMES ALFA
C
      CALL GMMATS (G,3,3,0, ALF,3,1,0, G1)
C
      G11PR = G1(1)
      G22PR = G1(2)
      G33PR = G1(3)
      GO TO 149
  147 CONTINUE
      DO 148 I = 1,9
  148 GE1(I) = G(I)*AVINER
C
C     NO NEED TO COMPUTE DETERMINANT SINCE IT IS NOT USED SUBSEQUENTLY
C
      ISING = -1
      CALL INVERS (3,GE1(1),3,TS6(1),0,DETERM,ISING,INDEX)
      IF (ISING .EQ. 2) GO TO 905
      CALL GMMATS (GE1,3,3,0, TREAL(2),3,1,0, PL(1))
  149 CONTINUE
C
C     CALCULATIONS FOR THE TRIANGLE
C
      CALL TRIF (XC,YC,ZC,IVECT,JVECT,KVECT,A,B,C,IEST(1),NAME)
C
C     COMPUTE THE AREA INTEGRATION FUNCTION F
C
      CALL AF (F,14,A,B,C,0,0,0,0,0,0,-1)
C
C     CALCULATIONS FOR QMATRIX (QQQ) AND ITS INVERSE
C
      DO 110 I = 1,20
      DO 110 J = 1,20
  110 QQQ(I,J) = 0.0
      DO 115 I = 1,6
      I1 = (I-1)*3 + 1
      I2 = (I-1)*3 + 2
      I3 = (I-1)*3 + 3
      QQQ(I1, 1) = 1.0
      QQQ(I1, 2) = XC(I)
      QQQ(I1, 3) = YC(I)
      QQQ(I1, 4) = XC(I)*XC(I)
      QQQ(I1, 5) = XC(I)*YC(I)
      QQQ(I1, 6) = YC(I)*YC(I)
      QQQ(I1, 7) = QQQ(I1, 4)*XC(I)
      QQQ(I1, 8) = QQQ(I1, 4)*YC(I)
      QQQ(I1, 9) = QQQ(I1, 5)*YC(I)
      QQQ(I1,10) = QQQ(I1, 6)*YC(I)
      QQQ(I1,11) = QQQ(I1, 7)*XC(I)
      QQQ(I1,12) = QQQ(I1, 7)*YC(I)
      QQQ(I1,13) = QQQ(I1, 8)*YC(I)
      QQQ(I1,14) = QQQ(I1, 9)*YC(I)
      QQQ(I1,15) = QQQ(I1,10)*YC(I)
      QQQ(I1,16) = QQQ(I1,11)*XC(I)
      QQQ(I1,17) = QQQ(I1,12)*YC(I)
      QQQ(I1,18) = QQQ(I1,13)*YC(I)
      QQQ(I1,19) = QQQ(I1,14)*YC(I)
      QQQ(I1,20) = QQQ(I1,15)*YC(I)
      QQQ(I2, 3) = 1.0
      QQQ(I2, 5) = XC(I)
      QQQ(I2, 6) = YC(I)*2.0
      QQQ(I2, 8) = QQQ(I1, 4)
      QQQ(I2, 9) = QQQ(I1, 5)*2.0
      QQQ(I2,10) = QQQ(I1, 6)*3.0
      QQQ(I2,12) = QQQ(I1, 7)
      QQQ(I2,13) = QQQ(I1, 8)*2.0
      QQQ(I2,14) = QQQ(I1, 9)*3.0
      QQQ(I2,15) = QQQ(I1,10)*4.0
      QQQ(I2,17) = QQQ(I1,12)*2.0
      QQQ(I2,18) = QQQ(I1,13)*3.0
      QQQ(I2,19) = QQQ(I1,14)*4.0
      QQQ(I2,20) = QQQ(I1,15)*5.0
      QQQ(I3, 2) =-1.0
      QQQ(I3, 4) =-2.0*XC(I)
      QQQ(I3, 5) =-YC(I)
      QQQ(I3, 7) =-QQQ(I1, 4)*3.0
      QQQ(I3, 8) =-QQQ(I1, 5)*2.0
      QQQ(I3, 9) =-QQQ(I1, 6)
      QQQ(I3,11) =-QQQ(I1, 7)*4.0
      QQQ(I3,12) =-QQQ(I1, 8)*3.0
      QQQ(I3,13) =-QQQ(I1, 9)*2.0
      QQQ(I3,14) =-QQQ(I1,10)
      QQQ(I3,16) =-QQQ(I1,11)*5.0
      QQQ(I3,17) =-QQQ(I1,13)*3.0
      QQQ(I3,18) =-QQQ(I1,14)*2.0
      QQQ(I3,19) =-QQQ(I1,15)
  115 CONTINUE
      QQQ(19,16) = 5.0*A**4*C
      QQQ(19,17) = 3.0*A**2*C**3 - 2.0*A**4*C
      QQQ(19,18) =-2.0*A*C**4 + 3.0*A**3*C**2
      QQQ(19,19) = C**5 - 4.0*A**2*C**3
      QQQ(19,20) = 5.0*A*C**4
      QQQ(20,16) = 5.0*B**4*C
      QQQ(20,17) = 3.0*B**2*C**3 - 2.0*B**4*C
      QQQ(20,18) = 2.0*B*C**4 - 3.0*B**3*C**2
      QQQ(20,19) = C**5 - 4.0*B**2*C**3
      QQQ(20,20) =-5.0*B*C**4
      DO 128 I = 1,6
      DO 128 J = 1,6
      I1 = (I-1)*3 + 1
      Q(I,J) = QQQ(I1,J)
  128 CONTINUE
C
C     SET ISING = -1
C
      ISING = -1
      CALL INVERS (6,Q,6,TS6(1),0,DETERM,ISING,IND)
      IF (ISING .EQ. 2) GO TO 904
C
C     FOURTH ARGUMENT IS A DUMMY LOCATION FOR INVERSE AND HENCE TS1(1) I
C
C     AGAIN SET ISING = -1
C
      ISING = -1
      CALL INVERS (20,QQQ,20,TS6(1),0,DETERM,ISING,INDEX)
C
C     ISING EQUAL TO 2 IMPLIES THAT QQQ IS SINGULAR
C
      IF (ISING .EQ. 2) GO TO 905
C
C     FIRST 18 COLUMNS OF QQQ INVERSE IS THE QQQINV FOR USE IN STIFFNESS
C     MATRIX CALCULATIONS
C
      DO  153 I = 1,960
      QQ(I) = 0.0
  153 CONTINUE
      DO 154 I = 1,6
      DO 154 J = 1,6
      IJ = (I-1)*30 + J
      IK = (I+5)*30 + J + 6
      QQ(IJ) = Q(I,J)
      QQ(IK) = Q(I,J)
  154 CONTINUE
      DO 156 I = 1,20
      DO 156 J = 1,18
      IJ = 372 + (I-1)*30 + J
      QQ (IJ) = QQQ(I,J)
      IJ1 = (I-1)*18 + J
      QQQINV(IJ1) = QQQ(I,J)
  156 CONTINUE
C
C     START EXECUTION FOR STIFFNESS MATRIX CALCULATION
C
C     CM IS STIFFNESS MATRIX IN ELEMENT COORDINATES
C
C     EVALUATE THE CONSTANTS C1,C2,AND C3 IN THE LINEAR EQUATION FOR
C     THICKNESS VARIATION - MEMBRANE
C
      CALL AF (F,14,A,B,C,C1,C2,C3,TMEM1,TMEM3,TMEM5,1)
      CAB(1) = C1
      CAB(2) = C2
      CAB(3) = C3
      AREA   = F(1,1)
      VOL    = C1*F(1,1) + C2*F(2,1) + C3*F(1,2)
      UNIBEN =.FALSE.
      UNIMEM =.FALSE.
      UNITEM =.FALSE.
      IF (ABS(C2).LE.1.0E-06 .AND. ABS(C3).LE.1.0E-06) UNIMEM =.TRUE.
C
      D334 = D33*4.0
      D132 = D13*2.0
      D232 = D23*2.0
C
C     DD(1) TO DD(3) ARE THE CONSTANTS IN LINEAR EQUATION FOR TEMP
C     GRADIENT. CURRENTLY ONLY UNIFORM TEMP GRADIENT IS PERMITTED IN
C     THE ELEMENT, THOUGH THE CODE IS WRITTEN FOR LINEAR VARIATION
C
      CALL AF (F,14,A,B,C,DD(1),DD(2),DD(3),T1PRIM,T3PRIM,T5PRIM,1)
C
C     EL(1) TO EL(3) ARE THE CONSTANTS IN THE LINEAR EQUATION FOR
C     MEAN TEMP VARIATION
C
      EL(1) = TREAL(1) - TREF
      EL(2) = 0.0
      EL(3) = 0.0
C
C     A1,A2,A3 ARE THE COEFFICIENTS OF LINEAR EQUATION FOR VARIATION
C     OF BENDING THICKNESSES
C
      CALL AF (F,14,A,B,C,A1,A2,A3,THK1,THK2,THK3,1)
      A1SQ = A1*A1
      A2SQ = A2*A2
      A3SQ = A3*A3
      C1   = A1SQ*A1
      C2   = 3.0*A1SQ*A2
      C3   = 3.0*A1SQ*A3
      C4   = 3.0*A1*A2SQ
      C5   = 6.0*A1*A2*A3
      C6   = 3.0*A3SQ*A1
      C7   = A2SQ*A2
      C8   = 3.0*A2SQ*A3
      C9   = 3.0*A2*A3SQ
      C10  = A3*A3SQ
      IF (ABS(A2).LE.1.0E-06 .AND. ABS(A3).LE.1.0E-06) UNIBEN =.TRUE.
      EL2  = EL(2)
      EL3  = EL(3)
      IF (ABS(EL2).LE.1.E-06 .AND. ABS(EL3).LE.1.E-06) UNITEM =.TRUE.
C
C     AA1, AA2, AA3  ARE COEFFICIENTS IN THICKNESS VARIATION FOR
C     TRANSVERSE SHEAR
C
      CALL AF (F,14,A,B,C,AA1,AA2,AA3,TSHR1,TSHR3,TSHR5,1)
      H4 = Q(4,1)*ZC(1) + Q(4,2)*ZC(2) + Q(4,3)*ZC(3) + Q(4,4)*ZC(4) +
     1     Q(4,5)*ZC(5) + Q(4,6)*ZC(6)
      H5 = Q(5,1)*ZC(1) + Q(5,2)*ZC(2) + Q(5,3)*ZC(3) + Q(5,4)*ZC(4) +
     1     Q(5,5)*ZC(5) + Q(5,6)*ZC(6)
      H6 = Q(6,1)*ZC(1) + Q(6,2)*ZC(2) + Q(6,3)*ZC(3) + Q(6,4)*ZC(4) +
     1     Q(6,5)*ZC(5) + Q(6,6)*ZC(6)
      H4 = H4*2.0
      H6 = H6*2.0
C
C     H5 IS MULTIPLIED BY 2.0, SO THAT EXY=DU/DY + DV/DX - ZXY*W
C
      H5 = H5*2.0
C
C     CALCULATION OF THERMAL LOAD VECTOR
C
      DO 670 I = 1,32
      PTEM(I) = 0.0
      IX   = XU(I)
      RIX  = IX
      JX   = YU(I)
      RJX  = JX
      KX   = XV(I)
      RKX  = KX
      LX   = YV(I)
      RLX  = LX
      MX   = XW(I)
      RMX  = MX
      NX   = YW(I)
      RNX  = NX
      RMNX = RMX*RNX
      RMX1 = RMX*(RMX-1.0)
      RNX1 = RNX*(RNX-1.0)
      IXP1 = IX + 1
      JXP1 = JX + 1
      KXP1 = KX + 1
      LXP1 = LX + 1
      MXP1 = MX + 1
      NXP1 = NX + 1
      MX01 = MX - 1
      MX1  = MX + 1
      NX01 = NX - 1
      NX1  = NX + 1
      PTEMP= 0.0
      IF (I .LE. 12) GO TO 225
      DO 215 K = 1,10
      MX01X= MX01+ XTHK(K)
      NX1Y = NX1 + YTHK(K)
      MX1X = MX1 + XTHK(K)
      NX01Y= NX01+ YTHK(K)
      MXX  = MX  + XTHK(K)
      NXY  = NX  + YTHK(K)
      IF (TINT(6) .NE. 1) GO TO 213
      DO 212 L = 1,3
      MX01XP= MX01X+ PT(L)
      NX1YQ = NX1Y + QT(L)
      MX1XP = MX1X + PT(L)
      NX01YQ= NX01Y+ QT(L)
      MXXP  = MXX  + PT(L)
      NXYQ  = NXY  + QT(L)
      IF (MX01XP.GT.0 .AND. NX1YQ.GT.0)
     1    PTEMP = PTEMP + CC(K)*DD(L)*G1(1)*RMX1*F(MX01XP,NX1YQ)
      IF (MX1XP.GT.0 .AND. NX01YQ.GT.0)
     1    PTEMP = PTEMP + CC(K)*DD(L)*G1(2)*RNX1*F(MX1XP,NX01YQ)
      IF (MXXP.GT.0 .AND. NXYQ.GT.0)
     1    PTEMP = PTEMP + CC(K)*DD(L)*G1(3)*RMNX*F(MXXP,NXYQ)
      IF (UNITEM) GO TO 213
  212 CONTINUE
  213 CONTINUE
      IF (TINT(6) .EQ. 1) GO TO 214
      IF (MX01X .GT. 0) PTEMP = PTEMP + CC(K)*RMX1*(PL(1)*G(1)
     1                        + PL(2)*G(2) + PL(3)*G(3))*F(MX01X,NX1Y)
      IF (NX01Y .GT. 0) PTEMP = PTEMP + CC(K)*RNX1*(PL(1)*G(4)
     1                        + PL(2)*G(5) + PL(3)*G(6))*F(MX1X,NX01Y)
      IF (MXX.GT.0 .AND. NXY.GT.0) PTEMP = PTEMP + CC(K)*RMNX*(PL(1)*
     1                        G(7)+PL(2)*G(8)+PL(3)*G(9))*F(MXX,NXY)
  214 CONTINUE
      IF (UNIBEN) GO TO 2150
  215 CONTINUE
 2150 CONTINUE
      PTEM(I) = PTEMP/12.0
      GO TO 235
  225 CONTINUE
      DO 263 K = 1,3
      IXR = IX + RK(K)
      JXS = JX + SK(K)
      KXR = KX + RK(K)
      LXS = LX + SK(K)
      DO 262 L = 1,3
      IXRT  = IXR + TL(L)
      JXSU1 = JXS + UL(L) + 1
      KXRT1 = KXR + TL(L) + 1
      LXSU  = LXS + UL(L)
      IXRT1 = IXRT  + 1
      JXSU  = JXSU1 - 1
      KXRT  = KXRT1 - 1
      LXSU1 = LXSU  + 1
      MKR1  = MX + KX + RK(K) - 1
      NLS1  = NX + LX + SK(K) - 1
      IF (IXRT .GT. 0) PTEMP = PTEMP +CAB(K)*EL(L)*GM1*RIX*F(IXRT,JXSU1)
      IF (LXSU .GT. 0) PTEMP = PTEMP +CAB(K)*EL(L)*GM2*RLX*F(KXRT1,LXSU)
      IF (JXSU .GT. 0) PTEMP = PTEMP +CAB(K)*EL(L)*GM3*RJX*F(IXRT1,JXSU)
      IF (KXRT .GT. 0) PTEMP = PTEMP +CAB(K)*EL(L)*GM3*RKX*F(KXRT,LXSU1)
      IF (MKR1.GT.0 .AND. NLS1.GT.0) PTEMP = PTEMP -(G11PR*H4*EL(L)*
     1    CAB(K)*F(MKR1,NLS1))-(G22PR*H4*EL(L)*CAB(K)*F(MKR1,NLS1))-
     2    (G33PR*H4*EL(L)*CAB(K)*F(MKR1,NLS1))
      IF (UNITEM) GO TO 2620
  262 CONTINUE
 2620 CONTINUE
      IF (UNIMEM) GO TO 2630
  263 CONTINUE
 2630 CONTINUE
      PTEM(I) = PTEMP
  235 CONTINUE
  670 CONTINUE
      CALL GMMATS (QQ,32,30,+1,PTEM,32,1,0,P6)
      DO 179 I = 1,30
      EE(I)  = 0.0
  179 CONTINUE
      EE( 1) = IVECT(1)
      EE( 2) = JVECT(1)
      EE( 3) = KVECT(1)
      EE( 6) = IVECT(2)
      EE( 7) = JVECT(2)
      EE( 8) = KVECT(2)
      EE(11) = IVECT(3)
      EE(12) = JVECT(3)
      EE(13) = KVECT(3)
      EE(19) = IVECT(1)
      EE(20) = JVECT(1)
      EE(24) = IVECT(2)
      EE(25) = JVECT(2)
      EE(29) = IVECT(3)
      EE(30) = JVECT(3)
      DO 278 K = 1,6
      DO 277 I = 1,2
      K1 = 6*(I-1) + K
      I1 = 5*(K-1) + I
      P7(I1) = P6(K1)
  277 CONTINUE
  278 CONTINUE
      DO 283 K = 1,6
      DO 282 I = 1,3
      I2 = 5*(K-1) + I + 2
      K2 = 12 + (K-1)*3 + I
      P7(I2) = P6(K2)
  282 CONTINUE
  283 CONTINUE
C
C     LOCATE THE TRANSFORMATION MATRICES FROM BASIC TO LOCAL (THAT IS
C     COORDINATE AT ANY GRID POINT IN WHICH DISPLACEMENT AND STRESSES
C     ARE ROTATED
C     - NOT NEEDED IF FIELD 7 IN GRID CARD IS ZERO)
C
C     TRANSFORM STIFFNESS MATRIX FROM ELEMENT COORDINATES TO BASIC
C     COORDINATES
C
C     TRANSFORM STIFFNESS MATRIX FROM BASIC COORDINAYES TO GLOBAL (DISP)
C     COORDINATES
C
      DO 302 I = 1,6
      SMALL(I) = I
  302 CONTINUE
      DO 308 I = 1,6
      SIL1 = SMALL(I)
      DO 310 II = 1,36
      BALOTR(II) = 0.0
  310 CONTINUE
      DO 304 K = 1,5
      K1 = (SIL1-1)*5 + K
      P8(K) = P7(K1)
  304 CONTINUE
      CALL GMMATS (EE,6,5,0,P8,5,1,0,P9)
C
C     TRANSFORM THE KSUB(36) FROM BASIC TO DISPLACEMENT COORDINATES
C
      IF (NL(SIL1).EQ.0 .OR. ICS(SIL1).EQ.0) GO TO 330
      JJ = 4*SIL1 + 24
      CALL TRANSS (IEST(JJ),TRAND)
      DO 320 JJ = 1,3
      L = 6*(JJ-1) + 1
      M = 3*(JJ-1) + 1
      BALOTR(L   ) = TRAND(M  )
      BALOTR(L+ 1) = TRAND(M+1)
      BALOTR(L+ 2) = TRAND(M+2)
      BALOTR(L+21) = TRAND(M  )
      BALOTR(L+22) = TRAND(M+1)
      BALOTR(L+23) = TRAND(M+2)
  320 CONTINUE
      CALL GMMATS (BALOTR(1),6,6,1, P9(1),6,1,0, P6(1))
      DO 350 K = 1,6
  350 P9(K) = P6(K)
  330 CONTINUE
      DO 370 II = 1,6
      I2 = IEST(I+1) + II - 1
      PG(I2) = PG(I2) + P9(II)
  370 CONTINUE
  308 CONTINUE
      GO TO 999
  904 WRITE (NOUT,2416) UFM,IEST(1)
      GO TO 910
  905 WRITE (NOUT,2417) UFM,IEST(1)
  910 NOGO = .TRUE.
      GO TO 999
C
 2416 FORMAT (A23,' 2416, MATRIX RELATING GENERALIZED PARAMETERS AND ',
     1       'GRID POINT DISPLACEMENTS IS SINGULAR.',/26X,
     2       'CHECK COORDINATES OF ELEMENT  TRSHL WITH ID =',I9,1H.)
 2417 FORMAT (A23,' 2417, A SINGULAR MATERIAL MATRIX FOR ELEMENT ID =',
     1       I9,' HAS BEEN DETECTED BY SUBROUTINE TLODSL', /26X,'WHILE',
     2       ' TRYING TO COMPUTE THERMAL LOADS WITH TEMPP2 CARD DATA.')
  999 RETURN
      END


text:
!$acc parallel loop collapse (3)
!$acc parallel loop
!$acc loop private (stencil, vals, d3_vals)
!$acc parallel loop collapse (3)
!$acc parallel loop
!$acc loop private (stencil, vals, d3_vals)
!$acc parallel loop collapse (3)
!$acc parallel loop collapse (2)
!$acc parallel loop
!$acc parallel loop collapse (2) private (xloc, mnt_deriv, x)

max_stars_repo_name: passlab/accparser

max_issues_repo_name: passlab/accparser

max_forks_repo_name: passlab/accparser