text:
      SUBROUTINE PCGEBRD( M, N, A, IA, JA, DESCA, D, E, TAUQ, TAUP,
     $                    WORK, LWORK, INFO )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 25, 2001
*
*     .. Scalar Arguments ..
      INTEGER            IA, INFO, JA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
      REAL               D( * ), E( * )
      COMPLEX            A( * ), TAUP( * ), TAUQ( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  PCGEBRD reduces a complex general M-by-N distributed matrix
*  sub( A ) = A(IA:IA+M-1,JA:JA+N-1) to upper or lower bidiagonal
*  form B by an unitary transformation: Q' * sub( A ) * P = B.
*
*  If M >= N, B is upper bidiagonal; if M < N, B is lower bidiagonal.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  M       (global input) INTEGER
*          The number of rows to be operated on, i.e. the number of rows
*          of the distributed submatrix sub( A ). M >= 0.
*
*  N       (global input) INTEGER
*          The number of columns to be operated on, i.e. the number of
*          columns of the distributed submatrix sub( A ). N >= 0.
*
*  A       (local input/local output) COMPLEX pointer into the
*          local memory to an array of dimension (LLD_A,LOCc(JA+N-1)).
*          On entry, this array contains the local pieces of the
*          general distributed matrix sub( A ). On exit, if M >= N,
*          the diagonal and the first superdiagonal of sub( A ) are
*          overwritten with the upper bidiagonal matrix B; the elements
*          below the diagonal, with the array TAUQ, represent the
*          unitary matrix Q as a product of elementary reflectors, and
*          the elements above the first superdiagonal, with the array
*          TAUP, represent the orthogonal matrix P as a product of
*          elementary reflectors. If M < N, the diagonal and the first
*          subdiagonal are overwritten with the lower bidiagonal
*          matrix B; the elements below the first subdiagonal, with the
*          array TAUQ, represent the unitary matrix Q as a product of
*          elementary reflectors, and the elements above the diagonal,
*          with the array TAUP, represent the orthogonal matrix P as a
*          product of elementary reflectors. See Further Details.
*
*  IA      (global input) INTEGER
*          The row index in the global array A indicating the first
*          row of sub( A ).
*
*  JA      (global input) INTEGER
*          The column index in the global array A indicating the
*          first column of sub( A ).
*
*  DESCA   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix A.
*
*  D       (local output) REAL array, dimension
*          LOCc(JA+MIN(M,N)-1) if M >= N; LOCr(IA+MIN(M,N)-1) otherwise.
*          The distributed diagonal elements of the bidiagonal matrix
*          B: D(i) = A(i,i). D is tied to the distributed matrix A.
*
*  E       (local output) REAL array, dimension
*          LOCr(IA+MIN(M,N)-1) if M >= N; LOCc(JA+MIN(M,N)-2) otherwise.
*          The distributed off-diagonal elements of the bidiagonal
*          distributed matrix B:
*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
*          E is tied to the distributed matrix A.
*
*  TAUQ    (local output) COMPLEX array dimension
*          LOCc(JA+MIN(M,N)-1). The scalar factors of the elementary
*          reflectors which represent the unitary matrix Q. TAUQ is
*          tied to the distributed matrix A. See Further Details.
*
*  TAUP    (local output) COMPLEX array, dimension
*          LOCr(IA+MIN(M,N)-1). The scalar factors of the elementary
*          reflectors which represent the unitary matrix P. TAUP is
*          tied to the distributed matrix A. See Further Details.
*
*  WORK    (local workspace/local output) COMPLEX array,
*                                                 dimension (LWORK)
*          On exit, WORK( 1 ) returns the minimal and optimal LWORK.
*
*  LWORK   (local or global input) INTEGER
*          The dimension of the array WORK.
*          LWORK is local input and must be at least
*          LWORK >= NB*( MpA0 + NqA0 + 1 ) + NqA0
*
*          where NB = MB_A = NB_A,
*          IROFFA = MOD( IA-1, NB ), ICOFFA = MOD( JA-1, NB ),
*          IAROW = INDXG2P( IA, NB, MYROW, RSRC_A, NPROW ),
*          IACOL = INDXG2P( JA, NB, MYCOL, CSRC_A, NPCOL ),
*          MpA0 = NUMROC( M+IROFFA, NB, MYROW, IAROW, NPROW ),
*          NqA0 = NUMROC( N+ICOFFA, NB, MYCOL, IACOL, NPCOL ).
*
*          INDXG2P and NUMROC are ScaLAPACK tool functions;
*          MYROW, MYCOL, NPROW and NPCOL can be determined by calling
*          the subroutine BLACS_GRIDINFO.
*
*          If LWORK = -1, then LWORK is global input and a workspace
*          query is assumed; the routine only calculates the minimum
*          and optimal size for all work arrays. Each of these
*          values is returned in the first entry of the corresponding
*          work array, and no error message is issued by PXERBLA.
*
*  INFO    (global output) INTEGER
*          = 0:  successful exit
*          < 0:  If the i-th argument is an array and the j-entry had
*                an illegal value, then INFO = -(i*100+j), if the i-th
*                argument is a scalar and had an illegal value, then
*                INFO = -i.
*
*  Further Details
*  ===============
*
*  The matrices Q and P are represented as products of elementary
*  reflectors:
*
*  If m >= n,
*
*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
*
*  Each H(i) and G(i) has the form:
*
*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
*
*  where tauq and taup are complex scalars, and v and u are complex
*  vectors;
*  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
*  A(ia+i:ia+m-1,ja+i-1);
*  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
*  A(ia+i-1,ja+i+1:ja+n-1);
*  tauq is stored in TAUQ(ja+i-1) and taup in TAUP(ia+i-1).
*
*  If m < n,
*
*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
*
*  Each H(i) and G(i) has the form:
*
*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
*
*  where tauq and taup are complex scalars, and v and u are complex
*  vectors;
*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in
*  A(ia+i+1:ia+m-1,ja+i-1);
*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in
*  A(ia+i-1,ja+i:ja+n-1);
*  tauq is stored in TAUQ(ja+i-1) and taup in TAUP(ia+i-1).
*
*  The contents of sub( A ) on exit are illustrated by the following
*  examples:
*
*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
*
*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
*    (  v1  v2  v3  v4  v5 )
*
*  where d and e denote diagonal and off-diagonal elements of B, vi
*  denotes an element of the vector defining H(i), and ui an element of
*  the vector defining G(i).
*
*  Alignment requirements
*  ======================
*
*  The distributed submatrix sub( A ) must verify some alignment proper-
*  ties, namely the following expressions should be true:
*  ( MB_A.EQ.NB_A .AND. IROFFA.EQ.ICOFFA )
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      COMPLEX            ONE
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      CHARACTER          COLCTOP, ROWCTOP
      INTEGER            I, IACOL, IAROW, ICTXT, IINFO, IOFF, IPW, IPY,
     $                   IW, J, JB, JS, JW, K, L, LWMIN, MN, MP, MYCOL,
     $                   MYROW, NB, NPCOL, NPROW, NQ
*     ..
*     .. Local Arrays ..
      INTEGER            DESCWX( DLEN_ ), DESCWY( DLEN_ ), IDUM1( 1 ),
     $                   IDUM2( 1 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, CHK1MAT, DESCSET, PCHK1MAT,
     $                   PCELSET, PCGEBD2, PCGEMM, PCLABRD,
     $                   PB_TOPGET, PB_TOPSET, PXERBLA
*     ..
*     .. External Functions ..
      INTEGER            INDXG2L, INDXG2P, NUMROC
      EXTERNAL           INDXG2L, INDXG2P, NUMROC
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CMPLX, MAX, MIN, MOD, REAL
*     ..
*     .. Executable Statements ..
*
*     Get grid parameters
*
      ICTXT = DESCA( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
*     Test the input parameters
*
      INFO = 0
      IF( NPROW.EQ.-1 ) THEN
         INFO = -(600+CTXT_)
      ELSE
         CALL CHK1MAT( M, 1, N, 2, IA, JA, DESCA, 6, INFO )
         IF( INFO.EQ.0 ) THEN
            NB = DESCA( MB_ )
            IOFF = MOD( IA-1, DESCA( MB_ ) )
            IAROW = INDXG2P( IA, NB, MYROW, DESCA( RSRC_ ), NPROW )
            IACOL = INDXG2P( JA, NB, MYCOL, DESCA( CSRC_ ), NPCOL )
            MP = NUMROC( M+IOFF, NB, MYROW, IAROW, NPROW )
            NQ = NUMROC( N+IOFF, NB, MYCOL, IACOL, NPCOL )
            LWMIN = NB*( MP+NQ+1 ) + NQ
*
            WORK( 1 ) = CMPLX( REAL( LWMIN ) )
            LQUERY = ( LWORK.EQ.-1 )
            IF( IOFF.NE.MOD( JA-1, DESCA( NB_ ) ) ) THEN
               INFO = -5
            ELSE IF( NB.NE.DESCA( NB_ ) ) THEN
               INFO = -(600+NB_)
            ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
               INFO = -12
            END IF
         END IF
         IF( LQUERY ) THEN
            IDUM1( 1 ) = -1
         ELSE
            IDUM1( 1 ) = 1
         END IF
         IDUM2( 1 ) = 12
         CALL PCHK1MAT( M, 1, N, 2, IA, JA, DESCA, 6, 1, IDUM1, IDUM2,
     $                  INFO )
      END IF
*
      IF( INFO.LT.0 ) THEN
         CALL PXERBLA( ICTXT, 'PCGEBRD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      MN = MIN( M, N )
      IF( MN.EQ.0 )
     $   RETURN
*
*     Initialize parameters.
*
      CALL PB_TOPGET( ICTXT, 'Combine', 'Columnwise', COLCTOP )
      CALL PB_TOPGET( ICTXT, 'Combine', 'Rowwise',    ROWCTOP )
      CALL PB_TOPSET( ICTXT, 'Combine', 'Columnwise', '1-tree' )
      CALL PB_TOPSET( ICTXT, 'Combine', 'Rowwise',    '1-tree' )
*
      IPY = MP * NB + 1
      IPW = NQ * NB + IPY
*
      CALL DESCSET( DESCWX, M+IOFF, NB, NB, NB, IAROW, IACOL, ICTXT,
     $              MAX( 1, MP ) )
      CALL DESCSET( DESCWY, NB, N+IOFF, NB, NB, IAROW, IACOL, ICTXT,
     $              NB )
*
      MP = NUMROC( M+IA-1, NB, MYROW, DESCA( RSRC_ ), NPROW )
      NQ = NUMROC( N+JA-1, NB, MYCOL, DESCA( CSRC_ ), NPCOL )
      K  = 1
      JB = NB - IOFF
      IW = IOFF + 1
      JW = IOFF + 1
*
      DO 10 L = 1, MN+IOFF-NB, NB
         I = IA + K - 1
         J = JA + K - 1
*
*        Reduce rows and columns i:i+nb-1 to bidiagonal form and return
*        the matrices X and Y which are needed to update the unreduced
*        part of the matrix.
*
         CALL PCLABRD( M-K+1, N-K+1, JB, A, I, J, DESCA, D, E, TAUQ,
     $                 TAUP, WORK, IW, JW, DESCWX, WORK( IPY ), IW,
     $                 JW, DESCWY, WORK( IPW ) )
*
*        Update the trailing submatrix A(i+nb:ia+m-1,j+nb:ja+n-1), using
*        an update of the form  A := A - V*Y' - X*U'.
*
         CALL PCGEMM( 'No transpose', 'No transpose', M-K-JB+1,
     $                N-K-JB+1, JB, -ONE, A, I+JB, J, DESCA,
     $                WORK( IPY ), IW, JW+JB, DESCWY, ONE, A, I+JB,
     $                J+JB, DESCA )
         CALL PCGEMM( 'No transpose', 'No transpose', M-K-JB+1,
     $                N-K-JB+1, JB, -ONE, WORK, IW+JB, JW, DESCWX, A, I,
     $                J+JB, DESCA, ONE, A, I+JB, J+JB, DESCA )
*
*        Copy last off-diagonal elements of B back into sub( A ).
*
         IF( M.GE.N ) THEN
            JS = MIN( INDXG2L( I+JB-1, NB, 0, DESCA( RSRC_ ), NPROW ),
     $                MP )
            IF( JS.GT.0 )
     $         CALL PCELSET( A, I+JB-1, J+JB, DESCA, CMPLX( E( JS ) ) )
         ELSE
            JS = MIN( INDXG2L( J+JB-1, NB, 0, DESCA( CSRC_ ), NPCOL ),
     $                NQ )
            IF( JS.GT.0 )
     $         CALL PCELSET( A, I+JB, J+JB-1, DESCA, CMPLX( E( JS ) ) )
         END IF
*
         K = K + JB
         JB = NB
         IW = 1
         JW = 1
         DESCWX( M_ ) = DESCWX( M_ ) - JB
         DESCWX( RSRC_ ) = MOD( DESCWX( RSRC_ ) + 1, NPROW )
         DESCWX( CSRC_ ) = MOD( DESCWX( CSRC_ ) + 1, NPCOL )
         DESCWY( N_ ) = DESCWY( N_ ) - JB
         DESCWY( RSRC_ ) = MOD( DESCWY( RSRC_ ) + 1, NPROW )
         DESCWY( CSRC_ ) = MOD( DESCWY( CSRC_ ) + 1, NPCOL )
*
   10 CONTINUE
*
*     Use unblocked code to reduce the remainder of the matrix.
*
      CALL PCGEBD2( M-K+1, N-K+1, A, IA+K-1, JA+K-1, DESCA, D, E, TAUQ,
     $              TAUP, WORK, LWORK, IINFO )
*
      CALL PB_TOPSET( ICTXT, 'Combine', 'Columnwise', COLCTOP )
      CALL PB_TOPSET( ICTXT, 'Combine', 'Rowwise',    ROWCTOP )
*
      WORK( 1 ) = CMPLX( REAL( LWMIN ) )
*
      RETURN
*
*     End of PCGEBRD
*
      END

ext: f

max_stars_repo_name: jschueller/scalapack

max_issues_repo_name: jschueller/scalapack

max_forks_repo_name: jschueller/scalapack


text:
! RUN: bbc -emit-fir %s -o - | FileCheck %s

! TODO: Descriptor (fir.box) will most likely be used for pointers
! (at least for the character case below). This code is hitting a
! hard todo until pointers are handled correctly.
! XFAIL: true

! CHECK-LABEL: func @_QPpointertests
subroutine pointerTests
    ! CHECK: fir.global internal @_QFpointertestsEptr1 : !fir.ptr<i32>
    integer, pointer :: ptr1 => NULL()
    ! CHECK: %[[c0:.*]] = arith.constant 0 : index
    ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref<none>
    ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref<none>) -> !fir.ptr<i32>
    ! CHECK: fir.has_value [[reg2]] : !fir.ptr<i32>

    ! CHECK: fir.global internal @_QFpointertestsEptr2 : !fir.ptr<f32>
    real, pointer :: ptr2 => NULL()
    ! CHECK: %[[c0:.*]] = arith.constant 0 : index
    ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref<none>
    ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref<none>) -> !fir.ptr<f32>
    ! CHECK: fir.has_value [[reg2]] : !fir.ptr<f32>

    ! CHECK: fir.global internal @_QFpointertestsEptr3 : !fir.ptr<!fir.complex<4>>
    complex, pointer :: ptr3 => NULL()
    ! CHECK: %[[c0:.*]] = arith.constant 0 : index
    ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref<none>
    ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref<none>) -> !fir.ptr<!fir.complex<4>>
    ! CHECK: fir.has_value [[reg2]] : !fir.ptr<!fir.complex<4>>

    ! CHECK: fir.global internal @_QFpointertestsEptr4 : !fir.ptr<!fir.char<1,?>>
    character(:), pointer :: ptr4 => NULL()
    ! CHECK: %[[c0:.*]] = arith.constant 0 : index
    ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref<none>
    ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref<none>) -> !fir.ptr<!fir.char<1,?>>
    ! CHECK: fir.has_value [[reg2]] : !fir.ptr<!fir.char<1,?>>

    ! CHECK: fir.global internal @_QFpointertestsEptr5 : !fir.ptr<!fir.logical<4>>
    logical, pointer :: ptr5 => NULL()
    ! CHECK: %[[c0:.*]] = arith.constant 0 : index
    ! CHECK: [[reg1:%[0-9]+]] = fir.convert %[[c0:.*]] : (index) -> !fir.ref<none>
    ! CHECK: [[reg2:%[0-9]+]] = fir.convert [[reg1]] : (!fir.ref<none>) -> !fir.ptr<!fir.logical<4>>
    ! CHECK: fir.has_value [[reg2]] : !fir.ptr<!fir.logical<4>>

  end subroutine pointerTests

