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

C=======================================================================
*DECK,INTRPE
      SUBROUTINE INTRP3 (CNTRA,CNTRB,IELPT,SOLEB,SOLEA,SOLGRA,IDBLK,
     &                   ITT,iblk,TIMES,ISTP,IST,INSUB,ICOMPL,
     &                   XB,YB,ZB,ICONB,DUME)
C
C     ******************************************************************
C
C     SUBROUTINE TO CONTROL INTERPOLATION OF ELEMENT VARIABLES
C     FROM MESH-A TO MESH-B FOR SCHEME 3, A ELEMENT CENTROID BASED
C     INTERPOLATION SCHEME. PHYSICAL CONSTRAINTS ARE APPLIED TO
C     THE INTERPOLATED RESULTS AND THEN THEY ARE WRITTEN TO MESH-C
C
C     Called by MAPVAR
C
C     ******************************************************************
C
C CNTRA   REAL  Centroidal coords for Mesh-A
C CNTRB   REAL  Centroidal coords for Mesh-B
C IELPT   INT   The element in Mesh-A within which the point
C               (node in Mesh-B) is found
C STRPT   REAL  The isoparametric coords of point in IELPT element
C SOLEB   REAL  Element variables for Mesh-B
C SOLEA   REAL  Element variables for Mesh-A
C SOLGRA  REAL  Gradient in element variables for Mesh-A
C IDBLK   INT   Element block ID for mesh-B
C ITT     INT   Truth table
C IM      INT   Element block being processed (not block ID)
C TIMES   REAL  Array of times - passed thru to PNF
C ISTP    INT   Time step
C IST     INT   Time step if multiple time steps are in use
C INSUB   INT   Entry into subroutine; 1-first time in; >1-second,etc
C ICOMPL  INT   Map completion; 0-incomplete; 1-complete
C
C     ******************************************************************
C
      include 'aexds1.blk'
      include 'aexds2.blk'
      include 'amesh.blk'
      include 'bmesh.blk'
      include 'ebbyeb.blk'
      include 'ex2tp.blk'
      include 'tapes.blk'
C
      DIMENSION CNTRB(NUMEBB,*), CNTRA(NUMEBA,*), IELPT(*)
      DIMENSION SOLEB(NUMEBB,*), SOLEA(NUMEBA,*)
      DIMENSION SOLGRA(NDIMA,NUMEBA,*)
      DIMENSION ITT(NVAREL,*), ICONB(NELNDB,*)
      DIMENSION XX(27), YY(27), ZZ(27), XB(*), YB(*), ZB(*)
      DIMENSION DUME(*)
C
C     ******************************************************************
C
        IROT = 0
        IROTF = 0
        DO 40 IVAR=1,NVAREL
          IF (ITT(IVAR,iblk) .EQ. 0)GO TO 40
C
C Initialize SOLEB if first time in subroutine for this element block
C After first time into subroutine
C retrieve SOLEB from storage in EXODUS
C
        IF (INSUB .EQ. 1) THEN
          CALL INIELT(SOLEB,IVAR,TIMES,ISTP,IDBLK,CENTER,DUME)
        ELSE
          CALL EXGEV(NTP4EX,IST,IVAR,IDBLK,NUMEBB,SOLEB(1,IVAR),IERR)
        END IF
C
C Loop on elements in recipient mesh
C
        DO 30 I=1,NUMEBB
          IF (IELPT(I) .NE. 0)THEN
C
C Distance in cartesian coordinates between mesh-A and mesh-B centroid
C
            XC = CNTRB(I,1) - CNTRA(IELPT(I),1)
            YC = CNTRB(I,2) - CNTRA(IELPT(I),2)
            ZC = 0.
            IF (NDIMB .EQ. 3)ZC = CNTRB(I,3) - CNTRA(IELPT(I),3)
C
C Evaluate interpolation
C
            SOLEB(I,IVAR) = SOLEA(IELPT(I),IVAR)
     &                    + SOLGRA(1,IELPT(I),IVAR) * XC
     &                    + SOLGRA(2,IELPT(I),IVAR) * YC
     &                    + SOLGRA(3,IELPT(I),IVAR) * ZC
          END IF
 30     CONTINUE
C
C If there is more searching to do (i.e. many blocks to one)
C use EXODUS as temporary storage
C don't bother to perform needed adjustments yet
C
        IF (ICOMPL .NE. 1)THEN
          CALL EXPEV(NTP4EX,IST,IVAR,IDBLK,NUMEBB,SOLEB(1,IVAR),IERR)
        ELSE
C
C write element vars out to EXODUS data base (now is convenient)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C ELMASS is special
C
           IF (NAMVAR(nvargp+IVAR)(1:6) .EQ. 'ELMASS')THEN