max_stars_repo_name: colemancda/llvm-project

max_issues_repo_name: colemancda/llvm-project

max_forks_repo_name: colemancda/llvm-project


text:
*----------------------------------------------------------------------*
      subroutine identify_vertices_i8(vtxmap,success,nskip,
     &     svtx_sub,vtx_sub,topo_sub,nvtx_sub,
     &     svtx,vtx,topo,nvtx)
*----------------------------------------------------------------------*
*     initial (and astonishingly simple) routine to identify a
*     sub-contraction in a contraction
*     topomaps are fantastic ...
*
*     rewritten for arbitrarily ordered contractions,
*     and with the possibility to skip nskip matching possibilities
*     (this way, a loop over nskip wrapped around this routine
*      may be used to systematically get all successful possibilities)
*----------------------------------------------------------------------*

      implicit none

      logical, intent(out) ::
     &     success
      integer, intent(in) ::
     &     nvtx, nvtx_sub, svtx(nvtx), svtx_sub(nvtx_sub), nskip
      integer(8), intent(in) ::
     &     vtx(nvtx), topo(nvtx,nvtx),
     &     vtx_sub(nvtx_sub), topo_sub(nvtx_sub,nvtx_sub)
      integer, intent(out) ::
     &     vtxmap(nvtx)

      integer ::
     &     ivtx, jvtx, ivtx_sub, jvtx_sub,
     &     lenmap_sub(nvtx_sub), vtxmap_sub(nvtx_sub,nvtx),
     &     idist(nvtx_sub), one(nvtx_sub), iskip
      logical, external ::
     &     next_dist2

      success = .false.

      vtxmap = 0
      one = 1
      lenmap_sub = 0
      vtxmap_sub = 0
      iskip = 0

      ! set up vtxmap_sub: to which vtxs could a sub-vtx be assigned?
      do ivtx_sub = 1, nvtx_sub
        do ivtx = 1, nvtx
          if (vtx(ivtx).eq.vtx_sub(ivtx_sub)) then
            lenmap_sub(ivtx_sub) = lenmap_sub(ivtx_sub)+1
            vtxmap_sub(ivtx_sub,lenmap_sub(ivtx_sub)) = ivtx
          end if
        end do
      end do

      ! for all sub-vtxs there must be at least one possibility
      if (any(lenmap_sub(1:nvtx_sub).eq.0)) return

      idist = 1
      idist(1) = 0

      dist_loop: do while(next_dist2(idist,nvtx_sub,one,lenmap_sub,1))
        vtxmap = 0
        do ivtx_sub = 1, nvtx_sub
          if (vtxmap(vtxmap_sub(ivtx_sub,idist(ivtx_sub))).ne.0)
     &          cycle dist_loop
          vtxmap(vtxmap_sub(ivtx_sub,idist(ivtx_sub))) = ivtx_sub
        end do

        do ivtx = 1, nvtx-1
          ivtx_sub = vtxmap(ivtx)
          if (ivtx_sub.eq.0) cycle
          do jvtx = ivtx, nvtx
            jvtx_sub = vtxmap(jvtx)
            if (jvtx_sub.eq.0) cycle

              ! either same supervtx or different supervtx
              if (svtx(ivtx).eq.svtx(jvtx).neqv.
     &            svtx_sub(ivtx_sub).eq.svtx_sub(jvtx_sub))
     &          cycle dist_loop

              ! same connectivity
              if (topo(ivtx,jvtx).ne.topo_sub(ivtx_sub,jvtx_sub))
     &          cycle dist_loop
          end do
        end do

        ! skip if requested
        if (iskip.lt.nskip) then
          iskip = iskip + 1
          cycle dist_loop
        end if

        ! this is the vtxmap we were looking for
        success = .true.
        exit dist_loop
      end do dist_loop

      return
      end

max_stars_repo_name: ak-ustutt/GeCCo-public

max_issues_repo_name: ak-ustutt/GeCCo-public

max_forks_repo_name: ak-ustutt/GeCCo-public