C
C ELMASS was changed to nodal density prior to processing.
C need to go back from density to element mass now
C
C             NNODES=NNELM(ITYPE)
             NNODES = NELNDB
             IF (ITYPE .EQ. 6) NNODES = 4
             DO 100 IEL = 1, NUMEBB
               DO 105 I = 1, NNODES
                 XX(I) = XB(ICONB(I,IEL))
                 YY(I) = YB(ICONB(I,IEL))
                 IF (NDIMB .EQ. 3)THEN
                   ZZ(I) = ZB(ICONB(I,IEL))
                 ELSE
                   ZZ(I) = 0.
                 END IF
 105           CONTINUE
               CALL VOL(ITYPE,XX,YY,ZZ,VOLUME)
               SOLEB(IEL,IVAR) = SOLEB(IEL,IVAR) * VOLUME
 100         CONTINUE
           END IF
C
C****************************************************************
C apply constraints to variables here as applicable
C
C
C Plastic strain (EQPS) must greater than or equal to 0.
C
           IF (NAMVAR(nvargp+IVAR)(1:4) .EQ. 'EQPS')THEN
             DO 110 IEL = 1, NUMEBB
               IF (SOLEB(IEL,IVAR) .LT. 0.)THEN
                 SOLEB(IEL,IVAR) = 0.
               END IF
  110        CONTINUE
C
C Hourglass forces and bulk viscosity have no meaning other than on
C the mesh from which they originated, just set them to zero.
C
           ELSE IF (NAMVAR(nvargp+IVAR)(1:2) .EQ. 'HG' .OR.
     &          NAMVAR(nvargp+IVAR)(1:5) .EQ. 'BULKQ')THEN
             DO 120 IEL = 1, NUMEBB
               SOLEB(IEL,IVAR) = 0.
  120        CONTINUE
           ELSE IF (NAMVAR(NVARGP+IVAR)(1:7) .EQ. 'TEARING')THEN
             DO 130 IEL = 1, NUMEBB
               IF (SOLEB(IEL,IVAR) .LT. 0.)THEN
                 SOLEB(IEL,IVAR) = 0.
               END IF
  130        CONTINUE
           END IF
C        ELSE IF (NAMVAR(NVARGP+IVAR)(1:?) .EQ. ?????)THEN
C          DO ??? IEL = 1, NUMEBB
C            IF (SOLEB(IEL,IVAR) .??. ?.)THEN
C              SOLEB(IEL,IVAR) = ?.
C            END IF
C  ???     CONTINUE
c************************************************************************
c
c########################################################################
c the rotation tensor is special
c
c just store pointers to the rotation tensor components for later
c processing. do nothing here
c
           IF (NAMVAR(NVARGP+IVAR)(1:8) .EQ. 'COSTHETA')THEN
             ICOS = IVAR
             IROT = IROT + 1
             GO TO 10
           ELSE IF (NAMVAR(NVARGP+IVAR)(1:8) .EQ. 'SINTHETA')THEN
             ISIN = IVAR
             IROT = IROT + 1
             GO TO 10
           ELSE IF (NAMVAR(NVARGP+IVAR)(1:3) .EQ. 'R11')THEN
             IR11 = IVAR
             IROT = IROT + 1
             GO TO 10
           ELSE IF (NAMVAR(NVARGP+IVAR)(1:3) .EQ. 'R21')THEN
             IR21 = IVAR
             IROT = IROT + 1
             GO TO 10
           ELSE IF (NAMVAR(NVARGP+IVAR)(1:3) .EQ. 'R31')THEN
             IR31 = IVAR
             IROT = IROT + 1
             GO TO 10
           ELSE IF (NAMVAR(NVARGP+IVAR)(1:3) .EQ. 'R12')THEN
             IR12 = IVAR
             IROT = IROT + 1
             GO TO 10
           ELSE IF (NAMVAR(NVARGP+IVAR)(1:3) .EQ. 'R22')THEN
             IR22 = IVAR
             IROT = IROT + 1
             GO TO 10
           ELSE IF (NAMVAR(NVARGP+IVAR)(1:3) .EQ. 'R32')THEN
             IR32 = IVAR
             IROT = IROT + 1
             GO TO 10
           ELSE IF (NAMVAR(NVARGP+IVAR)(1:3) .EQ. 'R13')THEN
             IR13 = IVAR
             IROT = IROT + 1
             GO TO 10
           ELSE IF (NAMVAR(NVARGP+IVAR)(1:3) .EQ. 'R23')THEN
             IR23 = IVAR
             IROT = IROT + 1
             GO TO 10
           ELSE IF (NAMVAR(NVARGP+IVAR)(1:3) .EQ. 'R33')THEN
             IR33 = IVAR
             IROT = IROT + 1
             GO TO 10
           END IF
c########################################################################
C
C write element variables
C
           CALL EXPEV(NTP4EX,IST,IVAR,IDBLK,NUMEBB,SOLEB(1,IVAR),IERR)
   10      CONTINUE
c
c########################################################################
c now fix-up rotations - rotation matrix must have mag=1
c
c some simple error checking
c
           IF (NDIMB .EQ. 2)THEN
             IF (IROT .EQ. 2 .AND.
     &         ICOS .NE. 0 .AND. ISIN .NE. 0) THEN
              DO 230 IEL = 1, NUMEBB
               RMAG = SQRT(SOLEB(IEL,ICOS)*SOLEB(IEL,ICOS)
     &                   + SOLEB(IEL,ISIN)*SOLEB(IEL,ISIN))
               SOLEB(IEL,ICOS) = SOLEB(IEL,ICOS) / RMAG
               SOLEB(IEL,ISIN) = SOLEB(IEL,ISIN) / RMAG
  230         CONTINUE
              CALL EXPEV(NTP4EX,IST,ICOS,IDBLK,NUMEBB,SOLEB(1,ICOS),
     &                   IERR)
              CALL EXPEV(NTP4EX,IST,ISIN,IDBLK,NUMEBB,SOLEB(1,ISIN),
     &                   IERR)
              IROTF = 1
             END IF
C
C
            ELSE IF (IROT .EQ. 9 .AND. IROTF .EQ. 0 .AND. IR11 .NE. 0
     &        .AND. IR21 .NE. 0 .AND. IR31 .NE. 0 .AND. IR12 .NE. 0
     &        .AND. IR22 .NE. 0 .AND. IR32 .NE. 0 .AND. IR13 .NE. 0
     &        .AND. IR23 .NE. 0 .AND. IR33 .NE. 0)THEN
C
C compute magnitude of matrix
C
            DO 280 IEL = I, NUMEBB
             RMAG=SQRT(SOLEB(IEL,IR11)*SOLEB(IEL,IR22)*SOLEB(IEL,IR33)
     &           +    SOLEB(IEL,IR21)*SOLEB(IEL,IR32)*SOLEB(IEL,IR13)
     &           +    SOLEB(IEL,IR31)*SOLEB(IEL,IR12)*SOLEB(IEL,IR23)
     &           -    SOLEB(IEL,IR11)*SOLEB(IEL,IR23)*SOLEB(IEL,IR32)
     &           -    SOLEB(IEL,IR12)*SOLEB(IEL,IR21)*SOLEB(IEL,IR33)
     &           -    SOLEB(IEL,IR13)*SOLEB(IEL,IR22)*SOLEB(IEL,IR31))

             SOLEB(IEL,IR11) = SOLEB(IEL,IR11) / RMAG
             SOLEB(IEL,IR21) = SOLEB(IEL,IR21) / RMAG
             SOLEB(IEL,IR31) = SOLEB(IEL,IR31) / RMAG
             SOLEB(IEL,IR12) = SOLEB(IEL,IR12) / RMAG
             SOLEB(IEL,IR22) = SOLEB(IEL,IR22) / RMAG
             SOLEB(IEL,IR32) = SOLEB(IEL,IR32) / RMAG
             SOLEB(IEL,IR13) = SOLEB(IEL,IR13) / RMAG
             SOLEB(IEL,IR23) = SOLEB(IEL,IR23) / RMAG
             SOLEB(IEL,IR33) = SOLEB(IEL,IR33) / RMAG
c
  280       CONTINUE
            CALL EXPEV(NTP4EX,IST,IR11,IDBLK,NUMEBB,SOLEB(1,IR11),
     &                 IERR)
            CALL EXPEV(NTP4EX,IST,IR21,IDBLK,NUMEBB,SOLEB(1,IR21),
     &                 IERR)
            CALL EXPEV(NTP4EX,IST,IR31,IDBLK,NUMEBB,SOLEB(1,IR31),
     &                 IERR)
            CALL EXPEV(NTP4EX,IST,IR12,IDBLK,NUMEBB,SOLEB(1,IR12),
     &                 IERR)
            CALL EXPEV(NTP4EX,IST,IR22,IDBLK,NUMEBB,SOLEB(1,IR22),
     &                 IERR)
            CALL EXPEV(NTP4EX,IST,IR32,IDBLK,NUMEBB,SOLEB(1,IR32),
     &                 IERR)
            CALL EXPEV(NTP4EX,IST,IR13,IDBLK,NUMEBB,SOLEB(1,IR13),
     &                 IERR)
            CALL EXPEV(NTP4EX,IST,IR23,IDBLK,NUMEBB,SOLEB(1,IR23),
     &                 IERR)
            CALL EXPEV(NTP4EX,IST,IR33,IDBLK,NUMEBB,SOLEB(1,IR33),
     &                 IERR)
            IROTF = 1
          END IF
        END IF
 40     CONTINUE
        IF (IROTF .NE. 1) THEN
          CALL ERROR('INTRPE',
     &      'ROTATION MATRIX NORMALLY REQUIRED FOR RESTART',
     &      'DIMENSION ',NDIMB,
     &      'NUMBER OF ROTATION MATRIX COMPONENTS FOUND',IROT,
     &      'THIS IS ONLY A WARNING',' ',0)
        END IF