text:
C    @(#)gt_intcom.f	20.2 2/28/00
C****************************************************************
C
C     File: gt_intcom.f
C
C     Purpose: Routine to retrieve specific arrays from specific
c     commons //
C
C     Input parameters:
C
C             tag      - "NUMOWN"
C                        "OWNER_O"
C             variable -
c             size     -
C
C     Author: Walt Powell  Date: 21 Jan 2000
C     Called by: ext_geown.f
C
C****************************************************************
      subroutine gt_intcom (tag, array, size)
      character *(*) tag
      integer array(*), size

      include 'ipfinc/parametr.inc'

      include 'ipfinc/prt.inc'
      include 'ipfinc/ownhash.inc'

      if (tag .eq. 'NUMOWN') then
        array(1) = numown
      else
        write (errbuf(1), 10000) tag
10000   format ('Illegal call to subroutine gt_intcom (', a, ')')
        call prterx ('W', 1)
      endif

      return
      end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
       PARAMETER (NSTEP=25)
       DIMENSION PHI(0:NSTEP)
       DIMENSION ALPHA(0:NSTEP),BETA(0:NSTEP),GAMMA(0:NSTEP)

       GAUSS(X,T)=EXP(-20.*(X-.5)**2/(1.+80*T))/SQRT(1+80*T)
       EXACT(X,T)=GAUSS(X,T)-GAUSS(X-1.,T)-GAUSS(X+1.,T)

       H=1./NSTEP

50     PRINT *, ' Enter time step and total time (0 to stop)'
       READ *,DT,TIME
       IF (DT .EQ. 0.) STOP
       NITER=TIME/DT
       DTH=DT/H**2

       T=0.
       PHI(0)=0.
       PHI(NSTEP)=0.
       DO 10 IX=1,NSTEP-1
          PHI(IX)=EXACT(IX*H,T)
10     CONTINUE

       AP=-DTH
       AZ=1.+2*DTH
       ALPHA(NSTEP-1)=0.
       GAMMA(NSTEP-1)=-1./AZ
       DO 15 IX=NSTEP-1,1,-1
          ALPHA(IX-1)=GAMMA(IX)*AP
          GAMMA(IX-1)=-1./(AZ+AP*ALPHA(IX-1))
15     CONTINUE

       DO 20 ITER=1,NITER

          BETA(NSTEP-1)=PHI(NSTEP)
          DO 25 IX=NSTEP-1,1,-1
             BETA(IX-1)=GAMMA(IX)*(AP*BETA(IX)-PHI(IX))
25        CONTINUE

          PHI(0)=0.
          DO 30 IX=0,NSTEP-1
             PHI(IX+1)=ALPHA(IX)*PHI(IX)+BETA(IX)
30        CONTINUE

          IF (MOD(ITER,10) .EQ. 0) THEN
             PRINT *, ' iteration = ', ITER, ' time = ',ITER*DT
             T=ITER*DT
             DO 40 IX=1,NSTEP-1
                DIFF=PHI(IX)-EXACT(IX*H,T)
                PRINT *, ' phi = ', PHI(IX),' error = ', DIFF
40           CONTINUE
          END IF
20     CONTINUE

       GOTO 50
       END

ext: for


text:
C
C     file pois3d.f
C
      SUBROUTINE POIS3D (LPEROD,L,C1,MPEROD,M,C2,NPEROD,N,A,B,C,LDIMF,
     1                   MDIMF,F,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C DIMENSION OF           A(N), B(N), C(N), F(LDIMF,MDIMF,N),
C ARGUMENTS              W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SOLVES THE LINEAR SYSTEM OF EQUATIONS
C                        FOR UNKNOWN X VALUES, WHERE I=1,2,...,L,
C                        J=1,2,...,M, AND K=1,2,...,N
C
C                        C1*(X(I-1,J,K) -2.*X(I,J,K) +X(I+1,J,K)) +
C                        C2*(X(I,J-1,K) -2.*X(I,J,K) +X(I,J+1,K)) +
C                        A(K)*X(I,J,K-1) +B(K)*X(I,J,K)+ C(K)*X(I,J,K+1)
C                        = F(I,J,K)
C
C                        THE INDICES K-1 AND K+1 ARE EVALUATED MODULO N,
C                        I.E. X(I,J,0)=X(I,J,N) AND X(I,J,N+1)=X(I,J,1).
C                        THE UNKNOWNS
C                        X(0,J,K), X(L+1,J,K), X(I,0,K), AND X(I,M+1,K)
C                        ARE ASSUMED TO TAKE ON CERTAIN PRESCRIBED
C                        VALUES DESCRIBED BELOW.
C
C USAGE                  CALL POIS3D (LPEROD,L,C1,MPEROD,M,C2,NPEROD,
C                        N,A,B,C,LDIMF,MDIMF,F,IERROR,W)
C
C ARGUMENTS
C
C ON INPUT
C                        LPEROD
C                          INDICATES THE VALUES THAT X(0,J,K) AND
C                          X(L+1,J,K) ARE ASSUMED TO HAVE.
C                          = 0  X(0,J,K)=X(L,J,K), X(L+1,J,K)=X(1,J,K)
C                          = 1  X(0,J,K) = 0,      X(L+1,J,K) = 0
C                          = 2  X(0,J,K)=0,        X(L+1,J,K)=X(L-1,J,K)
C                          = 3  X(0,J,K)=X(2,J,K), X(L+1,J,K)=X(L-1,J,K)
C                          = 4  X(0,J,K)=X(2,J,K), X(L+1,J,K) = 0.
C
C                        L
C                          THE NUMBER OF UNKNOWNS IN THE I-DIRECTION.
C                          L MUST BE AT LEAST 3.
C
C                        C1
C                          REAL CONSTANT IN THE ABOVE LINEAR SYSTEM
C                          OF EQUATIONS TO BE SOLVED.
C
C                        MPEROD
C                          INDICATES THE VALUES THAT X(I,0,K) AND
C                          X(I,M+1,K) ARE ASSUMED TO HAVE.
C                          = 0  X(I,0,K)=X(I,M,K), X(I,M+1,K)=X(I,1,K)
C                          = 1  X(I,0,K)=0,        X(I,M+1,K)=0
C                          = 2  X(I,0,K)=0,        X(I,M+1,K)=X(I,M-1,K)
C                          = 3  X(I,0,K)=X(I,2,K)  X(I,M+1,K)=X(I,M-1,K)
C                          = 4  X(I,0,K)=X(I,2,K)  X(I,M+1,K)=0
C
C                        M
C                          THE NUMBER OF UNKNOWNS IN THE J-DIRECTION.
C                          M MUST BE AT LEAST 3.
C
C                        C2
C                          REAL CONSTANT IN THE ABOVE LINEAR SYSTEM
C                          OF EQUATIONS TO BE SOLVED.
C
C                        NPEROD
C                          = 0  IF A(1) AND C(N) ARE NOT ZERO.
C                          = 1  IF A(1) = C(N) = 0.
C
C                        N
C                          THE NUMBER OF UNKNOWNS IN THE K-DIRECTION.
C                          N MUST BE AT LEAST 3.
C
C                        A, B, C
C                          ONE-DIMENSIONAL ARRAYS OF LENGTH N THAT
C                          SPECIFY THE COEFFICIENTS IN THE LINEAR
C                          EQUATIONS GIVEN ABOVE.
C
C                          IF NPEROD = 0 THE ARRAY ELEMENTS MUST NOT
C                          DEPEND UPON INDEX K, BUT MUST BE CONSTANT.
C                          SPECIFICALLY,THE SUBROUTINE CHECKS THE
C                          FOLLOWING CONDITION
C                            A(K) = C(1)
C                            C(K) = C(1)
C                            B(K) = B(1)
C                          FOR K=1,2,...,N.
C
C                        LDIMF
C                          THE ROW (OR FIRST) DIMENSION OF THE THREE-
C                          DIMENSIONAL ARRAY F AS IT APPEARS IN THE
C                          PROGRAM CALLING POIS3D.  THIS PARAMETER IS
C                          USED TO SPECIFY THE VARIABLE DIMENSION
C                          OF F.  LDIMF MUST BE AT LEAST L.
C
C                        MDIMF
C                          THE COLUMN (OR SECOND) DIMENSION OF THE THREE
C                          DIMENSIONAL ARRAY F AS IT APPEARS IN THE
C                          PROGRAM CALLING POIS3D.  THIS PARAMETER IS
C                          USED TO SPECIFY THE VARIABLE DIMENSION
C                          OF F.  MDIMF MUST BE AT LEAST M.
C
C                        F
C                          A THREE-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE RIGHT SIDE OF THE LINEAR SYSTEM
C                          OF EQUATIONS GIVEN ABOVE.  F MUST BE
C                          DIMENSIONED AT LEAST L X M X N.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED
C                          BY THE USER FOR WORK SPACE.  THE LENGTH OF W
C                          MUST BE AT LEAST
C                            30 + L + M + 2*N + MAX(L,M,N) +
C                            7*(INT((L+1)/2) + INT((M+1)/2)).
C
C ON OUTPUT
C
C                        F
C                          CONTAINS THE SOLUTION X.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS.  EXCEPT FOR NUMBER ZERO, A
C                          SOLUTION IS NOT ATTEMPTED.
C                          = 0  NO ERROR
C                          = 1  IF LPEROD .LT. 0 OR .GT. 4
C                          = 2  IF L .LT. 3
C                          = 3  IF MPEROD .LT. 0 OR .GT. 4
C                          = 4  IF M .LT. 3
C                          = 5  IF NPEROD .LT. 0 OR .GT. 1
C                          = 6  IF N .LT. 3
C                          = 7  IF LDIMF .LT. L
C                          = 8  IF MDIMF .LT. M
C                          = 9  IF A(K) .NE. C(1) OR C(K) .NE. C(1)
C                               OR B(I) .NE.B(1) FOR SOME K=1,2,...,N.
C                          = 10 IF NPEROD = 1 AND A(1) .NE. 0
C                               OR C(N) .NE. 0
C
C                          SINCE THIS IS THE ONLY MEANS OF INDICATING A
C                          POSSIBLY INCORRECT CALL TO POIS3D, THE USER
C                          SHOULD TEST IERROR AFTER THE CALL.
C
C SPECIAL CONDITIONS     NONE
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       COMF AND FFTPACK FROM FISHPACK
C FILES
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN THE LATE
C                        1970'S.  RELEASED ON NCAR'S PUBLIC SOFTWARE
C                        LIBRARIES IN JANUARY, 1980.
C
C PORTABILITY            FORTRAN 77
C
C ALGORITHM              THIS SUBROUTINE SOLVES THREE-DIMENSIONAL BLOCK
C                        TRIDIAGONAL LINEAR SYSTEMS ARISING FROM FINITE
C                        DIFFERENCE APPROXIMATIONS TO THREE-DIMENSIONAL
C                        POISSON EQUATIONS USING THE FFT PACKAGE
C                        FFTPACK WRITTEN BY PAUL SWARZTRAUBER.
C
C TIMING                 FOR LARGE L, M AND N, THE OPERATION COUNT
C                        IS ROUGHLY PROPORTIONAL TO
C                          L*M*N*(LOG2(L)+LOG2(M)+5)
C                        BUT ALSO DEPENDS ON INPUT PARAMETERS LPEROD
C                        AND MPEROD.
C
C ACCURACY               TO MEASURE THE ACCURACY OF THE ALGORITHM A
C                        UNIFORM RANDOM NUMBER GENERATOR WAS USED TO
C                        CREATE A SOLUTION ARRAY X FOR THE SYSTEM GIVEN
C                        IN THE 'PURPOSE' SECTION WITH
C                          A(K) = C(K) = -0.5*B(K) = 1,  K=1,2,...,N
C                        AND, WHEN NPEROD = 1
C                          A(1) = C(N) = 0
C                          A(N) = C(1) = 2.
C
C                        THE SOLUTION X WAS SUBSTITUTED INTO THE GIVEN
C                        SYSTEM AND, USING DOUBLE PRECISION, A RIGHT
C                        SIDE Y WAS COMPUTED.  USING THIS ARRAY Y
C                        SUBROUTINE POIS3D WAS CALLED TO PRODUCE AN
C                        APPROXIMATE SOLUTION Z.  RELATIVE ERROR
C
C                        E = MAX(ABS(Z(I,J,K)-X(I,J,K)))/MAX(ABS(X(I,J,K
C
C                        WAS COMPUTED, WHERE THE TWO MAXIMA ARE TAKEN
C                        OVER I=1,2,...,L, J=1,2,...,M AND K=1,2,...,N.
C                        VALUES OF E ARE GIVEN IN THE TABLE BELOW FOR
C                        SOME TYPICAL VALUES OF L,M AND N.
C
C                        L(=M=N)   LPEROD    MPEROD       E
C                        ------    ------    ------     ------
C
C                          16        0         0        1.E-13
C                          15        1         1        4.E-13
C                          17        3         3        2.E-13
C                          32        0         0        2.E-13
C                          31        1         1        2.E-12
C                          33        3         3        7.E-13
C
C REFERENCES              NONE
C ********************************************************************
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,
     1                F(LDIMF,MDIMF,1)       ,W(*)       ,SAVE(6)
C
      LP = LPEROD+1
      MP = MPEROD+1
      NP = NPEROD+1
C
C     CHECK FOR INVALID INPUT.
C
      IERROR = 0
      IF (LP.LT.1 .OR. LP.GT.5) IERROR = 1
      IF (L .LT. 3) IERROR = 2
      IF (MP.LT.1 .OR. MP.GT.5) IERROR = 3
      IF (M .LT. 3) IERROR = 4
      IF (NP.LT.1 .OR. NP.GT.2) IERROR = 5
      IF (N .LT. 3) IERROR = 6
      IF (LDIMF .LT. L) IERROR = 7
      IF (MDIMF .LT. M) IERROR = 8
      IF (NP .NE. 1) GO TO 103
      DO 101 K=1,N
         IF (A(K) .NE. C(1)) GO TO 102
         IF (C(K) .NE. C(1)) GO TO 102
         IF (B(K) .NE. B(1)) GO TO 102
  101 CONTINUE
      GO TO 104
  102 IERROR = 9
  103 IF (NPEROD.EQ.1 .AND. (A(1).NE.0. .OR. C(N).NE.0.)) IERROR = 10
  104 IF (IERROR .NE. 0) GO TO 122
      IWYRT = L+1
      IWT = IWYRT+M
      IWD = IWT+MAX0(L,M,N)+1
      IWBB = IWD+N
      IWX = IWBB+N
      IWY = IWX+7*((L+1)/2)+15
      GO TO (105,114),NP
C
C     REORDER UNKNOWNS WHEN NPEROD = 0.
C
  105 NH = (N+1)/2
      NHM1 = NH-1
      NODD = 1
      IF (2*NH .EQ. N) NODD = 2
      DO 111 I=1,L
         DO 110 J=1,M
            DO 106 K=1,NHM1
               NHPK = NH+K
               NHMK = NH-K
               W(K) = F(I,J,NHMK)-F(I,J,NHPK)
               W(NHPK) = F(I,J,NHMK)+F(I,J,NHPK)
  106       CONTINUE
            W(NH) = 2.*F(I,J,NH)
            GO TO (108,107),NODD
  107       W(N) = 2.*F(I,J,N)
  108       DO 109 K=1,N
               F(I,J,K) = W(K)
  109       CONTINUE
  110    CONTINUE
  111 CONTINUE
      SAVE(1) = C(NHM1)
      SAVE(2) = A(NH)
      SAVE(3) = C(NH)
      SAVE(4) = B(NHM1)
      SAVE(5) = B(N)
      SAVE(6) = A(N)
      C(NHM1) = 0.
      A(NH) = 0.
      C(NH) = 2.*C(NH)
      GO TO (112,113),NODD
  112 B(NHM1) = B(NHM1)-A(NH-1)
      B(N) = B(N)+A(N)
      GO TO 114
  113 A(N) = C(NH)
  114 CONTINUE
      CALL POS3D1 (LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,W,W(IWYRT),W(IWT),
     1             W(IWD),W(IWX),W(IWY),C1,C2,W(IWBB))
      GO TO (115,122),NP
  115 DO 121 I=1,L
         DO 120 J=1,M
            DO 116 K=1,NHM1
               NHMK = NH-K
               NHPK = NH+K
               W(NHMK) = .5*(F(I,J,NHPK)+F(I,J,K))
               W(NHPK) = .5*(F(I,J,NHPK)-F(I,J,K))
  116       CONTINUE
            W(NH) = .5*F(I,J,NH)
            GO TO (118,117),NODD
  117       W(N) = .5*F(I,J,N)
  118       DO 119 K=1,N
               F(I,J,K) = W(K)
  119       CONTINUE
  120    CONTINUE
  121 CONTINUE
      C(NHM1) = SAVE(1)
      A(NH) = SAVE(2)
      C(NH) = SAVE(3)
      B(NHM1) = SAVE(4)
      B(N) = SAVE(5)
      A(N) = SAVE(6)
  122 CONTINUE
      RETURN
      END
      SUBROUTINE POS3D1 (LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,XRT,YRT,T,D,
     1                   WX,WY,C1,C2,BB)
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,
     1                F(LDIMF,MDIMF,1)       ,XRT(*)     ,YRT(*)     ,
     2                T(*)       ,D(*)       ,WX(*)      ,WY(*)      ,
     3                BB(*)
      PI = PIMACH(DUM)
      LR = L
      MR = M
      NR = N
C
C     GENERATE TRANSFORM ROOTS
C
      LRDEL = ((LP-1)*(LP-3)*(LP-5))/3
      SCALX = LR+LRDEL
      DX = PI/(2.*SCALX)
      GO TO (108,103,101,102,101),LP
  101 DI = 0.5
      SCALX = 2.*SCALX
      GO TO 104
  102 DI = 1.0
      GO TO 104
  103 DI = 0.0
  104 DO 105 I=1,LR
         XRT(I) = -4.*C1*(SIN((FLOAT(I)-DI)*DX))**2
  105 CONTINUE
      SCALX = 2.*SCALX
      GO TO (112,106,110,107,111),LP
  106 CALL SINTI (LR,WX)
      GO TO 112
  107 CALL COSTI (LR,WX)
      GO TO 112
  108 XRT(1) = 0.
      XRT(LR) = -4.*C1
      DO 109 I=3,LR,2
         XRT(I-1) = -4.*C1*(SIN(FLOAT((I-1))*DX))**2
         XRT(I) = XRT(I-1)
  109 CONTINUE
      CALL RFFTI (LR,WX)
      GO TO 112
  110 CALL SINQI (LR,WX)
      GO TO 112
  111 CALL COSQI (LR,WX)
  112 CONTINUE
      MRDEL = ((MP-1)*(MP-3)*(MP-5))/3
      SCALY = MR+MRDEL
      DY = PI/(2.*SCALY)
      GO TO (120,115,113,114,113),MP
  113 DJ = 0.5
      SCALY = 2.*SCALY
      GO TO 116
  114 DJ = 1.0
      GO TO 116
  115 DJ = 0.0
  116 DO 117 J=1,MR
         YRT(J) = -4.*C2*(SIN((FLOAT(J)-DJ)*DY))**2
  117 CONTINUE
      SCALY = 2.*SCALY
      GO TO (124,118,122,119,123),MP
  118 CALL SINTI (MR,WY)
      GO TO 124
  119 CALL COSTI (MR,WY)
      GO TO 124
  120 YRT(1) = 0.
      YRT(MR) = -4.*C2
      DO 121 J=3,MR,2
         YRT(J-1) = -4.*C2*(SIN(FLOAT((J-1))*DY))**2
         YRT(J) = YRT(J-1)
  121 CONTINUE
      CALL RFFTI (MR,WY)
      GO TO 124
  122 CALL SINQI (MR,WY)
      GO TO 124
  123 CALL COSQI (MR,WY)
  124 CONTINUE
      IFWRD = 1
      IS = 1
  125 CONTINUE
C
C     TRANSFORM X
C
      DO 141 J=1,MR
         DO 140 K=1,NR
            DO 126 I=1,LR
               T(I) = F(I,J,K)
  126       CONTINUE
            GO TO (127,130,131,134,135),LP
  127       GO TO (128,129),IFWRD
  128       CALL RFFTF (LR,T,WX)
            GO TO 138
  129       CALL RFFTB (LR,T,WX)
            GO TO 138
  130       CALL SINT (LR,T,WX)
            GO TO 138
  131       GO TO (132,133),IFWRD
  132       CALL SINQF (LR,T,WX)
            GO TO 138
  133       CALL SINQB (LR,T,WX)
            GO TO 138
  134       CALL COST (LR,T,WX)
            GO TO 138
  135       GO TO (136,137),IFWRD
  136       CALL COSQF (LR,T,WX)
            GO TO 138
  137       CALL COSQB (LR,T,WX)
  138       CONTINUE
            DO 139 I=1,LR
               F(I,J,K) = T(I)
  139       CONTINUE
  140    CONTINUE
  141 CONTINUE
      GO TO (142,164),IFWRD
C
C     TRANSFORM Y
C
  142 CONTINUE
      DO 158 I=1,LR
         DO 157 K=1,NR
            DO 143 J=1,MR
               T(J) = F(I,J,K)
  143       CONTINUE
            GO TO (144,147,148,151,152),MP
  144       GO TO (145,146),IFWRD
  145       CALL RFFTF (MR,T,WY)
            GO TO 155
  146       CALL RFFTB (MR,T,WY)
            GO TO 155
  147       CALL SINT (MR,T,WY)
            GO TO 155
  148       GO TO (149,150),IFWRD
  149       CALL SINQF (MR,T,WY)
            GO TO 155
  150       CALL SINQB (MR,T,WY)
            GO TO 155
  151       CALL COST (MR,T,WY)
            GO TO 155
  152       GO TO (153,154),IFWRD
  153       CALL COSQF (MR,T,WY)
            GO TO 155
  154       CALL COSQB (MR,T,WY)
  155       CONTINUE
            DO 156 J=1,MR
               F(I,J,K) = T(J)
  156       CONTINUE
  157    CONTINUE
  158 CONTINUE
      GO TO (159,125),IFWRD
  159 CONTINUE
C
C     SOLVE TRIDIAGONAL SYSTEMS IN Z
C
      DO 163 I=1,LR
         DO 162 J=1,MR
            DO 160 K=1,NR
               BB(K) = B(K)+XRT(I)+YRT(J)
               T(K) = F(I,J,K)
  160       CONTINUE
            CALL TRID (NR,A,BB,C,T,D)
            DO 161 K=1,NR
               F(I,J,K) = T(K)
  161       CONTINUE
  162    CONTINUE
  163 CONTINUE
      IFWRD = 2
      IS = -1
      GO TO 142
  164 CONTINUE
      DO 167 I=1,LR
         DO 166 J=1,MR
            DO 165 K=1,NR
               F(I,J,K) = F(I,J,K)/(SCALX*SCALY)
  165       CONTINUE
  166    CONTINUE
  167 CONTINUE
      RETURN
      END
      SUBROUTINE TRID (MR,A,B,C,Y,D)
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,Y(*)       ,
     1                D(*)
      M = MR
      MM1 = M-1
      Z = 1./B(1)
      D(1) = C(1)*Z
      Y(1) = Y(1)*Z
      DO 101 I=2,MM1
         Z = 1./(B(I)-A(I)*D(I-1))
         D(I) = C(I)*Z
         Y(I) = (Y(I)-A(I)*Y(I-1))*Z
  101 CONTINUE
      Z = B(M)-A(M)*D(MM1)
      IF (Z .NE. 0.) GO TO 102
      Y(M) = 0.
      GO TO 103
  102 Y(M) = (Y(M)-A(M)*Y(MM1))/Z
  103 CONTINUE
      DO 104 IP=1,MM1
         I = M-IP
         Y(I) = Y(I)-D(I)*Y(I+1)
  104 CONTINUE
      RETURN
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END

max_stars_repo_name: ipelupessy/omuse

max_issues_repo_name: ipelupessy/omuse

max_forks_repo_name: ipelupessy/omuse


text:
      SUBROUTINE IFT
C
C     INVERSE FOURIER TRANSFORM MODULE (IFT)
C
C     DMAP CALLING SEQ.
C
C     IFT   UHVF,CASECC,TRL,FOL/UHVT,TOL/C,Y,IFTM
C
      INTEGER SYSBUF,      IZ(1),UHVF,UHVT,CASECC,TRL,TOL,FOL,NAME(2),
     1  MCB(7),FILE,MCB1(7)
      COMMON /SYSTEM/SYSBUF,NOUT
      COMMON /PACKX/IT1,IT2,II,JJ,INCR
      COMMON /UNPAKX/IT3,II1,JJ1,INCR1
      COMMON /CONDAS/ PHI,TWOPI
      COMMON  /ZZZZZZ/ Z(1)
      COMMON /BLANK/ IFTM
      EQUIVALENCE (Z(1),IZ(1))
      DATA UHVF,CASECC,TRL,FOL,UHVT,TOL/101,102,103,104,201,202/
      DATA NAME /4HIFT , 1H  /
C
C     VARIABLE CORE
C
C        CONTENT         LENGTH         POINTER
C        -------         ------         -------
C     FOL                NFREQ          IFREQ
C     TSTEP              NGROUP*3       ITSTP
C     UHVF               NMODES*NFREQ*2 IUHVF
C     CK                 NBIG           ICK
C     SK                 NBIG           ISK
C     UDOT               NMODES*NFREW*2 IUDOT
C     UHVT               NMODES         IUVT
C
C
C
C     PUT FOL INTO CORE
C
      NZ = KORSZ(IZ)
      IBUF1 = NZ-SYSBUF+1
      IBUF2 = IBUF1-SYSBUF
      NZ = NZ-2*SYSBUF
      FILE = FOL
      CALL OPEN(*900,FOL,IZ(IBUF1),0)
      CALL FREAD(FOL ,IZ,-2,0)
      CALL READ(*910,*10,FOL,IZ,NZ,0,NFREQ)
      CALL MESAGE(-8,0,NAME)
   10 CALL CLOSE(FOL ,1)
      IFREQ = 1
      NZ = NZ-NFREQ
      ITSTP=NFREQ+1
C
C     DEFINE BASIC SIZES
C
      MCB(1) = UHVF
      CALL RDTRL(MCB)
      NLOAD = MCB(2)/NFREQ
      NMODES = MCB(3)
      MCB(1) = UHVT
      MCB(2) = 0
      MCB(5) = 1
      MCB(6) = 0
      MCB(7) = 0
      K = NFREQ + 2*(NMODES*NFREQ*2) + NMODES
      IF(K .GT. NZ) CALL  MESAGE(-8,0,NAME)
C
C     DETERMINE IF EQUAL FREQ - CONVERT TO W'S
C
      DELW = Z(IFREQ+1)-Z(IFREQ)
      EPSI = DELW*1.E-6
      J = NFREQ-1
      IEQUAL = 1
      DO 20 I=1,J
      M = IFREQ+I-1
      IF( ABS(Z(M+1)-Z(M)-DELW) .GE. EPSI) IEQUAL = 0
      Z(M) = Z(M)*TWOPI
   20 CONTINUE
      Z(IFREQ+NFREQ-1) = Z(IFREQ+NFREQ-1)*TWOPI
      DELW = DELW*TWOPI
C
C     FIRST FREQUENCY MUST BE MULTIPLE OF DELW
C
      NBIG = ABS(Z(IFREQ)/DELW)+.1
      IF(ABS(FLOAT(NBIG)*DELW-ABS(Z(IFREQ))) .GT. EPSI) IEQUAL = 0
      LLL = NBIG -1
C
C     FIND TSTEP IN TRL
C
      CALL GOPEN(CASECC,IZ(IBUF1),0)
      CALL FREAD(CASECC,0,-37,0)
      CALL FREAD(CASECC,J,1,0)
      CALL CLOSE(CASECC,1)
      FILE = TRL
      CALL OPEN(*900,TRL,IZ(IBUF1),0)
      CALL FREAD(TRL,MCB1,3,1)
      M = MCB1(3)
      CALL SKPREC(TRL,M)
   25 CONTINUE
      CALL FREAD(TRL,M,1,0)
      IF(M .EQ. J) GO TO 30
      CALL FREAD(TRL,0,0,1)
      GO TO 25
C
C     FOUND TSTEP
C
   30 CALL READ(*910,*40,TRL,IZ(ITSTP),NZ,0,NGROUP)
      CALL MESAGE(-8,0,NAME)
   40 NZ = NZ-NGROUP
      IUHVF = ITSTP+NGROUP
      CALL CLOSE(TRL,1)
      NGROUP = NGROUP/3
      IF(NGROUP .NE. 1) IEQUAL = 0
      IF( IEQUAL .EQ. 0 ) GO TO 50
C
C     FORCE WAT TO BE INTEGER MULTIPLE OF TWOPI/N
C
      FBIG = TWOPI/(DELW*Z(ITSTP+1))
      NBIG = FBIG+.9
      Z(ITSTP+1) = TWOPI/(FLOAT(NBIG)*DELW)
   50 CONTINUE
C
C     BUILD / WRITE TOL
C
      FILE = TOL
      CALL OPEN(*900,TOL,IZ(IBUF1),1)
      CALL FNAME(TOL,MCB1)
      CALL WRITE(TOL,MCB1,2,0)
      DELT = Z(ITSTP+1)
      T = 0.0
      N = 0
      M = ITSTP
      DO 60 I=1,NGROUP
      NSTEP = IZ(M)
      IF(I .EQ. 1) NSTEP = NSTEP +1
      M = M+3
      DO 70 J=1,NSTEP
      CALL WRITE(TOL,T,1,0)
      N = N+1
      IF(J .EQ. NSTEP  .AND. I .NE. NGROUP) DELT = Z(M+1)
      T = T+DELT
   70 CONTINUE
   60 CONTINUE
      CALL WRITE(TOL,0,0,1)
      CALL CLOSE(TOL,1)
      MCB1(1) = TOL
      MCB1(2) = NGROUP
      MCB1(3) = N
      MCB1(4) = 0
      MCB1(5) = 0
      MCB1(6) = 0
      MCB1(7) = 0
      CALL WRTTRL(MCB1)
C
C     BUILD TABLE OF CK, SK
C
      ICK = IUHVF + 2*NMODES*NFREQ
      ISK = ICK
      IUDOT = ISK
      IF( IEQUAL .EQ. 0 ) GO TO 100
      ISK = ICK + NBIG
      IUDOT = ISK + NBIG
      M = ICK
      M1 = ISK
      M2 = ISK
      J = IUDOT
      RP = COS(TWOPI/FLOAT(NBIG))
      CP = SIN(TWOPI/FLOAT(NBIG))
      I = M
      N = M1+1
      L = M2
      KK = J
      Z(I) = 1.0
      Z(L) = 0.0
   65 IF(M1-I-2) 61,62,63
   62 CMNR = -1.
      CMNC = 0.
      GO TO 64
   63 CMNR = RP*Z(I) -CP*Z(L)
      CMNC = CP*Z(I) +RP*Z(L)
   64 I = I+1
      L = L+1
      M1 = M1-1
      KK = KK-1
      Z(I) = CMNR
      Z(L) = CMNC
      Z(M1) = CMNR
      Z(KK) = -CMNC
      GO TO 65
   61 CONTINUE
C     GET READY FOR OUTPUTS
C
  100 CALL GOPEN(UHVF,IZ(IBUF1),0)
      CALL GOPEN(UHVT,IZ(IBUF2),1)
      IT1 = 1
      IT2 = 1
      II = 1
      JJ=NMODES
      INCR = 1
      IT3 = 3
      II1 = 1
      JJ1 = NMODES
      INCR1 = 1
      IUVT = IUDOT
      IF(IFTM .EQ. 2) IUVT = IUVT+2*NFREQ*NMODES
      ASSIGN 235 TO IHOP
C
C     BEGIN LOOP ON LOADS
C
      DO 200 I=1,NLOAD
C
C     PUT UHVF INTO CORE
C
      DO 110 J=1,NFREQ
      M = IUHVF+(J-1)*NMODES*2
      CALL UNPACK(*120,UHVF,Z(M))
      GO TO 110
  120 CALL ZEROC(Z(M),2*NMODES)
  110 CONTINUE
      IF(IFTM .NE. 2) GO TO 150
      ASSIGN 236 TO IHOP
C
C     COMPUTE SPLINE FIT FOR U DOT
C
C
C     COMPUTE A'S
C
      IAP = IUVT + NMODES
      M =NFREQ + IAP - 1
      Z(M) = 0.0
      L = NFREQ-2
      IF(L .LE. 0) GO TO 126
      DO 125 J=1,L
      M = IAP + NFREQ -J-1
      N = IFREQ + NFREQ-J-1
      Z(M) = (Z(N) - Z(N-1))/(2.*(Z(N+1)-Z(N-1))-(Z(N+1)-Z(N))*Z(M+1))
  125 CONTINUE
  126 CONTINUE
C
C     COMPUTE U DOT DOT
C
      DO 122 M1=1,NMODES
      M = IUDOT +(NFREQ-1)*NMODES*2 +(M1-1)*2
      Z(M) = 0.0
      Z(M+1) = 0.0
C
C     BEGIN BACKWARD PASS
C
      M2= IUHVF +(NFREQ-1)*NMODES*2 +(M1-1)*2
      IF(L .LE. 0) GO TO 122
      DO 130 J=1,L
      N2 = M
      M = M-NMODES*2
      N = IFREQ + NFREQ -J-1
      M2 = M2-NMODES*2
      KK = IAP + NFREQ-J
      LL = M2+2*NMODES
      RP = Z(N+1) - Z(N)
      CP = Z(N) -Z(N-1)
      N1 = M2-2*NMODES
      Z(M) = (6. *((Z(LL)-Z(M2))/RP-(Z(M2)-Z(N1))/CP)-RP*Z(KK)*Z(N2))
     U   /CP
      Z(M+1) = (6.*((Z(LL+1)-Z(M2+1))/RP-(Z(M2+1)-Z(N1+1))/CP)-RP*Z(KK)*
     1  Z(N2+1))/CP
  130 CONTINUE
  122 CONTINUE
C
C     BEGIN FORWARD PASS
C
      DO 135 M1=1,NMODES
      M = IUDOT +(M1-1)*2
      M2 = IUHVF +(M1-1)*2
      N1 = M2+2*NMODES
      LL = M+2*NMODES
      RP = Z(IFREQ+1) -Z(IFREQ)
      Z(M) =(6.*(Z(N1)-Z(M2))/RP-RP*Z(IAP+1)*Z(LL))/(6.*Z(IFREQ)+(RP)*
     1  (2.-Z(IAP+1)) )
      Z(M+1) = 0.0
      DO 138 J=2,NFREQ
      KK = IAP+J-1
      M2 = M
      M = M+2*NMODES
      Z(M) = Z(KK)*(Z(LL) - Z(M2))
      Z(M+1) = Z(KK)*(Z(LL+1)-Z(M2+1))
      LL = LL + 2*NMODES
  138 CONTINUE
  135 CONTINUE
  150 CONTINUE
      T = 0.0
      N = 0
      M = ITSTP
      DELT = Z(ITSTP+1)
C
C     BEGIN LOOP ON TIMES
C
      DO 160 L=1,NGROUP
      NSTEP = IZ(M)
      IF(L .EQ. 1) NSTEP = NSTEP+1
      M = M+3
      DO 170 J=1,NSTEP
      TT = T
      CALL ZEROC(Z(IUVT),NMODES)
C
C     BEGIN LOOP ON FREQUENCIES
C
      LX = LLL
      DO 180 LL=1,NFREQ
      LX = LX+1
      WN = Z(IFREQ+LL-1)
      IF(LL .EQ. 1) GO TO 191
      WNM1 = Z(IFREQ+LL-2)
  191 IF(LL .EQ. NFREQ) GO TO 192
      WNP1 = Z(IFREQ+LL)
  192 CONTINUE
      IF(IEQUAL .EQ. 0) GO TO 190
      KK = MOD(LX*N,NBIG)
      CK = Z(ICK+KK)
      SK = Z(ISK+KK)
      GO TO 195
  190 CK = COS(WN*TT)
      SK = SIN(WN*TT)
  195 CONTINUE
C
C     COMPUTE CMN, DMN
C
      IF(IFTM .NE. 0) GO TO 220
C
C     IFTM  =0
C
      CMNC = 0.0
      IF(LL .EQ. 1) GO TO 196
      IF(LL .EQ. NFREQ) GO TO 197
      CMNR = (WNP1-WNM1)*.5
      GO TO 230
  196 CONTINUE
      CMNR = WNP1-WN
      IF(WN .EQ. 0.0) CMNR = CMNR*.5
      GO TO 230
  197 CMNR = WN -WNM1
      GO TO 230
C
C     IFTM = 1
C
  220 CONTINUE
      IF(LL .EQ. 1) GO TO 221
      IF(LL.GT. 2 .AND. IEQUAL .NE. 0 .AND. LL .NE. NFREQ) GO TO 223
      R1 = WN-WNM1
      CALL IFTE2(-TT*R1,RP,CP)
      CMNR = R1*.5*RP
      CMNC = R1*.5*CP
      GO TO 222
  221 CMNR = 0.
      CMNC = 0.
  222 CONTINUE
      IF(LL .EQ. NFREQ) GO TO 223
      R2 = WNP1-WN
      CALL IFTE2(TT*R2,RP,CP)
      CMNR = CMNR+R2*.5*RP
      CMNC = CMNC+R2*.5*CP
  223 IF(IFTM .EQ. 2) GO TO 229
      DMNR = 0.0
      DMNC = 0.0
      GO TO 230
  229 CONTINUE
C
C     IFTM = 2
C
      IM2 = IUDOT -2 +(LL-1)*NMODES*2
      IF(LL .EQ. 1) GO TO 224
      IF(LL .GT. 2 .AND.  IEQUAL .NE. 0 .AND. LL .NE. NFREQ) GO TO 230
      CALL IFTG(-TT*R1,RP,CP)
      R1 = -R1*R1*R1/24.
      DMNR = R1*RP
      DMNC = R1*CP
      GO TO 228
  224 CONTINUE
      DMNR = 0.0
      DMNC = 0.0
  228 CONTINUE
      IF(LL .EQ. NFREQ) GO TO 230
      CALL IFTG(TT*R2,RP,CP)
      R2 = -R2*R2*R2/24.
      DMNR = DMNR+R2*RP
      DMNC = DMNC+R2*CP
  230 CONTINUE
      IM1 = IUHVF-2 +(LL-1)*NMODES*2
C
C     BEGIN LOOP ON MODES
C
      DO 240 KK=1,NMODES
      IM = IM1+2*KK
      RP = CMNR*Z(IM)-CMNC*Z(IM+1)
      CP = CMNC*Z(IM)+CMNR* Z(IM+1)
      GO TO IHOP,(235,236)
  236 CONTINUE
      IM = IM2+2*KK
      RP = RP+DMNR*Z(IM)-DMNC*Z(IM+1)
      CP = CP+DMNC*Z(IM)+DMNR*Z(IM+1)
  235 CONTINUE
      Z(IUVT+KK-1) = Z(IUVT+KK-1) + RP*CK-CP*SK
C
C     END LOOP ON MODES
C
  240 CONTINUE
C
C     END LOOP ON FREQUENCIES
C
  180 CONTINUE
      DO 181 KK=1,NMODES
      Z(IUVT+KK-1) = Z(IUVT+KK-1)/PHI
  181 CONTINUE
      CALL PACK(Z(IUVT),UHVT,MCB)
      DO 182 KK =1,2
      CALL BLDPK(1,1,UHVT,0,0)
      CALL BLDPKN(UHVT,0,MCB)
  182 CONTINUE
      IF(J .EQ. NSTEP) DELT = Z(M+1)
      T = T + DELT
      N = N+1
  170 CONTINUE
C
C     END LOOP ON TIME
C
  160 CONTINUE
C
C     END LOOP ON LOADS
C
  200 CONTINUE
      CALL CLOSE(UHVF,1)
      CALL CLOSE(UHVT,1)
      CALL WRTTRL(MCB)
      RETURN
C
C     ERROR MESSAGES
C
  900 N1=-1
  901 CALL MESAGE(N1,FILE,NAME)
      CALL PEXIT
  910 N1=-2
      GO TO 901
      END


SUBROUTINE emb_2d_geom(iel,nx1,nx2,ny1,ny2,w1,s1,w2,h1,h2,coord,num)
! Used in p64
! This subroutine forms the nodal coordinates and numbering for a 2-d
! slope of 8-node quadrilaterals. Nodes numbering in the y-direction,
! elements numbered in the x-direction.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::w1,s1,w2,h1,h2
 INTEGER,INTENT(IN)::iel,nx1,nx2,ny1,ny2
 REAL(iwp),INTENT(OUT)::coord(:,:)
 INTEGER,INTENT(OUT)::num(:)
 REAL(iwp)::facx,facy,facb,facs,frh,zero=0.0_iwp,pt5=0.5_iwp,one=1.0_iwp
 INTEGER::nxe,nye,nc,nt,ip,iq
 nxe=nx1+nx2
 nye=ny1+ny2
 nt=nx1*ny1
 nc=(3*nye+2)*nx1+2*ny1
 facx=s1/ny1
 facy=h1/ny1
 facb=(w1+s1)/nx1
 facs=zero
 IF(ny2/=0)facs=h2/ny2
 frh=zero
 IF(nx2/=0)frh=w2/nx2
 IF(iel<=nt)THEN
   iq=(iel-1)/nx1+1
   ip=iel-(iq-1)*nx1
 ELSE
   iq=(iel-nt-1)/nxe+ny1+1
   ip=iel-nt-(iq-ny1-1)*nxe
 END IF
 IF(ip<=nx1)THEN
   num(1)=(ip-1)*(3*nye+2)+2*iq+1
   num(2)=num(1)-1
   num(3)=num(1)-2
   num(4)=(ip-1)*(3*nye+2)+2*nye+iq+1
   num(5)=ip*(3*nye+2)+2*iq-1
   num(6)=num(5)+1
   num(7)=num(5)+2
   num(8)=num(4)+1
   IF(iq<=ny1)THEN
     coord(1,1)=(ip-one)*(w1+iq*facx)/nx1
     coord(3,1)=(ip-one)*(w1+(iq-1)*facx)/nx1
     coord(5,1)=ip*(w1+(iq-1)*facx)/nx1
     coord(7,1)=ip*(w1+iq*facx)/nx1
     coord(1,2)=-iq*facy
     coord(3,2)=-(iq-1)*facy
     coord(5,2)=-(iq-1)*facy
     coord(7,2)=-iq*facy
   ELSE
     coord(1,1)=(ip-one)*facb
     coord(3,1)=(ip-one)*facb
     coord(5,1)=ip*facb
     coord(7,1)=ip*facb
     coord(1,2)=-h1-(iq-ny1)*facs
     coord(3,2)=-h1-(iq-ny1-1)*facs
     coord(5,2)=-h1-(iq-ny1-1)*facs
     coord(7,2)=-h1-(iq-ny1)*facs
   END IF
 ELSE
   num(1)=nc+(ip-nx1-1)*(3*ny2+2)+2*(iq-ny1)+1
   num(2)=num(1)-1
   num(3)=num(1)-2
   num(4)=nc+(ip-nx1-1)*(3*ny2+2)+2*ny2+iq-ny1+1
   num(5)=nc+(ip-nx1)*(3*ny2+2)+2*(iq-ny1)-1
   num(6)=num(5)+1
   num(7)=num(5)+2
   num(8)=num(4)+1
   coord(1,1)=w1+s1+(ip-nx1-1)*frh
   coord(3,1)=coord(1,1)
   coord(5,1)=w1+s1+(ip-nx1)*frh
   coord(7,1)=coord(5,1)
   coord(1,2)=-h1-(iq-ny1)*facs
   coord(3,2)=-h1-(iq-ny1-1)*facs
   coord(5,2)=-h1-(iq-ny1-1)*facs
   coord(7,2)=-h1-(iq-ny1)*facs
 END IF
 coord(2:6:2,:)=pt5*(coord(1:5:2,:)+coord(3:7:2,:))
 coord(8,:)=pt5*(coord(7,:)+coord(1,:))
RETURN
END SUBROUTINE emb_2d_geom


module fftw3
    use, intrinsic :: iso_c_binding
    implicit none
    include 'fftw3.f03'
end module


text:
      MODULE cslh_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.3E  10:47:12   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
      SUBROUTINE cslh (NAME, NCORE, NBLKIN, IDBLK)
      CHARACTER (LEN = *) :: NAME
      INTEGER :: NCORE
      INTEGER, INTENT(IN) :: NBLKIN
      CHARACTER (LEN = 8), DIMENSION(*) :: IDBLK
!VAST.../HBLOCK/ NBLOCK(INOUT), PNCFBLK(INOUT)
!VAST.../ORB2/ NCFTOT(INOUT)
!VAST...Calls: ALLOC, SETCSLL, NCFBLK, RALLOC, LODCSH
!...This routine performs I/O.
      END SUBROUTINE
      END INTERFACE
      END MODULE

max_stars_repo_name: sylas/grasp-continuum

max_issues_repo_name: sylas/grasp-continuum

max_forks_repo_name: sylas/grasp-continuum


text:
      subroutine ttqqgHampsq(q,q1,q2,q3,q4,q5,eta1,eta2,ampsq)
      implicit none
      include 'constants.f'
      include 'masses.f'
      double precision q(mxpart,4),s134mmtsq,s234mmtsq,
     & s134,s234,s34,s35,s45,s345,s15,s25,s15mmtsq,
     & s25mmtsq,s1345mmtsq,
     & s2345mmtsq,s1345,s2345,ampsq
      double complex spstrng0,spstrng1,spstrng2,
     & spstrng3,cdot,m(4),
     & p1(4),p2(4),p3(4),p4(4),p5(4),et1(4),et2(4),
     & e1C(4),e1Cp(4),e1Cm(4),e2(4),e2p(4),e2m(4),e5m(4),e5p(4),e5(4),
     & e3(4),e3C(4),e4(4),e4C(4),
     & e3m(4),e4m(4),e3p(4),e4p(4),e3Cm(4),e4Cm(4),e3Cp(4),e4Cp(4),
     & p234(4),p34(4),p25(4),p35(4),p45(4),p345(4),p1345(4),
     & p2345(4),p15(4),p134(4),T34x21(2,2,2,2,2),
     & T21x34(2,2,2,2,2),T24x31(2,2,2,2,2),T31x24(2,2,2,2,2)
      integer q1,q2,q3,q4,q5,eta1,eta2,h1,h2,h3,h4,h5
      p1(:)=dcmplx(q(q1,:))
      p2(:)=dcmplx(q(q2,:))
      p3(:)=dcmplx(q(q3,:))
      p4(:)=dcmplx(q(q4,:))
      p5(:)=dcmplx(q(q5,:))
      et1(:)=dcmplx(q(eta1,:))
      et2(:)=dcmplx(q(eta2,:))
      p15(:)=dcmplx(q(q1,:)+q(q5,:))
      p25(:)=dcmplx(q(q2,:)+q(q5,:))
      p34(:)=dcmplx(q(q3,:)+q(q4,:))
      p45(:)=dcmplx(q(q4,:)+q(q5,:))
      p35(:)=dcmplx(q(q3,:)+q(q5,:))
      p345(:)=dcmplx(q(q3,:)+q(q4,:)+q(q5,:))
      p1345(:)=dcmplx(q(q1,:)+q(q3,:)+q(q4,:)+q(q5,:))
      p2345(:)=dcmplx(q(q2,:)+q(q3,:)+q(q4,:)+q(q5,:))
      p234(:)=dcmplx(q(q2,:)+q(q3,:)+q(q4,:))
      p134(:)=dcmplx(q(q1,:)+q(q3,:)+q(q4,:))
      s45=dble(p45(4)**2-p45(1)**2-p45(2)**2-p45(3)**2)
      s15=dble(p15(4)**2-p15(1)**2-p15(2)**2-p15(3)**2)
      s25=dble(p25(4)**2-p25(1)**2-p25(2)**2-p25(3)**2)
      s34=dble(p34(4)**2-p34(1)**2-p34(2)**2-p34(3)**2)
      s35=dble(p35(4)**2-p35(1)**2-p35(2)**2-p35(3)**2)
      s134=dble(p134(4)**2-p134(1)**2-p134(2)**2-p134(3)**2)
      s234=dble(p234(4)**2-p234(1)**2-p234(2)**2-p234(3)**2)
      s345=dble(p345(4)**2-p345(1)**2-p345(2)**2-p345(3)**2)
      s1345=dble(p1345(4)**2-p1345(1)**2-p1345(2)**2-p1345(3)**2)
      s2345=dble(p2345(4)**2-p2345(1)**2-p2345(2)**2-p2345(3)**2)
      s15mmtsq=s15-mt**2
      s25mmtsq=s25-mt**2
      s134mmtsq=s134-mt**2
      s234mmtsq=s234-mt**2
      s1345mmtsq=s1345-mt**2
      s2345mmtsq=s2345-mt**2
      h1=-1
      call VklSt(p1,mt,p3,h1,e1Cm)
      call UbKlst(p2,mt,p3,h1,e2m)
      call ubarspinor0(p3,h1,e3m)
      call uspinor0(p3,-h1,e3Cm)
      call ubarspinor0(p4,h1,e4m)
      call uspinor0(p4,-h1,e4Cm)
      call pol_real(p5,h1,e5m)
      h1=1
      call VKlSt(p1,mt,p3,h1,e1Cp)
      call UbKlSt(p2,mt,p3,h1,e2p)
      call ubarspinor0(p3,h1,e3p)
      call uspinor0(p3,-h1,e3Cp)
      call ubarspinor0(p4,h1,e4p)
      call uspinor0(p4,-h1,e4Cp)
      call pol_real(p5,h1,e5p)
      do h3=1,2
      if (h3 .eq. 1) then
         e3(:)=e3m(:)
         e3C(:)=e3Cm(:)
      elseif (h3 .eq. 2) then
         e3(:)=e3p(:)
         e3C(:)=e3Cp(:)
      endif
      h4=3-h3
      if (h4 .eq. 1) then
         e4(:)=e4m(:)
         e4C(:)=e4Cm(:)
      elseif (h4 .eq. 2) then
         e4(:)=e4p(:)
         e4C(:)=e4Cp(:)
      endif
      do h5=1,2
      if (h5 .eq. 1) e5(:)=e5m(:)
      if (h5 .eq. 2) e5(:)=e5p(:)
      do h1=1,2
      if (h1 .eq. 1) then
          e1C(:)=e1Cm(:)
      elseif (h1 .eq. 2) then
          e1C(:)=e1Cp(:)
      endif
      do h2=1,2
      if (h2 .eq. 1) then
          e2(:)=e2m(:)
      elseif (h2 .eq. 2) then
          e2(:)=e2p(:)
      endif
      T34x21(h1,h2,h3,h4,h5)= + xn**(-1)*two*s345**(-1) * (  -
     &    spstrng0(e2,e3C)*spstrng3(e4,e5,p45,p2345,e1C)*
     &    s2345mmtsq**(-1)*s45**(-1) + spstrng0(e2,e4C)*spstrng3(e3,e5,
     &    p35,p2345,e1C)*s2345mmtsq**(-1)*s35**(-1) + spstrng0(e3,e1C)*
     &    spstrng3(e2,p1345,p45,e5,e4C)*s1345mmtsq**(-1)*s45**(-1) -
     &    spstrng0(e4,e1C)*spstrng3(e2,p1345,p35,e5,e3C)*
     &    s1345mmtsq**(-1)*s35**(-1) + spstrng1(e2,p1345,e3C)*spstrng2(
     &    e4,e5,p45,e1C)*s1345mmtsq**(-1)*s45**(-1) - spstrng1(e2,p1345
     &    ,e4C)*spstrng2(e3,e5,p35,e1C)*s1345mmtsq**(-1)*s35**(-1) -
     &    spstrng1(e3,p2345,e1C)*spstrng2(e2,p45,e5,e4C)*
     &    s2345mmtsq**(-1)*s45**(-1) + spstrng1(e4,p2345,e1C)*spstrng2(
     &    e2,p35,e5,e3C)*s2345mmtsq**(-1)*s35**(-1) )
      T34x21(h1,h2,h3,h4,h5) = T34x21(h1,h2,h3,h4,h5) + xn**(-1)*two*mt
     & *s345**(-1) * (  - spstrng0(e2,e3C)*spstrng2(e4,e5,p45,e1C)*
     &    s1345mmtsq**(-1)*s45**(-1) - spstrng0(e2,e3C)*spstrng2(e4,e5,
     &    p45,e1C)*s2345mmtsq**(-1)*s45**(-1) + spstrng0(e2,e4C)*
     &    spstrng2(e3,e5,p35,e1C)*s1345mmtsq**(-1)*s35**(-1) +
     &    spstrng0(e2,e4C)*spstrng2(e3,e5,p35,e1C)*s2345mmtsq**(-1)*
     &    s35**(-1) - spstrng0(e3,e1C)*spstrng2(e2,p45,e5,e4C)*
     &    s1345mmtsq**(-1)*s45**(-1) - spstrng0(e3,e1C)*spstrng2(e2,p45
     &    ,e5,e4C)*s2345mmtsq**(-1)*s45**(-1) + spstrng0(e4,e1C)*
     &    spstrng2(e2,p35,e5,e3C)*s1345mmtsq**(-1)*s35**(-1) +
     &    spstrng0(e4,e1C)*spstrng2(e2,p35,e5,e3C)*s2345mmtsq**(-1)*
     &    s35**(-1) )

      T21x34(h1,h2,h3,h4,h5)= + s34**(-1)*xn**(-1)*two * ( spstrng0(e2,
     &    e3C)*spstrng3(e4,p234,e5,p2345,e1C)*s234mmtsq**(-1)*
     &    s2345mmtsq**(-1) - spstrng0(e2,e3C)*spstrng3(e4,p234,p15,e5,
     &    e1C)*s234mmtsq**(-1)*s15mmtsq**(-1) + spstrng0(e2,e4C)*
     &    spstrng3(e3,p234,e5,p2345,e1C)*s234mmtsq**(-1)*
     &    s2345mmtsq**(-1) - spstrng0(e2,e4C)*spstrng3(e3,p234,p15,e5,
     &    e1C)*s234mmtsq**(-1)*s15mmtsq**(-1) - spstrng0(e3,e1C)*
     &    spstrng3(e2,e5,p25,p134,e4C)*s134mmtsq**(-1)*s25mmtsq**(-1)
     &     + spstrng0(e3,e1C)*spstrng3(e2,p1345,e5,p134,e4C)*
     &    s134mmtsq**(-1)*s1345mmtsq**(-1) - spstrng0(e4,e1C)*spstrng3(
     &    e2,e5,p25,p134,e3C)*s134mmtsq**(-1)*s25mmtsq**(-1) +
     &    spstrng0(e4,e1C)*spstrng3(e2,p1345,e5,p134,e3C)*
     &    s134mmtsq**(-1)*s1345mmtsq**(-1) + spstrng1(e2,p1345,e3C)*
     &    spstrng2(e4,p15,e5,e1C)*s1345mmtsq**(-1)*s15mmtsq**(-1) +
     &    spstrng1(e2,p1345,e4C)*spstrng2(e3,p15,e5,e1C)*
     &    s1345mmtsq**(-1)*s15mmtsq**(-1) )
      T21x34(h1,h2,h3,h4,h5) = T21x34(h1,h2,h3,h4,h5) + s34**(-1)*
     & xn**(-1)*two * ( spstrng1(e3,p2345,e1C)*spstrng2(e2,e5,p25,e4C)*
     &    s2345mmtsq**(-1)*s25mmtsq**(-1) + spstrng1(e4,p2345,e1C)*
     &    spstrng2(e2,e5,p25,e3C)*s2345mmtsq**(-1)*s25mmtsq**(-1) )
      T21x34(h1,h2,h3,h4,h5) = T21x34(h1,h2,h3,h4,h5) + s34**(-1)*
     & xn**(-1)*two*mt * ( spstrng0(e2,e3C)*spstrng2(e4,e5,p2345,e1C)*
     &    s234mmtsq**(-1)*s2345mmtsq**(-1) - spstrng0(e2,e3C)*spstrng2(
     &    e4,p15,e5,e1C)*s234mmtsq**(-1)*s15mmtsq**(-1) - spstrng0(e2,
     &    e3C)*spstrng2(e4,p15,e5,e1C)*s1345mmtsq**(-1)*s15mmtsq**(-1)
     &     + spstrng0(e2,e3C)*spstrng2(e4,p234,e5,e1C)*s234mmtsq**(-1)*
     &    s2345mmtsq**(-1) + spstrng0(e2,e3C)*spstrng2(e4,p234,e5,e1C)*
     &    s234mmtsq**(-1)*s15mmtsq**(-1) + spstrng0(e2,e4C)*spstrng2(e3
     &    ,e5,p2345,e1C)*s234mmtsq**(-1)*s2345mmtsq**(-1) - spstrng0(e2
     &    ,e4C)*spstrng2(e3,p15,e5,e1C)*s234mmtsq**(-1)*s15mmtsq**(-1)
     &     - spstrng0(e2,e4C)*spstrng2(e3,p15,e5,e1C)*s1345mmtsq**(-1)*
     &    s15mmtsq**(-1) + spstrng0(e2,e4C)*spstrng2(e3,p234,e5,e1C)*
     &    s234mmtsq**(-1)*s2345mmtsq**(-1) + spstrng0(e2,e4C)*spstrng2(
     &    e3,p234,e5,e1C)*s234mmtsq**(-1)*s15mmtsq**(-1) + spstrng0(e3,
     &    e1C)*spstrng2(e2,e5,p25,e4C)*s134mmtsq**(-1)*s25mmtsq**(-1)
     &     + spstrng0(e3,e1C)*spstrng2(e2,e5,p25,e4C)*s2345mmtsq**(-1)*
     &    s25mmtsq**(-1) )
      T21x34(h1,h2,h3,h4,h5) = T21x34(h1,h2,h3,h4,h5) + s34**(-1)*
     & xn**(-1)*two*mt * (  - spstrng0(e3,e1C)*spstrng2(e2,e5,p134,e4C)
     &    *s134mmtsq**(-1)*s1345mmtsq**(-1) - spstrng0(e3,e1C)*
     &    spstrng2(e2,e5,p134,e4C)*s134mmtsq**(-1)*s25mmtsq**(-1) -
     &    spstrng0(e3,e1C)*spstrng2(e2,p1345,e5,e4C)*s134mmtsq**(-1)*
     &    s1345mmtsq**(-1) + spstrng0(e4,e1C)*spstrng2(e2,e5,p25,e3C)*
     &    s134mmtsq**(-1)*s25mmtsq**(-1) + spstrng0(e4,e1C)*spstrng2(e2
     &    ,e5,p25,e3C)*s2345mmtsq**(-1)*s25mmtsq**(-1) - spstrng0(e4,
     &    e1C)*spstrng2(e2,e5,p134,e3C)*s134mmtsq**(-1)*
     &    s1345mmtsq**(-1) - spstrng0(e4,e1C)*spstrng2(e2,e5,p134,e3C)*
     &    s134mmtsq**(-1)*s25mmtsq**(-1) - spstrng0(e4,e1C)*spstrng2(e2
     &    ,p1345,e5,e3C)*s134mmtsq**(-1)*s1345mmtsq**(-1) + spstrng1(e2
     &    ,e5,e3C)*spstrng1(e4,p2345,e1C)*s2345mmtsq**(-1)*
     &    s25mmtsq**(-1) + spstrng1(e2,e5,e4C)*spstrng1(e3,p2345,e1C)*
     &    s2345mmtsq**(-1)*s25mmtsq**(-1) - spstrng1(e2,p1345,e3C)*
     &    spstrng1(e4,e5,e1C)*s1345mmtsq**(-1)*s15mmtsq**(-1) )
      T21x34(h1,h2,h3,h4,h5) = T21x34(h1,h2,h3,h4,h5) + s34**(-1)*
     & xn**(-1)*two*mt * (  - spstrng1(e2,p1345,e4C)*spstrng1(e3,e5,e1C
     &    )*s1345mmtsq**(-1)*s15mmtsq**(-1) )
      T21x34(h1,h2,h3,h4,h5) = T21x34(h1,h2,h3,h4,h5) + s34**(-1)*
     & xn**(-1)*two*mt**2 * ( spstrng0(e2,e3C)*spstrng1(e4,e5,e1C)*
     &    s234mmtsq**(-1)*s2345mmtsq**(-1) + spstrng0(e2,e3C)*spstrng1(
     &    e4,e5,e1C)*s234mmtsq**(-1)*s15mmtsq**(-1) + spstrng0(e2,e3C)*
     &    spstrng1(e4,e5,e1C)*s1345mmtsq**(-1)*s15mmtsq**(-1) +
     &    spstrng0(e2,e4C)*spstrng1(e3,e5,e1C)*s234mmtsq**(-1)*
     &    s2345mmtsq**(-1) + spstrng0(e2,e4C)*spstrng1(e3,e5,e1C)*
     &    s234mmtsq**(-1)*s15mmtsq**(-1) + spstrng0(e2,e4C)*spstrng1(e3
     &    ,e5,e1C)*s1345mmtsq**(-1)*s15mmtsq**(-1) + spstrng0(e3,e1C)*
     &    spstrng1(e2,e5,e4C)*s134mmtsq**(-1)*s1345mmtsq**(-1) +
     &    spstrng0(e3,e1C)*spstrng1(e2,e5,e4C)*s134mmtsq**(-1)*
     &    s25mmtsq**(-1) + spstrng0(e3,e1C)*spstrng1(e2,e5,e4C)*
     &    s2345mmtsq**(-1)*s25mmtsq**(-1) + spstrng0(e4,e1C)*spstrng1(
     &    e2,e5,e3C)*s134mmtsq**(-1)*s1345mmtsq**(-1) + spstrng0(e4,e1C
     &    )*spstrng1(e2,e5,e3C)*s134mmtsq**(-1)*s25mmtsq**(-1) +
     &    spstrng0(e4,e1C)*spstrng1(e2,e5,e3C)*s2345mmtsq**(-1)*
     &    s25mmtsq**(-1) )

      T24x31(h1,h2,h3,h4,h5)= + s34**(-1)*two*s345**(-1) * ( cdot(e5,
     &    p34)*spstrng0(e2,e3C)*spstrng1(e4,p2345,e1C)*s2345mmtsq**(-1)
     &     + cdot(e5,p34)*spstrng0(e2,e4C)*spstrng1(e3,p2345,e1C)*
     &    s2345mmtsq**(-1) - cdot(e5,p34)*spstrng0(e3,e1C)*spstrng1(e2,
     &    p1345,e4C)*s1345mmtsq**(-1) - cdot(e5,p34)*spstrng0(e4,e1C)*
     &    spstrng1(e2,p1345,e3C)*s1345mmtsq**(-1) + cdot(e5,p345)*
     &    spstrng0(e2,e3C)*spstrng1(e4,p2345,e1C)*s2345mmtsq**(-1) +
     &    cdot(e5,p345)*spstrng0(e2,e4C)*spstrng1(e3,p2345,e1C)*
     &    s2345mmtsq**(-1) - cdot(e5,p345)*spstrng0(e3,e1C)*spstrng1(e2
     &    ,p1345,e4C)*s1345mmtsq**(-1) - cdot(e5,p345)*spstrng0(e4,e1C)
     &    *spstrng1(e2,p1345,e3C)*s1345mmtsq**(-1) - spstrng1(e3,e5,e4C
     &    )*spstrng2(e2,p34,p2345,e1C)*s2345mmtsq**(-1) + spstrng1(e3,
     &    e5,e4C)*spstrng2(e2,p1345,p34,e1C)*s1345mmtsq**(-1) + 1.D0/2.D
     &    0*spstrng1(e3,p34,e4C)*spstrng2(e2,e5,p2345,e1C)*
     &    s2345mmtsq**(-1) - 1.D0/2.D0*spstrng1(e3,p34,e4C)*spstrng2(e2
     &    ,p1345,e5,e1C)*s1345mmtsq**(-1) )
      T24x31(h1,h2,h3,h4,h5) = T24x31(h1,h2,h3,h4,h5) + s34**(-1)*two*
     & s345**(-1) * (  - spstrng1(e3,p345,e4C)*spstrng2(e2,e5,p2345,e1C
     &    )*s2345mmtsq**(-1) + spstrng1(e3,p345,e4C)*spstrng2(e2,p1345,
     &    e5,e1C)*s1345mmtsq**(-1) )
      T24x31(h1,h2,h3,h4,h5) = T24x31(h1,h2,h3,h4,h5) + s34**(-1)*two
     &  * ( spstrng0(e3,e1C)*spstrng3(e2,e5,p25,p134,e4C)*
     &    s134mmtsq**(-1)*s25mmtsq**(-1) - spstrng0(e3,e1C)*spstrng3(e2
     &    ,p1345,e5,p134,e4C)*s134mmtsq**(-1)*s1345mmtsq**(-1) +
     &    spstrng0(e4,e1C)*spstrng3(e2,e5,p25,p134,e3C)*s134mmtsq**(-1)
     &    *s25mmtsq**(-1) - spstrng0(e4,e1C)*spstrng3(e2,p1345,e5,p134,
     &    e3C)*s134mmtsq**(-1)*s1345mmtsq**(-1) - spstrng1(e3,p2345,e1C
     &    )*spstrng2(e2,e5,p25,e4C)*s2345mmtsq**(-1)*s25mmtsq**(-1) -
     &    spstrng1(e4,p2345,e1C)*spstrng2(e2,e5,p25,e3C)*
     &    s2345mmtsq**(-1)*s25mmtsq**(-1) )
      T24x31(h1,h2,h3,h4,h5) = T24x31(h1,h2,h3,h4,h5) + s34**(-1)*two*
     & mt*s345**(-1) * ( cdot(e5,p34)*spstrng0(e2,e3C)*spstrng0(e4,e1C)
     &    *s1345mmtsq**(-1) + cdot(e5,p34)*spstrng0(e2,e3C)*spstrng0(e4
     &    ,e1C)*s2345mmtsq**(-1) + cdot(e5,p34)*spstrng0(e2,e4C)*
     &    spstrng0(e3,e1C)*s1345mmtsq**(-1) + cdot(e5,p34)*spstrng0(e2,
     &    e4C)*spstrng0(e3,e1C)*s2345mmtsq**(-1) + cdot(e5,p345)*
     &    spstrng0(e2,e3C)*spstrng0(e4,e1C)*s1345mmtsq**(-1) + cdot(e5,
     &    p345)*spstrng0(e2,e3C)*spstrng0(e4,e1C)*s2345mmtsq**(-1) +
     &    cdot(e5,p345)*spstrng0(e2,e4C)*spstrng0(e3,e1C)*
     &    s1345mmtsq**(-1) + cdot(e5,p345)*spstrng0(e2,e4C)*spstrng0(e3
     &    ,e1C)*s2345mmtsq**(-1) + 1.D0/2.D0*spstrng1(e2,e5,e1C)*
     &    spstrng1(e3,p34,e4C)*s1345mmtsq**(-1) + 1.D0/2.D0*spstrng1(e2
     &    ,e5,e1C)*spstrng1(e3,p34,e4C)*s2345mmtsq**(-1) - spstrng1(e2,
     &    e5,e1C)*spstrng1(e3,p345,e4C)*s1345mmtsq**(-1) - spstrng1(e2,
     &    e5,e1C)*spstrng1(e3,p345,e4C)*s2345mmtsq**(-1) - spstrng1(e2,
     &    p34,e1C)*spstrng1(e3,e5,e4C)*s1345mmtsq**(-1) )
      T24x31(h1,h2,h3,h4,h5) = T24x31(h1,h2,h3,h4,h5) + s34**(-1)*two*
     & mt*s345**(-1) * (  - spstrng1(e2,p34,e1C)*spstrng1(e3,e5,e4C)*
     &    s2345mmtsq**(-1) )
      T24x31(h1,h2,h3,h4,h5) = T24x31(h1,h2,h3,h4,h5) + s34**(-1)*two*
     & mt * (  - spstrng0(e3,e1C)*spstrng2(e2,e5,p25,e4C)*
     &    s134mmtsq**(-1)*s25mmtsq**(-1) - spstrng0(e3,e1C)*spstrng2(e2
     &    ,e5,p25,e4C)*s2345mmtsq**(-1)*s25mmtsq**(-1) + spstrng0(e3,
     &    e1C)*spstrng2(e2,e5,p134,e4C)*s134mmtsq**(-1)*
     &    s1345mmtsq**(-1) + spstrng0(e3,e1C)*spstrng2(e2,e5,p134,e4C)*
     &    s134mmtsq**(-1)*s25mmtsq**(-1) + spstrng0(e3,e1C)*spstrng2(e2
     &    ,p1345,e5,e4C)*s134mmtsq**(-1)*s1345mmtsq**(-1) - spstrng0(e4
     &    ,e1C)*spstrng2(e2,e5,p25,e3C)*s134mmtsq**(-1)*s25mmtsq**(-1)
     &     - spstrng0(e4,e1C)*spstrng2(e2,e5,p25,e3C)*s2345mmtsq**(-1)*
     &    s25mmtsq**(-1) + spstrng0(e4,e1C)*spstrng2(e2,e5,p134,e3C)*
     &    s134mmtsq**(-1)*s1345mmtsq**(-1) + spstrng0(e4,e1C)*spstrng2(
     &    e2,e5,p134,e3C)*s134mmtsq**(-1)*s25mmtsq**(-1) + spstrng0(e4,
     &    e1C)*spstrng2(e2,p1345,e5,e3C)*s134mmtsq**(-1)*
     &    s1345mmtsq**(-1) - spstrng1(e2,e5,e3C)*spstrng1(e4,p2345,e1C)
     &    *s2345mmtsq**(-1)*s25mmtsq**(-1) )
      T24x31(h1,h2,h3,h4,h5) = T24x31(h1,h2,h3,h4,h5) + s34**(-1)*two*
     & mt * (  - spstrng1(e2,e5,e4C)*spstrng1(e3,p2345,e1C)*
     &    s2345mmtsq**(-1)*s25mmtsq**(-1) )
      T24x31(h1,h2,h3,h4,h5) = T24x31(h1,h2,h3,h4,h5) + s34**(-1)*two*
     & mt**2 * (  - spstrng0(e3,e1C)*spstrng1(e2,e5,e4C)*
     &    s134mmtsq**(-1)*s1345mmtsq**(-1) - spstrng0(e3,e1C)*spstrng1(
     &    e2,e5,e4C)*s134mmtsq**(-1)*s25mmtsq**(-1) - spstrng0(e3,e1C)*
     &    spstrng1(e2,e5,e4C)*s2345mmtsq**(-1)*s25mmtsq**(-1) -
     &    spstrng0(e4,e1C)*spstrng1(e2,e5,e3C)*s134mmtsq**(-1)*
     &    s1345mmtsq**(-1) - spstrng0(e4,e1C)*spstrng1(e2,e5,e3C)*
     &    s134mmtsq**(-1)*s25mmtsq**(-1) - spstrng0(e4,e1C)*spstrng1(e2
     &    ,e5,e3C)*s2345mmtsq**(-1)*s25mmtsq**(-1) )
      T24x31(h1,h2,h3,h4,h5) = T24x31(h1,h2,h3,h4,h5) + two*s345**(-1)
     &  * ( spstrng0(e2,e3C)*spstrng3(e4,e5,p45,p2345,e1C)*
     &    s2345mmtsq**(-1)*s45**(-1) - spstrng0(e3,e1C)*spstrng3(e2,
     &    p1345,p45,e5,e4C)*s1345mmtsq**(-1)*s45**(-1) - spstrng1(e2,
     &    p1345,e3C)*spstrng2(e4,e5,p45,e1C)*s1345mmtsq**(-1)*s45**(-1)
     &     + spstrng1(e3,p2345,e1C)*spstrng2(e2,p45,e5,e4C)*
     &    s2345mmtsq**(-1)*s45**(-1) )
      T24x31(h1,h2,h3,h4,h5) = T24x31(h1,h2,h3,h4,h5) + two*mt*
     & s345**(-1) * ( spstrng0(e2,e3C)*spstrng2(e4,e5,p45,e1C)*
     &    s1345mmtsq**(-1)*s45**(-1) + spstrng0(e2,e3C)*spstrng2(e4,e5,
     &    p45,e1C)*s2345mmtsq**(-1)*s45**(-1) + spstrng0(e3,e1C)*
     &    spstrng2(e2,p45,e5,e4C)*s1345mmtsq**(-1)*s45**(-1) +
     &    spstrng0(e3,e1C)*spstrng2(e2,p45,e5,e4C)*s2345mmtsq**(-1)*
     &    s45**(-1) )

      T31x24(h1,h2,h3,h4,h5)= + s34**(-1)*two*s345**(-1) * (  - cdot(e5
     &    ,p34)*spstrng0(e2,e3C)*spstrng1(e4,p2345,e1C)*
     &    s2345mmtsq**(-1) - cdot(e5,p34)*spstrng0(e2,e4C)*spstrng1(e3,
     &    p2345,e1C)*s2345mmtsq**(-1) + cdot(e5,p34)*spstrng0(e3,e1C)*
     &    spstrng1(e2,p1345,e4C)*s1345mmtsq**(-1) + cdot(e5,p34)*
     &    spstrng0(e4,e1C)*spstrng1(e2,p1345,e3C)*s1345mmtsq**(-1) -
     &    cdot(e5,p345)*spstrng0(e2,e3C)*spstrng1(e4,p2345,e1C)*
     &    s2345mmtsq**(-1) - cdot(e5,p345)*spstrng0(e2,e4C)*spstrng1(e3
     &    ,p2345,e1C)*s2345mmtsq**(-1) + cdot(e5,p345)*spstrng0(e3,e1C)
     &    *spstrng1(e2,p1345,e4C)*s1345mmtsq**(-1) + cdot(e5,p345)*
     &    spstrng0(e4,e1C)*spstrng1(e2,p1345,e3C)*s1345mmtsq**(-1) +
     &    spstrng1(e3,e5,e4C)*spstrng2(e2,p34,p2345,e1C)*
     &    s2345mmtsq**(-1) - spstrng1(e3,e5,e4C)*spstrng2(e2,p1345,p34,
     &    e1C)*s1345mmtsq**(-1) - 1.D0/2.D0*spstrng1(e3,p34,e4C)*
     &    spstrng2(e2,e5,p2345,e1C)*s2345mmtsq**(-1) + 1.D0/2.D0*
     &    spstrng1(e3,p34,e4C)*spstrng2(e2,p1345,e5,e1C)*
     &    s1345mmtsq**(-1) )
      T31x24(h1,h2,h3,h4,h5) = T31x24(h1,h2,h3,h4,h5) + s34**(-1)*two*
     & s345**(-1) * ( spstrng1(e3,p345,e4C)*spstrng2(e2,e5,p2345,e1C)*
     &    s2345mmtsq**(-1) - spstrng1(e3,p345,e4C)*spstrng2(e2,p1345,e5
     &    ,e1C)*s1345mmtsq**(-1) )
      T31x24(h1,h2,h3,h4,h5) = T31x24(h1,h2,h3,h4,h5) + s34**(-1)*two
     &  * (  - spstrng0(e2,e3C)*spstrng3(e4,p234,e5,p2345,e1C)*
     &    s234mmtsq**(-1)*s2345mmtsq**(-1) + spstrng0(e2,e3C)*spstrng3(
     &    e4,p234,p15,e5,e1C)*s234mmtsq**(-1)*s15mmtsq**(-1) -
     &    spstrng0(e2,e4C)*spstrng3(e3,p234,e5,p2345,e1C)*
     &    s234mmtsq**(-1)*s2345mmtsq**(-1) + spstrng0(e2,e4C)*spstrng3(
     &    e3,p234,p15,e5,e1C)*s234mmtsq**(-1)*s15mmtsq**(-1) -
     &    spstrng1(e2,p1345,e3C)*spstrng2(e4,p15,e5,e1C)*
     &    s1345mmtsq**(-1)*s15mmtsq**(-1) - spstrng1(e2,p1345,e4C)*
     &    spstrng2(e3,p15,e5,e1C)*s1345mmtsq**(-1)*s15mmtsq**(-1) )
      T31x24(h1,h2,h3,h4,h5) = T31x24(h1,h2,h3,h4,h5) + s34**(-1)*two*
     & mt*s345**(-1) * (  - cdot(e5,p34)*spstrng0(e2,e3C)*spstrng0(e4,
     &    e1C)*s1345mmtsq**(-1) - cdot(e5,p34)*spstrng0(e2,e3C)*
     &    spstrng0(e4,e1C)*s2345mmtsq**(-1) - cdot(e5,p34)*spstrng0(e2,
     &    e4C)*spstrng0(e3,e1C)*s1345mmtsq**(-1) - cdot(e5,p34)*
     &    spstrng0(e2,e4C)*spstrng0(e3,e1C)*s2345mmtsq**(-1) - cdot(e5,
     &    p345)*spstrng0(e2,e3C)*spstrng0(e4,e1C)*s1345mmtsq**(-1) -
     &    cdot(e5,p345)*spstrng0(e2,e3C)*spstrng0(e4,e1C)*
     &    s2345mmtsq**(-1) - cdot(e5,p345)*spstrng0(e2,e4C)*spstrng0(e3
     &    ,e1C)*s1345mmtsq**(-1) - cdot(e5,p345)*spstrng0(e2,e4C)*
     &    spstrng0(e3,e1C)*s2345mmtsq**(-1) - 1.D0/2.D0*spstrng1(e2,e5,
     &    e1C)*spstrng1(e3,p34,e4C)*s1345mmtsq**(-1) - 1.D0/2.D0*
     &    spstrng1(e2,e5,e1C)*spstrng1(e3,p34,e4C)*s2345mmtsq**(-1) +
     &    spstrng1(e2,e5,e1C)*spstrng1(e3,p345,e4C)*s1345mmtsq**(-1) +
     &    spstrng1(e2,e5,e1C)*spstrng1(e3,p345,e4C)*s2345mmtsq**(-1) +
     &    spstrng1(e2,p34,e1C)*spstrng1(e3,e5,e4C)*s1345mmtsq**(-1) )
      T31x24(h1,h2,h3,h4,h5) = T31x24(h1,h2,h3,h4,h5) + s34**(-1)*two*
     & mt*s345**(-1) * ( spstrng1(e2,p34,e1C)*spstrng1(e3,e5,e4C)*
     &    s2345mmtsq**(-1) )
      T31x24(h1,h2,h3,h4,h5) = T31x24(h1,h2,h3,h4,h5) + s34**(-1)*two*
     & mt * (  - spstrng0(e2,e3C)*spstrng2(e4,e5,p2345,e1C)*
     &    s234mmtsq**(-1)*s2345mmtsq**(-1) + spstrng0(e2,e3C)*spstrng2(
     &    e4,p15,e5,e1C)*s234mmtsq**(-1)*s15mmtsq**(-1) + spstrng0(e2,
     &    e3C)*spstrng2(e4,p15,e5,e1C)*s1345mmtsq**(-1)*s15mmtsq**(-1)
     &     - spstrng0(e2,e3C)*spstrng2(e4,p234,e5,e1C)*s234mmtsq**(-1)*
     &    s2345mmtsq**(-1) - spstrng0(e2,e3C)*spstrng2(e4,p234,e5,e1C)*
     &    s234mmtsq**(-1)*s15mmtsq**(-1) - spstrng0(e2,e4C)*spstrng2(e3
     &    ,e5,p2345,e1C)*s234mmtsq**(-1)*s2345mmtsq**(-1) + spstrng0(e2
     &    ,e4C)*spstrng2(e3,p15,e5,e1C)*s234mmtsq**(-1)*s15mmtsq**(-1)
     &     + spstrng0(e2,e4C)*spstrng2(e3,p15,e5,e1C)*s1345mmtsq**(-1)*
     &    s15mmtsq**(-1) - spstrng0(e2,e4C)*spstrng2(e3,p234,e5,e1C)*
     &    s234mmtsq**(-1)*s2345mmtsq**(-1) - spstrng0(e2,e4C)*spstrng2(
     &    e3,p234,e5,e1C)*s234mmtsq**(-1)*s15mmtsq**(-1) + spstrng1(e2,
     &    p1345,e3C)*spstrng1(e4,e5,e1C)*s1345mmtsq**(-1)*
     &    s15mmtsq**(-1) )
      T31x24(h1,h2,h3,h4,h5) = T31x24(h1,h2,h3,h4,h5) + s34**(-1)*two*
     & mt * ( spstrng1(e2,p1345,e4C)*spstrng1(e3,e5,e1C)*
     &    s1345mmtsq**(-1)*s15mmtsq**(-1) )
      T31x24(h1,h2,h3,h4,h5) = T31x24(h1,h2,h3,h4,h5) + s34**(-1)*two*
     & mt**2 * (  - spstrng0(e2,e3C)*spstrng1(e4,e5,e1C)*
     &    s234mmtsq**(-1)*s2345mmtsq**(-1) - spstrng0(e2,e3C)*spstrng1(
     &    e4,e5,e1C)*s234mmtsq**(-1)*s15mmtsq**(-1) - spstrng0(e2,e3C)*
     &    spstrng1(e4,e5,e1C)*s1345mmtsq**(-1)*s15mmtsq**(-1) -
     &    spstrng0(e2,e4C)*spstrng1(e3,e5,e1C)*s234mmtsq**(-1)*
     &    s2345mmtsq**(-1) - spstrng0(e2,e4C)*spstrng1(e3,e5,e1C)*
     &    s234mmtsq**(-1)*s15mmtsq**(-1) - spstrng0(e2,e4C)*spstrng1(e3
     &    ,e5,e1C)*s1345mmtsq**(-1)*s15mmtsq**(-1) )
      T31x24(h1,h2,h3,h4,h5) = T31x24(h1,h2,h3,h4,h5) + two*s345**(-1)
     &  * (  - spstrng0(e2,e4C)*spstrng3(e3,e5,p35,p2345,e1C)*
     &    s2345mmtsq**(-1)*s35**(-1) + spstrng0(e4,e1C)*spstrng3(e2,
     &    p1345,p35,e5,e3C)*s1345mmtsq**(-1)*s35**(-1) + spstrng1(e2,
     &    p1345,e4C)*spstrng2(e3,e5,p35,e1C)*s1345mmtsq**(-1)*s35**(-1)
     &     - spstrng1(e4,p2345,e1C)*spstrng2(e2,p35,e5,e3C)*
     &    s2345mmtsq**(-1)*s35**(-1) )
      T31x24(h1,h2,h3,h4,h5) = T31x24(h1,h2,h3,h4,h5) + two*mt*
     & s345**(-1) * (  - spstrng0(e2,e4C)*spstrng2(e3,e5,p35,e1C)*
     &    s1345mmtsq**(-1)*s35**(-1) - spstrng0(e2,e4C)*spstrng2(e3,e5,
     &    p35,e1C)*s2345mmtsq**(-1)*s35**(-1) - spstrng0(e4,e1C)*
     &    spstrng2(e2,p35,e5,e3C)*s1345mmtsq**(-1)*s35**(-1) -
     &    spstrng0(e4,e1C)*spstrng2(e2,p35,e5,e3C)*s2345mmtsq**(-1)*
     &    s35**(-1) )

      enddo
      enddo
      enddo
      enddo
      ampsq=0d0
      do h1=1,2
      do h2=1,2
      do h3=1,2
      h4=3-h3
      do h5=1,2
      m(1)=T34x21(h1,h2,h3,h4,h5)
      m(2)=T21x34(h1,h2,h3,h4,h5)
      m(3)=T24x31(h1,h2,h3,h4,h5)
      m(4)=T31x24(h1,h2,h3,h4,h5)
C     Factor of V removed from color sum
      ampsq=ampsq+xn*dble(
     & +m(1)*Dconjg(m(1))+m(2)*Dconjg(m(2))
     & +m(3)*Dconjg(m(3))+m(4)*Dconjg(m(4)))
     & +dble((m(1)+m(2))*Dconjg(m(3)+m(4))
     &      +(m(3)+m(4))*Dconjg(m(1)+m(2)))
      enddo
      enddo
      enddo
      enddo
      return
      end

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text:
module dynarray_string_mod
implicit none

type dynarray_string
	integer :: capacity, length
	character(len=14), allocatable :: store(:)
contains
	procedure :: initialize
	procedure :: append
	procedure :: last
	procedure :: print
	procedure :: write
	procedure :: read
end type dynarray_string

private :: initialize, append, last, print, write, read

contains

subroutine initialize(a)
	class(dynarray_string) :: a

	a%length = 0
	a%capacity = 128
	allocate(character(14) :: a%store(a%capacity))
end subroutine initialize

subroutine append(a, val)
	class(dynarray_string) :: a
	character(len=*), intent(in) :: val

	character(len=:), allocatable :: buf(:)

	if (a%length == a%capacity) then
		call move_alloc(a%store, buf)
		a%capacity = a%capacity * 2
		allocate(character(14) :: a%store(a%capacity))
		a%store(1:a%length) = buf
		deallocate(buf)
	end if
	a%length = a%length + 1
	a%store(a%length) = val
end subroutine append

function last(a) result(out)
	class(dynarray_string) :: a
	character(len=:), allocatable :: out

	out = a%store(a%length)
end function last

subroutine print(a)
	class(dynarray_string) :: a

	integer :: i

	do i = 1, a%length
		print *, a%store(i)
	end do
	print *, ''
end subroutine print

subroutine write(a)
	class(dynarray_string) :: a

	write(10) a%length
	write(10) a%store(:a%length)
end subroutine write

subroutine read(a)
	class(dynarray_string) :: a

	read(10) a%length
	a%capacity = a%length
	allocate(character(14) :: a%store(a%capacity))
	read(10) a%store
end subroutine read

end module dynarray_string_mod

max_stars_repo_name: vkitchen/fortsearch

max_issues_repo_name: vkitchen/fortsearch

max_forks_repo_name: vkitchen/fortsearch


text:
! { dg-do run }
! PR 18958:  We used to segfault for eoshifting off the end of an array.
program main
  character(len=20) line
  write (line,'(2I4)') eoshift((/1, 3/), 3)
end program main

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
      real*4 function interp(ix, iy, xfrac, yfrac, rvs, iac, ioff)

c      integer*4 CMAX
c      parameter (CMAX = 7000)
      integer*4 ix, iy, n, first, iac, ioff
      real*8 xfrac, yfrac
      !real*4 rvs(0:2*iac-1,*)
      !the upper defination makes the index of the second dimension (row) start with 1
      !I change it as follows, as both dimensions require index starting with 0
      !1-JUN-2015, Cunren Liang
      real*4 rvs(0:2*iac-1,0:100000000)

      complex temp(8)
      real*4 xintp(0:65544)
      data first/1/
      save xintp, first

c*    we want to do a 8192 x (8-pt sinc) interpolation of the original data, choosing
c*    the resulting nearest neighbor.

      if(first .eq. 1) then
         call intp_coef_norm(8192,xintp)
         first = 0
      end if
      n = 0

      ifrac = 8 * nint(xfrac * 8192.)
c      write (*,*)  '1 ',frac,ifrac
      do i = iy - 3 , iy + 4
         n = n + 1
         temp(n) = cmplx(0.0,0.0)
         do k = -3 , 4
            temp(n) = temp(n)  + rvs(ix+k+ioff,i) * xintp(ifrac+k+3)
         end do
      enddo

      ifrac = 8 * nint(yfrac * 8192.)
c      write (*,*)  '2 ', frac,ifrac
      cinterp = cmplx(0.,0.)
      do k = -3 , 4
         cinterp = cinterp + temp(k+4) * xintp(ifrac+k+3)
      end do
      interp = real(cinterp)
      return
      end


! Copyright 2019 Khang Hoang Nguyen
!
! Permission is hereby granted, free of charge, to any person obtaining
! a copy of this software and associated documentation files
! (the "Software"), to deal in the Software without restriction,
! including without limitation the rights to use, copy, modify, merge,
! publish, distribute, sublicense, and/or sell copies of the Software,
! and to permit persons to whom the Software is furnished to do so,
! subject to the following conditions
!
! The above copyright notice and this permission notice shall be
! included in all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
! NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
! BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
! ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!| author: Khang Hoang Nguyen
!  license: MIT
!  since: 1n.0.0.f
!
!
This module, fnConsts64 contains constant values for
!  modules that deal with 64-bit ints.
!

module fnConsts64
    implicit none
    integer         , parameter  ::  k_int64 = selected_int_kind(18)    !! An integer value for int64's kind.

    integer(k_int64), parameter  ::  czero64 = 48_k_int64               !! An int64 value of the character '0'.
    integer(k_int64), parameter  ::  cneg64 = 45_k_int64                !! An int64 value of the character '-'.
    integer(k_int64), parameter  ::  cpos64 = 43_k_int64                !! An int64 value of the character '+'.
    integer(k_int64), parameter  ::  cspace64 = 32_k_int64              !! An int64 value of space.
end module fnConsts64


text:
module data_wrangler
  use cvode_parameters, only: cv_data

  implicit none

contains

  subroutine store_solution(ysol, net_history, k, t)
    double precision, dimension(:), intent(in)   :: ysol
    double precision, dimension(:,:), intent(inout) :: net_history
    integer, intent(in) :: k
    double precision, intent(in) :: t
    integer :: i

    do i = 1, cv_data%NEQ
       net_history(i, k) = ysol(i)
    end do
    net_history(cv_data%NEQ+1, k) = t
  end subroutine store_solution

  subroutine write_solution(net_history, KFIN)
    double precision, dimension(:,:), intent(in) :: net_history
    integer, intent(in) :: KFIN
    integer :: K, J, NPROFILE

    ! Output Profile Misc
    character(len=50) :: rfmt
    character(len=50) :: hfmt
    character(len=*), parameter  :: profile_file_name = 'net_history.dat'

    NPROFILE = cv_data%NEQ + 1
    write(*,*) 'NPROFILE: ', NPROFILE
    write(*,*) 'size(net_history, 1): ', size(net_history,1)
    write(*,*) 'size(net_history, 2): ', size(net_history,2)
    !! Save profile to file
    ! Set format for writing column entries
    write(hfmt,'(A,I5,A)') '(', NPROFILE, '(A18))'
    write(rfmt,'(A,I5,A)') '(', NPROFILE, '(ES25.14))'
    open(unit=2, file=profile_file_name, recl=(25*NPROFILE+10), form='formatted')
    write(2, fmt=hfmt) 'Y_he4', 'Y_c12', 'E_nuc', 'Time'
    do K = 1, KFIN
       write(2, fmt=rfmt) (net_history(J, K), J=1, NPROFILE)
    end do
    close(unit=2)
  end subroutine write_solution

end module data_wrangler

max_stars_repo_name: jennranta/pyreaclib

max_issues_repo_name: jennranta/pyreaclib

max_forks_repo_name: jennranta/pyreaclib


text:
The Davis Feminist Film Festival, sponsored by the Consortium for Women and Research, is a grassroots event that uses alternative media as a springboard for linking art to social issues. The goal of the film festivals film festival is to showcase independent film spanning documentary, narrative, and experimental genres in order to explore perspectives often missing from mainstream media and culture. Now in its seventh year and increasingly international in scope, the festival provides an inclusive public space for underrepresented artists—particularly women and people of color—to raise consciousness about gender, race, class, sexuality, and other dimensions of social inequality. It is a fun, inspiring, communitybuilding event for artists and audiences alike!

The Thursday and Friday night receptions, have food for sale from Monticello and beer from Sierra Nevada and Berryessa Brewing; the films begin at 6:30 PM. The Solar Community Housing Association (SCHA) is making possible the sale of beer, the profits from which will be used to save the Baggins End Cooperative Community (aka the Domes).
One of the oldest student housing cooperatives in the United States, Baggins End is now in danger of being eliminated; the money raised at the festival will help with the necessary physical and structural repairs needed to save it.

 Past events 2013 Film Descriptions

 Thursday night, April 11
PLEASE BE ADVISED: The films are not rated. Some contain material that may not be appropriate for viewers of all ages.

Sólo sé que no sé nada / All I know is that I know nothing (14 min)
Olatz Arroyo, Spain
Sofia is in a rut, but her life changes radically when she discovers her son’s philosophy textbook. She finds Socrates and Sartre inspiring, but Rousseau is another matter. Luckily, she has ideas of her own. A wellcrafted, humorous narrative about marriage, friendship, and revenge.

Mamuu / To weave, to work (22 min)
Denise Nicole Green, Canada
This collection of personal vignettes brings to light the subtle yet powerful contributions that weaving makes to individuals, families, and the broader politicaleconomy of First Nations communities. An ongoing history of colonialism and inequality in the Pacific Northwest is the backdrop to a story of women’s creative perseverance and their everyday emphasis on intergenerational knowledge exchange.

Perfect Girl (4 min)
Pia Tjäder, Sweden
What does femininity look like? A baby girl explores the world around her, naïve to the media images that will shape her selfesteem as she grows up: smooth skin, flawless features, slender bodies. The baby doesn’t care, but the mother is more affected, examining her own body with apparent dissatisfaction. Images outside the commercial media reveal little girls who are strong, happy, shy, angry—all perfect just the way they are.

More Than a Face in the Crowd (25 min)
Samantha Chan, USA
More Than a Face in the Crowd tells the story of the filmmaker’s great aunt, Jane Chung, who began acting in Hollywood during the first wave of AsianAmerican actors. Enduring considerable racism and opposition, early pioneers like Chung established themselves in the entertainment business yet were rarely recognized for their work. Personal archives, interviews with family, and clips from Chung’s many film and television appearances paint an intimate portrait of the woman behind the career.

(A)typical Couple (6 min)
Maša Zia Lenárdič and Anja Wutej, Slovenia
Tired of negative stereotypes of lesbians as boring and humorless or psychotic and predatory? This charming, quirky film is just the antidote, offering us a slice of life we can all relate to. To quote one reviewer, “Yay! Lesbian couple! Super cute!”

The Rest of Us (2 min, 30 sec)
Maddi Davis, Alyssa Piraino, and Danny Tayara, USA
Labels. Categories. Boxes. Bathrooms. What if you don’t belong? Why should we have to choose? This clever film troubles the gender binary, offering a creative solution to the “bathroom problem.”

   INTERMISSION

Welcome and introductions

Plaza de Cocos (3 min)
Julio López Fernández, Mexico/El Salvador
Next to a Salvadoran road, two young girls hawk coconuts to driveby customers indifferent to their sense of urgency. The girls can illafford to be turned down, as we learn. An oblique commentary on gender, poverty, and survival.

America’s Most Unwanted (23 min)
Shani Heckman, USA
Onehalf of all fosters are homeless, onethird are on welfare, and onethird enter prison within two years of leaving foster care. America’s Most Unwanted is a candid documentary about three queer youth and their experiences of homophobia, homelessness, and educational marginalization in the fostercare system. A former foster herself, filmmaker Shani Heckman paints a poignant yet unsentimental portrait of a largely invisible population.

Silent Voices (4 min, 30 sec)
Jeeyoon Na, USA
This animated short was inspired by the sexist commentary that followed a Korean news report in which two teenage girls were reported gangraped. Instead of expressing sympathy, readers blamed the girls for provoking the attack. Silent Voices translates the feelings of shame and despair that victimblaming generates, as the young girl in the film gradually loses her voice and her confidence amidst the judgments of others.

There’s No Hole in My Head (14 min)
Alison Segar, UK/USA
At age 54, Abby Hale was diagnosed with earlyonset Alzheimer’s. A mother, loving partner, and former medical practitioner, Abby shares with eloquence and grace what she has gained and lost as a result of this cruel disease. There’s No Hole in My Head affords us insight into a condition that, although increasingly common, is rarely discussed in such an honest and open way.

Anamnesis (4 min)
Cat Xia, Canada/USA
Memory is fragile and can make us question reality. Its loss generates fear and insecurity. Being seen as “crazy” is especially fraught for women of color, whose capacity may be suspect even under “normal” circumstances. Anamnesis is a stopmotion short about the filmmaker’s personal experience with memory loss and its potential effect on her life. Serious and playful at the same time, it asks us to reconsider what it’s like to forget.

Perfect Plastic (13 min)
Meredith Sward, USA
The female body is a canvas for comparison and modification, with the media playing a key role in shaping notions of beauty and attractiveness.  Narrow images of female beauty increase dissatisfaction with “real” bodies and lead women to seek transformation through plastic surgery. Drawing on media footage, personal introspection, and interviews with surgeons, psychologists, and academics, Perfect Plastic casts a critical eye on current beauty ideals and the industries that profit from them.
WARNING: THIS FILM CONTAINS GRAPHIC FOOTAGE OF PLASTIC SURGERIES, INCLUDING BREAST AUGMENTATION AND LABIAPLASTY

Present Gender (8 min
Christine Yeakley and Lane Lewis, USA
Present Gender explores gender identity and gender expression through interviews and visual representation. Womyn and queer/trans youth discuss their experiences and challenges with being “read” by others and asserting their own identities and desires in the face of negativity or incomprehension. Made by and about local Davisites!

Q & A with participating filmmakers immediately following.
 Friday night, April 12

PLEASE BE ADVISED: The films are not rated. Some contain material that may not be appropriate for viewers of all ages.

And You Are …? (19 min)
Jeanette Rourke and Margaret Dane / Wayward Women Films, UK
When the mind is ravaged by disease, a repository of memories and snapshots becomes the touchstone for who we think we are. In this experimental short, “The Face” (played by Rourke) leads us on an emotional journey that traces the arc of one woman’s life. Sincere and beautifully acted, And You Are …? takes a personal approach to the universal themes of loss and degeneration.

Like a Dream (9 min)
Pia Tjäder, Sweden
Johnny and his sister Leia are playing in a seemingly nice, middleclass bedroom in a seemingly nice, middleclass home. But when Leia gets hungry and starts for the kitchen, Johnny distracts her by telling her a story about an enchanted forest. Gradually we understand that the two children use fairytales and fantasy to keep a tragic reality at bay. A lyrical, sensitive film with stellar performances from the children.

Out of Step (6 min)
Lynn Estomin, USA
Out of Step features the perspectives of four women veterans of the wars in Iraq and Afghanistan. Voiceover by the women themselves accompanies dance and musical interpretations of their emotional journey from idealistic recruits to veterans coping with PTSD. The film deals with global issues of war and peace, the effects of war and military service on women, and the connections felt by the veterans to the people deemed their “enemy.”

Hope (5 min)
Stelana Kliris, Cyprus
To this day, approximately 2000 people are still missing from the 1963 and 1974 conflicts in Cyprus. Hope is the story of the surviving relatives, who, decades later, remain frozen in time, awaiting their loved ones’ return. A true work of art that pays homage to the ravages of war on domestic life.

We Never Returned (27 min)
Astrid Asberger, Sweden
We Never Returned charts the efforts of a theatre project to stage the stories of four Kurdish refugees. Stories that the Migration Board hears everyday. For the Board, it takes “like five minutes” to make decisions about a person’s future. Can theatre make a difference? Can a play raise compassion and empathy? Can art be a healing force for those whose stories are told, or does it simply assuage the guilt of those who are safe and privileged, having never needed to flee their homes? This touching and honest film asks, but does not answer, these questions.

Libre Directo (13 min)
Bernabé Rico, Spain
Having turned 60, Adela is living a life she never wanted. She has a lazy, selfish husband, no children, and nothing to look forward to. Then one day she gets the chance to break free and leave her old life behind. Her challenge: a direct kick from midfield into the open goal at halftime during a professional soccer match attended by thousands of cheering spectators. Undeterred, Adela starts training for the big day. A charming, inspiring film that will have you cheering, too. Superb acting and overthetop production values.

   INTERMISSION

Welcome and introductions

I Am (2 min, 30 sec)
Koe Sozuteki, Cody Young, Schuyler Markey, USA
No one thing defines who we are. Like all people, queeridentified youth are complex and multifaceted. I Am asks us to hold this in mind and honor the diversity of human experience. A short, sweet film with a big message.

FEATURE FILM: Invisible (90 min)
Michal Aviad, Israel/Germany
More than 20 years after Lily and Nira are victimized by the same serial rapist, a chance encounter brings them together. Nira, a singlemother, works as a television editor; Lily is a progressive activist defending Palestinian rights. So affected is Nira by the encounter that she begins digging into the past, stirring up memories, trying to bridge the gap between the person she once was and the person she has become. She grows increasingly preoccupied with uncovering all she can about the rapist. Lily’s marriage is in crisis; she tries to prevent the trauma from resurfacing, but it penetrates every aspect of her life. She realizes she has no choice but to confront the past. What begins as a difficult journey turns into a subtle friendship that moves the two women toward healing and renewal. Leaving humiliation and guilt behind, they stop being invisible. An emotionally powerful and ultimately uplifting film, Invisible mixes fact and fiction, incorporating televised footage and recorded testimonies of real women who, like Lily and Nira, are survivors.

 Media
  http://media.www.californiaaggie.com/media/storage/paper981/news/2005/10/20/Arts/First.Davis.Feminist.Film.Festival.To.Be.Held.Tonight1321409.shtml First Davis Feminist Film Festival to Be Held Tonight: Doublebilled film fest showcases the minorities of media California Aggie October 20, 2005
  http://media.www.californiaaggie.com/media/storage/paper981/news/2007/02/21/ArtsEntertainment/Davis.Feminist.Film.Festival.Premieres.Thursday.Night2732919.shtml Davis Feminist Film Festival Premieres Thursday Night California Aggie February 21, 2007

 2011 Posters

20070906 18:22:29 nbsp greta and danielle are awesome people. im sure everyone else is too. Users/JessicaRockwell

If I go, should I castrate myself first? Just asking...Users/JoshLawson

20110407 08:13:23 nbsp To respond to Joshs comment: In the past twenty years or so, feminism is increasingly paying attention to the fact that men have gender as much as women do, just like white folks have race. This means that a gender analysis informed by feminism can focus on the ways in which masculinity gets constructed and reproduced in the world, not just femininity. To be feminist today means much more than being prowoman, it signals a sensitivity to how both masculinity and femininity work. I think that if you were to attend the Davis Feminist Film Festival you will notice that the films represent this broader notion of what feminism means. Users/Artemis

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search