c########################################################################
C
      RETURN
      END

max_stars_repo_name: milljm/seacas

max_issues_repo_name: milljm/seacas

max_forks_repo_name: milljm/seacas


text:
      SUBROUTINE DROTM (N,DX,INCX,DY,INCY,DPARAM)

c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2006-06-07 DROTM  Krogh  Removed arithmetic ifs
C>> 1994-10-20 DROTM  Krogh  Changes to use M77CON
C>> 1994-04-29 DROTM  CLL Edited to make DP and SP codes similar.
C>> 1985-08-02 DROTM  Lawson  Initial code.
C
C     APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
C
C     (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN
C     (DY**T)
C
C     DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
C     LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY.
C     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
C
C     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
C
C       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
C     H=(          )    (          )    (          )    (          )
C       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
C     SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM.
C     -----------------------------------------------------------------
c--D replaces "?": ?ROTM
C     -----------------------------------------------------------------
      integer i, incx, incy, kx, ky, n, nsteps
      DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22, DX(*),DY(*),DPARAM(5)
      DOUBLE PRECISION TWO, W,Z, ZERO
      parameter(ZERO= 0.0d0, TWO= 2.0d0)
C     -----------------------------------------------------------------
C
      DFLAG=DPARAM(1)
      IF ((N .LE. 0) .OR. (DFLAG+TWO .EQ. ZERO)) RETURN
      IF ((INCX .NE. INCY) .OR. (INCX .LT. 0)) THEN
        KX=1
        KY=1
        IF(INCX .LT. 0) KX=1+(1-N)*INCX
        IF(INCY .LT. 0) KY=1+(1-N)*INCY
C
        IF (DFLAG .EQ. 0.D0) THEN
          DH12=DPARAM(4)
          DH21=DPARAM(3)
          DO 10 I=1,N
            W=DX(KX)
            Z=DY(KY)
            DX(KX)=W+Z*DH12
            DY(KY)=W*DH21+Z
            KX=KX+INCX
            KY=KY+INCY
 10       CONTINUE
        ELSE IF (DFLAG .GT. 0.D0) then
          DH11=DPARAM(2)
          DH22=DPARAM(5)
          DO 20 I=1,N
            W=DX(KX)
            Z=DY(KY)
            DX(KX)=W*DH11+Z
            DY(KY)=-W+DH22*Z
            KX=KX+INCX
            KY=KY+INCY
 20      CONTINUE
        ELSE
          DH11=DPARAM(2)
          DH12=DPARAM(4)
          DH21=DPARAM(3)
          DH22=DPARAM(5)
          DO 30 I=1,N
            W=DX(KX)
            Z=DY(KY)
            DX(KX)=W*DH11+Z*DH12
            DY(KY)=W*DH21+Z*DH22
            KX=KX+INCX
            KY=KY+INCY
 30       CONTINUE
        END IF
      ELSE
        NSTEPS=N*INCX
        IF (DFLAG .EQ. 0.D0) THEN
          DH12=DPARAM(4)
          DH21=DPARAM(3)
          DO 40 I=1,NSTEPS,INCX
            W=DX(I)
            Z=DY(I)
            DX(I)=W+Z*DH12
            DY(I)=W*DH21+Z
 40       CONTINUE
        ELSE IF (DFLAG .GT. 0.D0) THEN
          DH11=DPARAM(2)
          DH22=DPARAM(5)
          DO 50 I=1,NSTEPS,INCX
            W=DX(I)
            Z=DY(I)
            DX(I)=W*DH11+Z
            DY(I)=-W+DH22*Z
 50       CONTINUE
        ELSE
          DH11=DPARAM(2)
          DH12=DPARAM(4)
          DH21=DPARAM(3)
          DH22=DPARAM(5)
          DO 60 I=1,NSTEPS,INCX
            W=DX(I)
            Z=DY(I)
            DX(I)=W*DH11+Z*DH12
            DY(I)=W*DH21+Z*DH22
 60       CONTINUE
        END IF
      END IF
      RETURN
      END

ext: f


text:
C    @(#)fxminv.f	20.3 2/13/96
      subroutine fxminv(a,i,c,n)
      real a(*),c(*)

      c(1) = a(1)
      c(2) = 1.0
      ia = 1
      do 100 l=1,n
         x = a(ia)
         if (x .le. c(1)) then
            c(1) = x
            c(2) = float(l)
         endif
         ia = ia + i
  100 continue
      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:
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
! File lsmrblasInterface.f90
!
!    BLAS1 Interfaces:   ddot    dnrm2    dscal
!
! Maintained by Michael Saunders <saunders@stanford.edu>.
!
! 19 Dec 2008: lsqrblasInterface module implemented.
!              Metcalf and Reid recommend putting interfaces in a module.
! 16 Jul 2010: LSMR version derived from LSQR equivalent.
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

module lsmrblasInterface

  implicit none
  public   :: ddot, dnrm2, dscal

  interface                              ! Level 1 BLAS
     function ddot  (n,dx,incx,dy,incy)
       use lsmrDataModule, only : dp
       integer,  intent(in)    :: n,incx,incy
       real(dp), intent(in)    :: dx(*),dy(*)
       real(dp)                :: ddot
     end function ddot

     function dnrm2 (n,dx,incx)
       use lsmrDataModule, only : dp
       integer,  intent(in)    :: n,incx
       real(dp), intent(in)    :: dx(*)
       real(dp)                :: dnrm2
     end function dnrm2

     subroutine dscal (n,sa,x,incx)
       use lsmrDataModule, only : dp
       integer,  intent(in)    :: n,incx
       real(dp), intent(in)    :: sa
       real(dp), intent(inout) :: x(*)
     end subroutine dscal
  end interface

end module lsmrblasInterface

max_stars_repo_name: ChetGoerzen/DSurfTomo

max_issues_repo_name: ChetGoerzen/DSurfTomo

max_forks_repo_name: ChetGoerzen/DSurfTomo


text:
      REAL B(11)
      CHARACTER*190 A

C OPEN NEW FILES

      OPEN(1,FILE='KIM.DAT',STATUS='OLD')
      OPEN(2,FILE='DKIM.DAT',STATUS='NEW')

C READ IN THE NUMBER OF LINES TO SKIP AND READ

      DO 600 LKK=1,32

      READ(1,*)NS,NR
      WRITE(2,*)NS,NR
      DO 30 I=1,NS
      READ(1,22)A
   30 CONTINUE

      DO 31 I=1,NR
      READ(1,*)NN,(B(IJ),IJ=1,6)
      WRITE(2,23)NN,(B(IJ),IJ=1,6)
   31 CONTINUE

  600 CONTINUE

C TERMINATE PROGRAM

   22 FORMAT(A)
   90 FORMAT(2I3)
   23 FORMAT(1X,I4,1X,6(E12.6,1X))
  100 CONTINUE

      STOP
      END

ext: for


text: This account has been BannedGroup banned because this editor is a bad person, taking advantage of and vandalizing the communal work of volunteers.   I.e., they spammed the heck out of the wiki repeatedly.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
// Generated Files
${PROJ_DIR}/lpif/rtl/lpif_txrx/lpif_txrx_x16_h2_slave_top.sv
${PROJ_DIR}/lpif/rtl/lpif_txrx/lpif_txrx_x16_h2_slave_concat.sv
${PROJ_DIR}/lpif/rtl/lpif_txrx/lpif_txrx_x16_h2_slave_name.sv

// Logic Link files
-f ${PROJ_DIR}/llink/rtl/llink.f

// Common Files
-f ${PROJ_DIR}/common/rtl/common.f

max_stars_repo_name: chipsalliance/aib-protocols

max_issues_repo_name: chipsalliance/aib-protocols

max_forks_repo_name: chipsalliance/aib-protocols


text:
! MIT License
!
! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md
!
! 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.
!
! FTObjectLibrary contains code that, to the best of our knowledge, has been released as
! public domain software:
! * `b3hs_hash_key_jenkins`: originally by Rich Townsend,
! https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005
!
! --- End License

!
!////////////////////////////////////////////////////////////////////////
!
!      FTStackClass.f90
!      Created: January 25, 2013 12:56 PM
!      By: David Kopriva
!
!>Inherits from FTLinkedListClass : FTObjectClass
!>
!>##Definition (Subclass of FTLinkedListClass):
!>   TYPE(FTStack) :: list
!>
!>#Usage:
!>
!>##Initialization
!>
!>      ALLOCATE(stack)  If stack is a pointer
!>      CALL stack  %  init()
!>
!>##Destruction
!>      CALL releaseFTStack(stack) [Pointers]
!>
!>##Pushing an object onto the stack
!>
!>      TYPE(FTObject) :: objectPtr
!>      objectPtr => r1
!>      CALL stack % push(objectPtr)
!>
!>##Peeking at the top of the stack
!>
!>      objectPtr => stack % peek()  No change of ownership
!>      SELECT TYPE(objectPtr)
!>         TYPE is (*SubclassType*)
!>            … Do something with ObjectPtr as subclass
!>         CLASS DEFAULT
!>            … Problem with casting
!>      END SELECT
!>
!>##Popping the top of the stack
!>
!>      objectPtr => stack % pop()  Ownership transferred to caller
!>      SELECT TYPE(objectPtr)
!>         TYPE is (*SubclassType*)
!>            … Do something with ObjectPtr as subclass
!>         CLASS DEFAULT
!>            … Problem with casting
!>      END SELECT
!
!////////////////////////////////////////////////////////////////////////
!
      Module FTStackClass
      USE FTLinkedListClass
      IMPLICIT NONE

      TYPE, EXTENDS(FTLinkedList) :: FTStack
!
!        ========
         CONTAINS
!        ========
!
         PROCEDURE :: init             => initFTStack
         PROCEDURE :: printDescription => printStackDescription
         PROCEDURE :: className        => stackClassName
         PROCEDURE :: push
         PROCEDURE :: pop
         PROCEDURE :: peek
      END TYPE FTStack
!
!     ----------
!     Procedures
!     ----------
!
!     ========
      CONTAINS
!     ========
!
!
!------------------------------------------------
!> Public, generic name: init()
!>
!> Initialize the stack.
!------------------------------------------------
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE initFTStack(self)
         IMPLICIT NONE
         CLASS(FTStack) :: self
!
!        --------------------------------------------
!        Call the initializer of the superclass first
!        --------------------------------------------
!
         CALL self % FTLinkedList % init()
!
!        ---------------------------------
!        Then initialize ivars of subclass
!        ---------------------------------
!
         !None to intialize

      END SUBROUTINE initFTStack
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE releaseFTStack(self)
         IMPLICIT NONE
         TYPE(FTStack)  , POINTER :: self
         CLASS(FTObject), POINTER :: obj

         IF(.NOT. ASSOCIATED(self)) RETURN

         obj => self
         CALL release(obj)
         IF(.NOT.ASSOCIATED(obj)) self => NULL()
      END SUBROUTINE releaseFTStack
!
!     -----------------------------------
!     push: Push an object onto the stack
!     -----------------------------------
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE push(self,obj)
!
!        ----------------------------------
!        Add object to the head of the list
!        ----------------------------------
!
         IMPLICIT NONE
         CLASS(FTStack)                     :: self
         CLASS(FTObject)          , POINTER :: obj
         CLASS(FTLinkedListRecord), POINTER :: newRecord => NULL()
         CLASS(FTLinkedListRecord), POINTER :: tmp       => NULL()

         ALLOCATE(newRecord)
         CALL newRecord % initWithObject(obj)

         IF ( .NOT.ASSOCIATED(self % head) )     THEN
            self % head => newRecord
            self % tail => newRecord
         ELSE
            tmp                => self % head
            self % head        => newRecord
            self % head % next => tmp
            tmp  % previous    => newRecord
         END IF
         self % nRecords = self % nRecords + 1

      END SUBROUTINE push
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION peek(self)
!
!        -----------------------------------------
!        Return the object at the head of the list
!        ** No change of ownership **
!        -----------------------------------------
!
         IMPLICIT NONE
         CLASS(FTStack)           :: self
         CLASS(FTObject), POINTER :: peek

         IF ( .NOT. ASSOCIATED(self % head) )     THEN
            peek => NULL()
            RETURN
         END IF

         peek => self % head % recordObject

      END FUNCTION peek
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE pop(self,p)
!
!        ---------------------------------------------------
!        Remove the head of the list and return the object
!        that it points to. Calling routine gains ownership
!        of the object.
!        ---------------------------------------------------
!
         IMPLICIT NONE
         CLASS(FTStack)                     :: self
         CLASS(FTObject)          , POINTER :: p, obj
         CLASS(FTLinkedListRecord), POINTER :: tmp => NULL()

         IF ( .NOT. ASSOCIATED(self % head) )     THEN
            p => NULL()
            RETURN
         END IF

         p => self % head % recordObject
         IF(.NOT.ASSOCIATED(p)) RETURN
         CALL p % retain()

         tmp => self % head
         self % head => self % head % next

         obj => tmp
         CALL release(obj)
         self % nRecords = self % nRecords - 1

      END SUBROUTINE pop
!
!////////////////////////////////////////////////////////////////////////
!
      FUNCTION stackFromObject(obj) RESULT(cast)
!
!     -----------------------------------------------------
!     Cast the base class FTObject to the LinkedList class
!     -----------------------------------------------------
!
         IMPLICIT NONE
         CLASS(FTObject), POINTER :: obj
         CLASS(FTStack) , POINTER :: cast

         cast => NULL()
         SELECT TYPE (e => obj)
            TYPE is (FTStack)
               cast => e
            CLASS DEFAULT

         END SELECT

      END FUNCTION stackFromObject
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE printStackDescription(self, iUnit)
         IMPLICIT NONE
         CLASS(FTStack) :: self
         INTEGER        :: iUnit

         CALL self % FTLinkedList % printDescription(iUnit = iUnit)

      END SUBROUTINE printStackDescription
!
!////////////////////////////////////////////////////////////////////////
!
!      -----------------------------------------------------------------
!> Class name returns a string with the name of the type of the object
!>
!>  ### Usage:
!>
!>        PRINT *,  obj % className()
!>        if( obj % className = "FTStack")
!>
      FUNCTION stackClassName(self)  RESULT(s)
         IMPLICIT NONE
         CLASS(FTStack)                             :: self
         CHARACTER(LEN=CLASS_NAME_CHARACTER_LENGTH) :: s

         IF(self % refCount() .ge. 0) CONTINUE
         s = "FTStack"

      END FUNCTION stackClassName

      END Module FTStackClass

max_stars_repo_name: HigherOrderMethods/FTObjectLibrary

max_issues_repo_name: HigherOrderMethods/FTObjectLibrary

max_forks_repo_name: HigherOrderMethods/FTObjectLibrary


!
! Provides the field type, and some basic utility functions
!
module mod_field
!=============================================================================
   use mod_prec
   use mod_params, only: nx, ny, max_l, min_m, max_m, dt
   implicit none
!=============================================================================
   private

   public :: field, &
      set_field, set_level, set_DT, &
      shift_time_step, &
      time_integrate_field
!=============================================================================
! field type:
! always have two levels: n, np1 and intermediate levels for RK4 time
! evolution. k1, etc. are the time derivatives (note 1==n, 5==np1).
! These functions are complex as we work in NP formalism
!-----------------------------------------------------------------------------
   type :: field

   character(:), allocatable :: fname

   logical :: first_time

   integer(ip) :: spin, boost, falloff

   complex(rp), allocatable :: &
      n(:,:,:),  l2(:,:,:), l3(:,:,:), l4(:,:,:), np1(:,:,:), &
      k1(:,:,:), k2(:,:,:), k3(:,:,:), k4(:,:,:), k5(:,:,:),  &

      level(:,:,:), &
      DT(:,:,:), &
      DR(:,:,:), &
      raised(:,:,:), &
      lowered(:,:,:), &
      swal_lap(:,:,:), &

      coefs_cheb(:,:,:), &

      edth(:,:,:), &
      edth_prime(:,:,:), &
      thorn(:,:,:), &
      thorn_prime(:,:,:), &

      coefs_swal(:,:,:), coefs_both(:,:,:)

   real(rp), allocatable :: &
      re(:,:,:), im(:,:,:), coefs_cheb_re(:,:,:), coefs_cheb_im(:,:,:)

   end type field
!=============================================================================
contains
!=============================================================================
   subroutine set_field(fname, spin, boost, falloff, f)
      character(*), intent(in)    :: fname ! field fname
      integer(ip),  intent(in)    :: spin, boost, falloff
      type(field),  intent(inout) :: f

      f % fname = fname

      f % first_time = .true.

      f % spin    = spin
      f % boost   = boost
      f % falloff = falloff

      allocate(f%n(  nx,ny,min_m:max_m))
      allocate(f%l2( nx,ny,min_m:max_m))
      allocate(f%l3( nx,ny,min_m:max_m))
      allocate(f%l4( nx,ny,min_m:max_m))
      allocate(f%np1(nx,ny,min_m:max_m))
      f % n   = 0.0_rp
      f % l2  = 0.0_rp
      f % l3  = 0.0_rp
      f % l4  = 0.0_rp
      f % np1 = 0.0_rp

      allocate(f%k1(nx,ny,min_m:max_m))
      allocate(f%k2(nx,ny,min_m:max_m))
      allocate(f%k3(nx,ny,min_m:max_m))
      allocate(f%k4(nx,ny,min_m:max_m))
      allocate(f%k5(nx,ny,min_m:max_m))
      f % k1 = 0.0_rp
      f % k2 = 0.0_rp
      f % k3 = 0.0_rp
      f % k4 = 0.0_rp
      f % k5 = 0.0_rp

      allocate(f%level(   nx,ny,min_m:max_m))
      allocate(f%DT(      nx,ny,min_m:max_m))
      allocate(f%DR(      nx,ny,min_m:max_m))
      allocate(f%raised(  nx,ny,min_m:max_m))
      allocate(f%lowered( nx,ny,min_m:max_m))
      allocate(f%swal_lap(nx,ny,min_m:max_m))
      f % level    = 0.0_rp
      f % DT       = 0.0_rp
      f % DR       = 0.0_rp
      f % raised   = 0.0_rp
      f % lowered  = 0.0_rp
      f % swal_lap = 0.0_rp

      allocate(f%coefs_swal(nx,0:max_l,min_m:max_m))
      allocate(f%coefs_cheb(nx,     ny,min_m:max_m))
      allocate(f%coefs_both(nx,0:max_l,min_m:max_m))
      f % coefs_swal = 0.0_rp
      f % coefs_cheb = 0.0_rp
      f % coefs_both = 0.0_rp

      allocate(f%edth(       nx,ny,min_m:max_m))
      allocate(f%edth_prime( nx,ny,min_m:max_m))
      allocate(f%thorn(      nx,ny,min_m:max_m))
      allocate(f%thorn_prime(nx,ny,min_m:max_m))
      f % edth        = 0.0_rp
      f % edth_prime  = 0.0_rp
      f % thorn       = 0.0_rp
      f % thorn_prime = 0.0_rp

      allocate(f%re(           nx,ny,min_m:max_m))
      allocate(f%im(           nx,ny,min_m:max_m))
      allocate(f%coefs_cheb_re(nx,ny,min_m:max_m))
      allocate(f%coefs_cheb_im(nx,ny,min_m:max_m))
      f % re = 0.0_rp
      f % im = 0.0_rp
      f % coefs_cheb_re = 0.0_rp
      f % coefs_cheb_im = 0.0_rp

   end subroutine set_field
!=============================================================================
   subroutine set_level(step, m_ang, f)
      integer(ip), intent(in)    :: step, m_ang
      type(field), intent(inout) :: f

      select case (step)
         case (1)
            f % level(:,:,m_ang) = f % n(:,:,m_ang)
         case (2)
            f % level(:,:,m_ang) = f % l2(:,:,m_ang)
         case (3)
            f % level(:,:,m_ang) = f % l3(:,:,m_ang)
         case (4)
            f % level(:,:,m_ang) = f % l4(:,:,m_ang)
         case (5)
            f % level(:,:,m_ang) = f % np1(:,:,m_ang)
         case default
            write(*,*) "ERROR(set_field_level), step=", step
      end select
   end subroutine set_level
!=============================================================================
   subroutine set_DT(step, m_ang, f)
      integer(ip), intent(in)    :: step, m_ang
      type(field), intent(inout) :: f

      select case (step)
         case (1)
            f % DT(:,:,m_ang) = f % k1(:,:,m_ang)
         case (2)
            f % DT(:,:,m_ang) = f % k2(:,:,m_ang)
         case (3)
            f % DT(:,:,m_ang) = f % k3(:,:,m_ang)
         case (4)
            f % DT(:,:,m_ang) = f % k4(:,:,m_ang)
         case (5)
            f % DT(:,:,m_ang) = f % k5(:,:,m_ang)
         case default
            write(*,*) "ERROR(set_field_DT), step=", step
      end select
   end subroutine set_DT
!=============================================================================
   subroutine shift_time_step(m_ang, f)
      integer(ip), intent(in)    :: m_ang
      type(field), intent(inout) :: f

      f % n( :,:,m_ang) = f % np1(:,:,m_ang)
      f % k1(:,:,m_ang) = f % k5( :,:,m_ang)
   end subroutine shift_time_step
!=============================================================================
! RK4 time integrator: integrate field in time
!=============================================================================
   subroutine time_integrate_field(m_ang, f, int_f)
      integer(ip), intent(in)    :: m_ang
      type(field), intent(in)    :: f
      type(field), intent(inout) ::int_f ! int_f :time integral of f
   !--------------------------------------------------------
      int_f%k1(:,:,m_ang)= f%n(:,:,m_ang)
      int_f%l2(:,:,m_ang)= int_f%n(:,:,m_ang)+0.5_rp*dt*int_f%k1(:,:,m_ang)
   !--------------------------------------------------------
      int_f%k2(:,:,m_ang)= f%l2(:,:,m_ang)
      int_f%l3(:,:,m_ang)= int_f%n(:,:,m_ang)+0.5_rp*dt*int_f%k2(:,:,m_ang)
   !--------------------------------------------------------
      int_f%k3(:,:,m_ang)= f%l3(:,:,m_ang)
      int_f%l4(:,:,m_ang)= int_f%n(:,:,m_ang)+dt*int_f%k3(:,:,m_ang)
   !--------------------------------------------------------
      int_f%k4(:,:,m_ang) = f%l4(:,:,m_ang)
      int_f%np1(:,:,m_ang)= int_f%n(:,:,m_ang) &
      +  (dt/6.0_rp)*( &
            int_f%k1(:,:,m_ang) &
         +  2.0_rp*int_f%k2(:,:,m_ang) &
         +  2.0_rp*int_f%k3(:,:,m_ang) &
         +  int_f%k4(:,:,m_ang) &
         )
   !------------------------------------------------------------
   ! want k5 for computing source term and independent residuals
   !------------------------------------------------------------
      int_f%k5(:,:,m_ang) = f%np1(:,:,m_ang)

   end subroutine time_integrate_field
!=============================================================================
end module mod_field