text:
!     Wrapper for the COULFG.

      subroutine myCOULFG(angL,eta,rho,myf,mydf,myg,mydg,iv)
      double precision  angL,eta, rho, myf, mydf,myg,mydg
      integer iv,lmax
      double precision XLMIN, XLMAX
      double precision XX, ETA1
      integer  MODE1, KFN, IFAIL
      double precision , allocatable, dimension(:):: FC,GC,FCP,GCP
Cf2py intent(in) angL
Cf2py intent(in) eta
Cf2py intent(in) rho
Cf2py intent(out) myf
Cf2py intent(out) mydf
Cf2py intent(out) myg
Cf2py intent(out) mydg
Cf2py intent(out) iv
      XLMIN=angL
      XLMAX=angL
      lmax=IDINT(XLMAX)+1
      allocate (FC(lmax),GC(lmax),FCP(lmax),GCP(lmax))
      MODE1=1
      KFN=0
      XX=rho
      ETA1=eta
      call COULFG(XX,ETA1,XLMIN,XLMAX,FC,GC,FCP,GCP,MODE1,KFN,IFAIL)
      myf=FC(lmax)
      mydf=FCP(lmax)
      myg=GC(lmax)
      mydg=GCP(lmax)
      iv=IFAIL
      return
      end

      SUBROUTINE COULFG(XX,ETA1,XLMIN,XLMAX,FC,GC,FCP,GCP,MODE1,
     & KFN,IFAIL)
C  REVISED #5 IJT WITH L-T ALGORITHMN FOR CONTINUED FRACTIONS,
C  AND IFAIL > 0 FOR AVOIDED EXPONENT CHECKS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C  REVISED COULOMB WAVEFUNCTION PROGRAM USING STEED'S METHOD           C
C                                                                      C
C  A. R. BARNETT           MANCHESTER  MARCH   1981                    C
C                                                                      C
C  ORIGINAL PROGRAM 'RCWFN'      IN    CPC  8 (1974) 377-395           C
C                 + 'RCWFF'      IN    CPC 11 (1976) 141-142           C
C  FULL DESCRIPTION OF ALGORITHM IN    CPC 21 (1981) 297-314           C
C  THIS VERSION WRITTEN UP       IN    CPC 27 (1982) 147-166           C
C                                                                      C
C  COULFG RETURNS F,G,F',G', FOR REAL XX.GT.0,REAL ETA1 (INCLUDING 0), C
C   AND REAL LAMBDA(XLMIN) .GT. -1 FOR INTEGER-SPACED LAMBDA VALUES    C
C   THUS GIVING POSITIVE-ENERGY SOLUTIONS TO THE COULOMB SCHRODINGER   C
C   EQUATION,TO THE KLEIN-GORDON EQUATION AND TO SUITABLE FORMS OF     C
C   THE DIRAC EQUATION ,ALSO SPHERICAL & CYLINDRICAL BESSEL EQUATIONS  C
C                                                                      C
C  FOR A RANGE OF LAMBDA VALUES (XLMAX - XLMIN) MUST BE AN INTEGER,    C
C  STARTING ARRAY ELEMENT IS M1 = MAX0(IDINT(XLMIN+ACCUR),0) + 1       C
C      SEE TEXT FOR MODIFICATIONS FOR INTEGER L-VALUES                 C
C                                                                      C
C  IF 'MODE' = 1  GET F,G,F',G'   FOR INTEGER-SPACED LAMBDA VALUES     C
C            = 2      F,G      UNUSED ARRAYS MUST BE DIMENSIONED IN    C
C            = 3      F               CALL TO AT LEAST LENGTH (1)      C
C  IF 'KFN'  = 0 REAL        COULOMB FUNCTIONS ARE RETURNED            C
C            = 1 SPHERICAL   BESSEL      "      "     "                C
C            = 2 CYLINDRICAL BESSEL      "      "     "                C
C  THE USE OF 'MODE' AND 'KFN' IS INDEPENDENT                          C
C                                                                      C
C  PRECISION:  RESULTS TO WITHIN 2-3 DECIMALS OF 'MACHINE ACCURACY'    C
C   IN OSCILLATING REGION X .GE. ETA1 + SQRT(ETA1**2 + XLM(XLM+1))     C
C   COULFG IS CODED FOR REAL*8 ON IBM OR EQUIVALENT  ACCUR = 10**-16   C
C   USE AUTODBL + EXTENDED PRECISION ON HX COMPILER  ACCUR = 10**-33   C
C   FOR MANTISSAS OF 56 & 112 BITS. FOR SINGLE PRECISION CDC (48 BITS) C
C   REASSIGN DSQRT=SQRT ETC.  SEE TEXT FOR COMPLEX ARITHMETIC VERSION  C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT double precision (A-H,O-Z)
      DIMENSION    FC(*),GC(*),FCP(*),GCP(*)
      LOGICAL      ETANE0,XLTURN
      COMMON       /STEE / PACCQ,NFP,NPQ,IEXP,M1
C***  COMMON BLOCK IS FOR INFORMATION ONLY.  NOT REQUIRED IN CODE
C***  COULFG HAS CALLS TO: DSQRT,DABS,DMOD,IDINT,DSIGN,DFLOAT,DMIN1
      DATA ZERO,ONE,TWO,TEN2,ABORT /0.0D0, 1.0D0, 2.0D0, 1.0D2, 2.0D4/
      DATA HALF,TM30,BIG / 0.5D0, 1.0D-30, 1.0D+100/
      DATA RT2DPI /0.79788 45608 02865 35587 98921 19868 76373 D0/
C *** THIS CONSTANT IS  DSQRT(TWO/PI):  USE Q0 FOR IBM REAL*16: D0 FOR
C ***  REAL*8 & CDC DOUBLE P:  E0 FOR CDC SINGLE P; AND TRUNCATE VALUE.
C
      ACCUR = 1.0D-16
C ***            CHANGE ACCUR TO SUIT MACHINE AND PRECISION REQUIRED
!      write(*,*) XLMIN,XLMAX
      MODE  = 1
      IF(MODE1 .EQ. 2 .OR. MODE1 .EQ. 3 ) MODE = MODE1
      IFAIL = 0
      IEXP  = 1
      NPQ   = 0
      ETA   = ETA1
      GJWKB = ZERO
      PACCQ = ONE
      IF(KFN .NE. 0) ETA = ZERO
                 ETANE0  = ETA .NE. ZERO
      ACC   = ACCUR * 10D0
      ACC4  = ACC*TEN2*TEN2
      ACCH  = DSQRT(ACC)
C ***    TEST RANGE OF XX, EXIT IF.LE.DSQRT(ACCUR) OR IF NEGATIVE
C
      IF(XX .LE. ACCH)                          GO TO 100
      X     = XX
      XLM   = XLMIN
      IF(KFN .EQ. 2)  XLM = XLM - HALF
      IF(XLM .LE. -ONE .OR. XLMAX .LT. XLMIN)   GO TO 105
      E2MM1 = ETA*ETA + XLM*XLM + XLM
      XLTURN= X*(X - TWO*ETA) .LT. XLM*XLM + XLM
      DELL  = XLMAX - XLMIN + ACC
      IF(DABS(DMOD(DELL,ONE)) .GT. 2*ACC) WRITE(6,2040)XLMAX,XLMIN,DELL
      LXTRA = IDINT(DELL)
      XLL   = XLM + DFLOAT(LXTRA)
C ***       LXTRA IS NUMBER OF ADDITIONAL LAMBDA VALUES TO BE COMPUTED
C ***       XLL  IS MAX LAMBDA VALUE, OR 0.5 SMALLER FOR J,Y BESSELS
C ***         DETERMINE STARTING ARRAY ELEMENT (M1) FROM XLMIN
      M1  = MAX0(IDINT(XLMIN + ACC),0) + 1
      L1  = M1 + LXTRA
C
C ***    EVALUATE CF1  =  F   =  FPRIME(XL,ETA,X)/F(XL,ETA,X)
C
      XI  = ONE/X
      FCL = ONE
      PK  = XLL + ONE
      PX  = PK  + ABORT
      F   =  ETA/PK + PK*XI
         IF(DABS(F).LT.TM30) F = TM30
         D = ZERO
         C = F
C
C ***   BEGIN CF1 LOOP ON PK = K = LAMBDA + 1
C
    4 PK1   = PK + ONE
        EK  = ETA / PK
        RK2 = ONE + EK*EK
        TK  = (PK + PK1)*(XI + EK/PK1)
        D   =  TK - RK2 * D
        C   =  TK - RK2 / C
         IF(DABS(C).LT.TM30) C = TM30
         IF(DABS(D).LT.TM30) D = TM30
         D = ONE/D
         DF = D * C
         F  = F * DF
            IF(D .LT. ZERO) FCL = - FCL
         PK = PK1
                          IF( PK .GT. PX ) GO TO 110
      IF(DABS(DF-ONE) .GE. ACC)             GO TO 4
                  NFP = PK - XLL - 1
      IF(LXTRA .EQ. 0)                          GO TO 7
C
C *** DOWNWARD RECURRENCE TO LAMBDA = XLM. ARRAY GC,IF PRESENT,STORES RL
C
      FCL = FCL/BIG
      FPL = FCL*F
      IF(MODE .EQ. 1) FCP(L1) = FPL
                      FC (L1) = FCL
      XL  = XLL
      RL  = ONE
      EL  = ZERO
      DO 6  LP = 1,LXTRA
         IF(ETANE0) EL = ETA/XL
         IF(ETANE0) RL = DSQRT(ONE + EL*EL)
         SL    =  EL  + XL*XI
         L     =  L1  - LP
         FCL1  = (FCL *SL + FPL)/RL
         FPL   =  FCL1*SL - FCL *RL
         FCL   =  FCL1
         FC(L) =  FCL
         IF(MODE .EQ. 1) FCP(L)  = FPL
         IF(MODE .NE. 3 .AND. ETANE0) GC(L+1) = RL
	 if(abs(FCL).gt.BIG) then
		do 55 LP1=L,M1+LXTRA
      		IF(MODE .EQ. 1) FCP(LP1) = FCP(LP1)*1d-20
 55                    		FC (LP1) = FC(LP1)*1d-20
		FCL=FC(L)
		FPL=FPL*1d-20
		endif
    6 XL = XL - ONE
      IF(FCL .EQ. ZERO) FCL = ACC
      F  = FPL/FCL
C ***    NOW WE HAVE REACHED LAMBDA = XLMIN = XLM
C ***    EVALUATE CF2 = P + I.Q  AGAIN USING STEED'S ALGORITHM
C ***    SEE TEXT FOR COMPACT COMPLEX CODE FOR SP CDC OR NON-ANSI IBM
C
    7 IF( XLTURN ) CALL JWKB(X,ETA,DMAX1(XLM,ZERO),FJWKB,GJWKB,IEXP)
      IF( IEXP .GT. 1 .OR. GJWKB .GT. ONE/(ACCH*TEN2))  GO TO 9
          XLTURN = .FALSE.
      TA =  TWO*ABORT
      PK =  ZERO
      WI =  ETA + ETA
      P  =  ZERO
      Q  =  ONE - ETA*XI
      AR = -E2MM1
      AI =  ETA
      BR =  TWO*(X - ETA)
      BI =  TWO
      DR =  BR/(BR*BR + BI*BI)
      DI = -BI/(BR*BR + BI*BI)
      DP = -XI*(AR*DI + AI*DR)
      DQ =  XI*(AR*DR - AI*DI)
    8 P     = P  + DP
         Q  = Q  + DQ
         PK = PK + TWO
         AR = AR + PK
         AI = AI + WI
         BI = BI + TWO
         D  = AR*DR - AI*DI + BR
         DI = AI*DR + AR*DI + BI
         C  = ONE/(D*D + DI*DI)
         DR =  C*D
         DI = -C*DI
         A  = BR*DR - BI*DI - ONE
         B  = BI*DR + BR*DI
         C  = DP*A  - DQ*B
         DQ = DP*B  + DQ*A
         DP = C
         IF(PK .GT. TA)                         GO TO 120
      IF(DABS(DP)+DABS(DQ).GE.(DABS(P)+DABS(Q))*ACC)   GO TO 8
                      NPQ   = PK/TWO
                      PACCQ = HALF*ACC/DMIN1(DABS(Q),ONE)
                      IF(DABS(P) .GT. DABS(Q)) PACCQ = PACCQ*DABS(P)
C
C *** SOLVE FOR FCM = F AT LAMBDA = XLM,THEN FIND NORM FACTOR W=W/FCM
C
      GAM = (F - P)/Q
            IF(Q .LE. ACC4*DABS(P))             GO TO 130
      W   = ONE/DSQRT((F - P)*GAM + Q)
            GO TO 10
C *** ARRIVE HERE IF G(XLM) .GT. 10**6 OR IEXP .GT. 70 & XLTURN = .TRUE.
    9 W   = FJWKB
      GAM = GJWKB*W
      P   = F
      Q   = ONE
C
C *** NORMALISE FOR SPHERICAL OR CYLINDRICAL BESSEL FUNCTIONS
C
   10                     ALPHA = ZERO
          IF(KFN  .EQ. 1) ALPHA = XI
          IF(KFN  .EQ. 2) ALPHA = XI*HALF
                          BETA  = ONE
          IF(KFN  .EQ. 1) BETA  = XI
          IF(KFN  .EQ. 2) BETA  = DSQRT(XI)*RT2DPI
      FCM  = DSIGN(W,FCL)*BETA
           FC(M1)  = FCM
                      IF(MODE .EQ. 3)           GO TO 11
           IF(.NOT. XLTURN)   GCL =  FCM*GAM
           IF(      XLTURN)   GCL =  GJWKB*BETA
           IF( KFN .NE. 0 )   GCL = -GCL
           GC(M1)  = GCL
           GPL =  GCL*(P - Q/GAM) - ALPHA*GCL
                      IF(MODE .EQ. 2)           GO TO 11
           GCP(M1) = GPL
           FCP(M1) = FCM*(F - ALPHA)
   11 IF(LXTRA .EQ. 0 ) RETURN
C *** UPWARD RECURRENCE FROM GC(M1),GCP(M1)  STORED VALUE IS RL
C *** RENORMALISE FC,FCP AT EACH LAMBDA AND CORRECT REGULAR DERIVATIVE
C ***    XL   = XLM HERE  AND RL = ONE , EL = ZERO FOR BESSELS
         W    = BETA*W/DABS(FCL)
         MAXL = L1 - 1
      DO 12 L = M1,MAXL
                      IF(MODE .EQ. 3)           GO TO 12
                      XL = XL + ONE
         IF(ETANE0)   EL = ETA/XL
         IF(ETANE0)   RL = GC(L+1)
                      SL = EL + XL*XI
         GCL1     = ((SL - ALPHA)*GCL - GPL)/RL
		IF(ABS(GCL1).gt.BIG) GO TO 140
         GPL      =   RL*GCL -  (SL + ALPHA)*GCL1
         GCL      = GCL1
         GC(L+1)  = GCL1
                      IF(MODE .EQ. 2)           GO TO 12
         GCP(L+1) = GPL
         FCP(L+1) = W*(FCP(L+1) - ALPHA*FC(L+1))
   12 FC(L+1)     = W* FC(L+1)
      RETURN
C
C ***    ERROR MESSAGES
C
  100 IFAIL = -1
      WRITE(6,2000) XX,ACCH
 2000 FORMAT(' FOR XX = ',1P,D12.3,' TRY SMALL-X  SOLUTIONS',
     *' OR X NEGATIVE'/ ,' SQUARE ROOT ACCURACY PARAMETER =  ',D12.3/)
      RETURN
  105 IFAIL = -2
      WRITE (6,2005) XLMAX,XLMIN,XLM
 2005 FORMAT(/' PROBLEM WITH INPUT ORDER VALUES:XLMAX,XLMIN,XLM = ',
     *1P,3D15.6/)
      RETURN
  110 IFAIL = -3
      WRITE (6,2010) ABORT,F ,DF,PK,PX,ACC
 2010 FORMAT(' CF1 HAS FAILED TO CONVERGE AFTER ',F10.0,' ITERATIONS',/
     *' F,DF,PK,PX,ACCUR =  ',1P,5D12.3//)
      RETURN
  120 IFAIL = -4
      WRITE (6,2020) ABORT,P,Q,DP,DQ,ACC
 2020 FORMAT(' CF2 HAS FAILED TO CONVERGE AFTER ',F7.0,' ITERATIONS',/
     *' P,Q,DP,DQ,ACCUR =  ',1P,4D17.7,D12.3//)
      RETURN
  130 IFAIL = -5
      WRITE (6,2030) P,Q,ACC,DELL,LXTRA,M1
 2030 FORMAT(' FINAL Q.LE.DABS(P)*ACC*10**4 , P,Q,ACC = ',1P,3D12.3,4X,
     *' DELL,LXTRA,M1 = ',D12.3,2I5 /)
      RETURN
 2040 FORMAT(' XLMAX - XLMIN = DELL NOT AN INTEGER ',1P,3D20.10/)
  140 IFAIL=L1-L
      RETURN
      END
C
      SUBROUTINE JWKB(XX,ETA1,XL,FJWKB,GJWKB,IEXP)                      ABNK0331
      implicit double precision(a-h,o-z)
c     REAL*8          XX,ETA1,XL,FJWKB,GJWKB,DZERO                      ABNK0332
C *** COMPUTES JWKB APPROXIMATIONS TO COULOMB FUNCTIONS    FOR XL.GE. 0 ABNK0333
C *** AS MODIFIED BY BIEDENHARN ET AL. PHYS REV 97 (1955) 542-554       ABNK0334
C *** CALLS DMAX1,SQRT,ALOG,EXP,ATAN2,FLOAT,INT        BARNETT FEB 1981 ABNK0335
      DATA   ZERO,HALF,ONE,SIX,TEN/ 0, 0.5d0, 1, 6, 10 /                ABNK0336
c     DATA  DZERO, RL35, ALOGE  /0,35, 0.43429 45 E0 /                  ABNK0337
      DATA  DZERO, RL35 /0,35 /                                         ABNK0337
      aloge=log(ten)
      X     = XX                                                        ABNK0339
      ETA   = ETA1                                                      ABNK0339
      GH2   = X*(ETA + ETA - X)                                         ABNK0340
      XLL1  = MAX(XL*XL + XL,DZERO)                                     ABNK0341
      IF(GH2 + XLL1 .LE. ZERO) RETURN                                   ABNK0342
       HLL  = XLL1 + SIX/RL35                                           ABNK0343
       HL   = SQRT(HLL)                                                 ABNK0344
       SL   = ETA/HL + HL/X                                             ABNK0345
       RL2  = ONE + ETA*ETA/HLL                                         ABNK0346
       GH   = SQRT(GH2 + HLL)/X                                         ABNK0347
       PHI  = X*GH - HALF*( HL*LOG((GH + SL)**2/RL2) - LOG(GH) )        ABNK0348
          IF(ETA .NE. ZERO) PHI = PHI - ETA*ATAN2(X*GH,X - ETA)         ABNK0349
      PHI10 = -PHI*ALOGE                                                ABNK0350
      IEXP  =  INT(PHI10)                                               ABNK0351
      IF(IEXP .GT. 70) GJWKB = TEN**(PHI10 - IEXP)                      ABNK0352
      IF(IEXP .LE. 70) GJWKB = EXP(-PHI)                                ABNK0353
      IF(IEXP .LE. 70) IEXP  = 0                                        ABNK0354
      FJWKB = HALF/(GH*GJWKB)                                           ABNK0355
      RETURN                                                            ABNK0356
      END                                                               ABNK0357

      SUBROUTINE WHIT(HETA,R,XK,E,LL,F,FD,IE)
C
C     CALCULATES  WHITTAKER  FUNCTION  WL(K,R)  WITH
C     ASYMPTOTIC  FORM  EXP(-(KR + ETA(LOG(2KR)))
C     E  IS  NEGATIVE
C     If IE = 0, allowed to return result e**IE larger than Whittaker,
C                for the IE value returned.
C     If IE > 0, must scale results by that amount.
C
C     Author: I.J. Thompson, downloaded from http://www.fresco.org.uk
      IMPLICIT double precision  (A-H,O-Z)
      DIMENSION F(LL+1),FD(LL+1) ,T(12),S(7)
      data fpmax/1.0d290/
      L = LL+1
C              NOW L = NO. OF VALUES TO FIND
      EE=-1.0
      AK=XK
      ETA=HETA
      LP1=L+1
      RHO=AK*R
	S(:) = 0
      IF(L-50)1,1,2
    1 LM=60
      GO TO 3
    2 LM=L+10
    3 LMP1=LM+1
      IS=7
      PJE=30.0*RHO+1.0
      H=max(INT(PJE),4)
      H=RHO/H
!	write(147,111) R,RHO,H
!111	format(3f10.6)
      RHOA=10.0*(ETA+1.0)
      IF(RHOA-RHO)13,13,14
   13 IFEQL=1
      RHOA=RHO
      GO TO 15
   14 IFEQL=0
   15 PJE=RHOA/H+0.5
      RHOA=H*INT(PJE)
      IF(IFEQL)16,16,18
   16 IF(RHOA-RHO-1.5*H)17,18,18
   17 RHOA=RHO+2.0*H
   18 IF(EE)55,55,19
   19 STOP 'WHIT'
   27 A=2.0-10.0/12.0*H*H*EE
      B=1.0/6.0*H*ETA
      C=1.0+1.0/12.0*H*H*EE
      M1=INT(RHOA/H-0.5)
      M2=INT(RHO/H-1.5)
      T(2)=B/FLOAT(M1+1)
      T(3)=B/FLOAT(M1)
      JS=M1
      DO 29 IS=M2,M1
      DO 28 I=1,6
      S(I)=S(I+1)
   28 CONTINUE
      T(1)=T(2)
      T(2)=T(3)
      T(3)=B/FLOAT(JS-1)
      S(7)=((A+10.0*T(2))*S(6)-(C-T(1))*S(5))/(C-T(3))
      JS=JS-1
      IF(ABS(S(7)).LE.FPMAX) GO TO 29
       DO 285 I=2,7
  285   S(I) = S(I) / FPMAX
   29 CONTINUE
      T(1)=S(4)
      T(2)=(1.0/60.0*(S(1)-S(7))+0.15*(S(6)-S(2))+0.75*(S(3)-S(5)))/H
      GO TO 60
   55 C=1.0/RHOA
      A=1.0
      B=1.0-C*ETA
      F(1)=A
      FD(1)=B
      DO 56 M=1,26
      D=0.5*(ETA+FLOAT(M-1))*(ETA+FLOAT(M))*C/FLOAT(M)
      A=-A*D
      B=-B*D-A*C
      F(1)=F(1)+A
      FD(1)=FD(1)+B
   56 CONTINUE
      A=-ETA*LOG(2.0*RHOA)-RHOA
      FPMINL = -LOG(FPMAX)
      if(IE.eq.0.and.A.LT.FPMINL) IE = INT(FPMINL-A)
      A=EXP(A+IE)
      F(1)=A*F(1)
c      FD(1)=A*FD(1)
      FD(1)=A*FD(1) * (-1d0 - 2*ETA/(RHOA))
      IF(IFEQL)57,57,61
   57 S(IS)=F(1)
      IF(IS-7)27,58,27
   58 IS=6
      RHOA=RHOA+H
      GO TO 55
   60 F(1)=T(1)
      FD(1)=T(2)
   61 C=1.0/RHO
      DO 63 M=1,L-1
      A=ETA/FLOAT(M)
      B=A+C*FLOAT(M)
      F(M+1)=(B*F(M)-FD(M))/(A+1.0)
      FD(M+1)=(A-1.0)*F(M)-B*F(M+1)
   63 CONTINUE
      DO 65 M=1,L
      FD(M)=AK*FD(M)
   65 CONTINUE
      RETURN
      END

max_stars_repo_name: buqeye/eigenvector-continuation

max_issues_repo_name: buqeye/eigenvector-continuation

max_forks_repo_name: buqeye/eigenvector-continuation


text:
c______________________________________________________________________
c
      subroutine outinit(iout,nch)

      character*80 cfout

c  commonblock FORMOUT contains info about output format
c    (common to outinit and outdo)
      character*40 cf,cfhd
      common /FORMOUT/cf,cfhd

c  common block HEADER contains info passed to output file, but not
c    used in main program
      character*80 comment
      integer iyr,imo,iday,ihr,imin,isec,iclk0,ioff,inunit,itf
      real dr
      common /inblk/dr,iyr,imo,iday,ihr,imin,isec,iclk0,
     &  ioff,inunit,itf,comment

      print*,'enter output file name'
      read(5,'(a80)') cfout
      open(unit=iout,file=cfout)

      return
      end
c______________________________________________________________________
c
      subroutine outdo(it1,nt,nch,ix,lsamp,iout)

c  commonblock FORMOUT contains info about output format
c    (common to outinit and outdo)
      character*40 cf,cfhd
      character*80 comment
      common /FORMOUT/cf,cfhd
      common /inblk/dr,iyr,imo,iday,ihr,imin,isec,iclk0,
     &  ioff,inunit,itf,comment
      logical lsamp

      parameter (ntmx=1000)
      integer ix(nch,*),it1,nt

      if(lsamp) then
         do j =  1,nt
            write(iout,'(i10,10i7)') it1+j-1,(ix(i,j),i=1,nch)
         enddo
      else
         do j =  1,nt
            write(iout,'(10i7)') (ix(i,j),i=1,nch)
         enddo
      endif

      return
      end
c______________________________________________________________________
c
      subroutine wrhdbin(iout,cfile,nch,dr,iyr,imo,iday,ihr,imin,
     & isec,iclk0,irecl,comment,nseg,iseg,xb,xsc,chid)

ccc   here this is just a dummy routine ... nothing happens when this is
ccc   called ... could easily be changed to have some sort of header output
ccc   if desired

      return
      end

ext: f

max_stars_repo_name: simpeg-research/iris-mt-scratch

max_issues_repo_name: simpeg-research/iris-mt-scratch

max_forks_repo_name: simpeg-research/iris-mt-scratch


text:
../hdl/riscv32ima_core.sv
../hdl/riscv32ima_wback.sv
../hdl/riscv32ima_lsu.sv
../hdl/riscv32ima_alu.sv
../hdl/riscv32ima_dec.sv
../hdl/riscv32ima_gprf.sv
../hdl/riscv32ima_fetch.sv


text:
! -----------------------------------------------------------------------------
! This distribution of LAPACK contains a modified version of xerbla.f
! Copyright (c) 2014 - present OpenGamma, Inc. and the OpenGamma group of
! companies.
! It is present in a file called xerbla.f90 located within the source
! at ${ROOT}/BLAS/SRC/xerbla.f90
!
! Internally, we refer to this function as "OG xerbla", however, due to the
! number of references to this routine throughout LAPACK, we have not modified
! the name of the routine in this distribution.
!
! The modifications we made to the XERBLA() subroutine in xerbla.f90 include:
!  - The use of a XERBLA_HANDLE module (see file xerbla_handle.f90) to allow a
! global state for deciding whether subroutine XERBLA() should call "STOP"
! or not. See local modification note in the source below.
!  - The source now compiles under (though does not comply with) Fortran 90
! standards.
! -----------------------------------------------------------------------------

!> \brief \b XERBLA
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE XERBLA( SRNAME, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER*(*)      SRNAME
!       INTEGER            INFO
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> XERBLA  is an error handler for the LAPACK routines.
!> It is called by an LAPACK routine if an input parameter has an
!> invalid value.  A message is printed and execution stops.
!>
!> Installers may consider modifying the STOP statement in order to
!> call system-specific exception-handling facilities.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] SRNAME
!> \verbatim
!>          SRNAME is CHARACTER*(*)
!>          The name of the routine which called XERBLA.
!> \endverbatim
!>
!> \param[in] INFO
!> \verbatim
!>          INFO is INTEGER
!>          The position of the invalid parameter in the parameter list
!>          of the calling routine.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2011
!
!> \ingroup aux_blas
!
!  =====================================================================
      SUBROUTINE XERBLA( SRNAME, INFO )
      USE XERBLA_HANDLE, ONLY: GET_XERBLA_DEATH_SWITCH, SET_XERBLA_DEATH_SWITCH
!
!  -- Reference BLAS level1 routine (version 3.4.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2011
!
!     .. Scalar Arguments ..
      CHARACTER*(*)      SRNAME
      INTEGER            INFO
!     ..
!
! =====================================================================
!
!     .. Intrinsic Functions ..
      INTRINSIC          LEN_TRIM
!     ..
!     .. Executable Statements ..
!
      print*,"IN XERBLA FROM SRC/LAPACK"
      WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
!
! Local modification, stop is only called if xerbla death switch is non-zero
!
! Copyright (C) 2014 - present by OpenGamma Inc. and the OpenGamma group of companies
!
! Please see distribution for licence.
!
      IF(GET_XERBLA_DEATH_SWITCH()/=0)THEN
        STOP
      ENDIF
! End local modification.

!
 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ',&
           'an illegal value' )
!
!     End of XERBLA
!
      END

max_stars_repo_name: stuartarchibald/OG-Lapack

max_issues_repo_name: stuartarchibald/OG-Lapack

max_forks_repo_name: stuartarchibald/OG-Lapack


text:
A Davis legend.  Tao is a Dubstep / Drum and Bass DJ that can often be found playing at large events as a headliner.

I saw this cat spin at Delta last week, it was super heavy... Super heavy...  With some clean transitions to boot... There is one song I really want to find that I heard.  Users/StevenDaubert

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
!!# USER MODULE  <<USR_Block>>
MODULE USR_Block

!!## PURPOSE
!! Defines the block type (TYPE_Block).  This type is a
!! doubly-linked list with dynamic string, integer, and
!! REAL(KIND_R) components.  It is very versatile and can
!! be used for a variety of jobs.

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R,KIND_L,KIND_I,KIND_S !!((01-A-KND_IntrinsicTypes.f90))

!!## EXTERNAL PROCEDURES
USE SUB_CLEAR                                            !!((04-A-SUB_CLEAR.f90))
USE FUN_Sentence                                         !!((04-B-FUN_Sentence.f90))
USE SUB_Reallocate                                       !!((04-B-SUB_Reallocate.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## EXTERNAL PARAMETERS
INTEGER,PARAMETER :: LEN_S  = 128
PUBLIC :: KIND_R,KIND_L,KIND_I,KIND_S,LEN_S

!!## DERIVED TYPE DECLARATION
TYPE TYPE_Block
 INTEGER        (      KIND_I),POINTER :: I(:)  => NULL()
 CHARACTER      (LEN_S,KIND_S),POINTER :: S(:)  => NULL()
 REAL           (      KIND_R),POINTER :: R(:)  => NULL()
 LOGICAL        (      KIND_L),POINTER :: L(:)  => NULL()
 TYPE(TYPE_Block)             ,POINTER :: PREV  => NULL()
 TYPE(TYPE_Block)             ,POINTER :: NEXT  => NULL()
END TYPE

!!## PROCEDURE OVERLOADING
INTERFACE ALLOCATE
 MODULE PROCEDURE ALLOCATE0_Block
 MODULE PROCEDURE ALLOCATE1_Block
END INTERFACE

INTERFACE NULLIFY
 MODULE PROCEDURE NULLIFY_Block
ENDINTERFACE

! NOTE: This name was changed in triage so that it didn't coincide with
! iso_varying_string's insert which is a function. Apparently you can't
! have an interface that results in something as a function and subroutine
! with the same name.
INTERFACE INSERT_BLOCK
 MODULE PROCEDURE INSERT0_Block
 MODULE PROCEDURE INSERT1_Block
END INTERFACE

INTERFACE OVERWRITE
 MODULE PROCEDURE OVERWRITE0_Block
 MODULE PROCEDURE OVERWRITE1_Block
END INTERFACE

INTERFACE APPEND
 MODULE PROCEDURE APPEND0_Block
 MODULE PROCEDURE APPEND1_Block
END INTERFACE

INTERFACE DEALLOCATE
 MODULE PROCEDURE DEALLOCATE_Block
END INTERFACE

INTERFACE RELEASE
 MODULE PROCEDURE RELEASE0_Block
 MODULE PROCEDURE RELEASE1_Block
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: TYPE_Block
PUBLIC :: ALLOCATE
PUBLIC :: NULLIFY
PUBLIC :: INSERT_BLOCK
PUBLIC :: OVERWRITE
PUBLIC :: APPEND
PUBLIC :: DEALLOCATE
PUBLIC :: RELEASE

!!## MODULE PROCEDURES
CONTAINS

SUBROUTINE ALLOCATE0_Block(Block,I,S,R,L,PREV,NEXT)
!PURPOSE
!! Allocate the Block type with scalar I, S, L, and R.

!ARGUMENTS
TYPE(TYPE_Block)            ,POINTER    :: Block
INTEGER(KIND_I)    ,OPTIONAL,INTENT(IN) :: I
CHARACTER(*,KIND_S),OPTIONAL,INTENT(IN) :: S
REAL(KIND_R)       ,OPTIONAL,INTENT(IN) :: R
LOGICAL(KIND_L)    ,OPTIONAL,INTENT(IN) :: L
TYPE(TYPE_Block)   ,OPTIONAL,POINTER    :: PREV
TYPE(TYPE_Block)   ,OPTIONAL,POINTER    :: NEXT
!

ALLOCATE(Block)

!integer part
IF( PRESENT(I) )THEN
 ALLOCATE(Block%I(1)) ; Block%I = I
ELSE
 Block%I => NULL()
ENDIF

!string part
IF( PRESENT(S) )THEN
 Block%S => ptr_BlockConvert( S )
ELSE
 Block%S => NULL()
ENDIF

!real part
IF( PRESENT(R) )THEN
 ALLOCATE(Block%R(1)) ; Block%R = R
ELSE
 Block%R => NULL()
ENDIF

!logical part
IF( PRESENT(L) )THEN
 ALLOCATE(Block%L(1)) ; Block%L = L
ELSE
 Block%L => NULL()
ENDIF

!previous pointer
IF( PRESENT(PREV) )THEN
 Block%PREV => PREV
ELSE
 Block%PREV => NULL()
ENDIF

!next pointer
IF( PRESENT(NEXT) )THEN
 Block%NEXT => NEXT
ELSE
 Block%NEXT => NULL()
ENDIF

!
END SUBROUTINE

FUNCTION ptr_BlockConvert(S) RESULT(A1S)
CHARACTER(*,KIND=KIND_S),INTENT(IN) :: S
CHARACTER(LEN=LEN_S,KIND=KIND_S),POINTER :: A1S(:)
INTEGER :: i1,i2,is,ns

!!--begin--
ns = LEN_TRIM(S)/LEN_S + 1
ALLOCATE( A1S(1:ns) )
CALL CLEAR( A1S )
i1 = 1
DO is=1,ns
 i2 = i1 + LEN_S-1
 IF( i2>LEN_TRIM(S) )i2 = LEN_TRIM(S)
 A1S(is) = S(i1:i2)
 i1 = i2 + 1
 IF( i1>LEN_TRIM(S) )EXIT
END DO
!!--end--
END FUNCTION

SUBROUTINE ALLOCATE1_Block(Block,I,S,R,L,PREV,NEXT)
!PURPOSE
!! Allocate the Block type with arrays I, R, L, and scalar
!! string S.

!ARGUMENTS
TYPE(TYPE_Block)            ,POINTER    :: Block
INTEGER(KIND_I)    ,         INTENT(IN) :: I(:)
CHARACTER(*,KIND_S),OPTIONAL,INTENT(IN) :: S
REAL(KIND_R)       ,OPTIONAL,INTENT(IN) :: R(:)
LOGICAL(KIND_L)    ,OPTIONAL,INTENT(IN) :: L(:)
TYPE(TYPE_Block)   ,OPTIONAL,POINTER    :: PREV
TYPE(TYPE_Block)   ,OPTIONAL,POINTER    :: NEXT

!
ALLOCATE(Block)

!integer part
IF( SIZE(I)==0 )THEN
 Block%I => NULL()
ELSE
 ALLOCATE(Block%I(1:SIZE(I))) ; Block%I = I
END IF

!string part
IF( PRESENT(S) )THEN
 Block%S => ptr_BlockConvert(S)
ELSE
 Block%S => NULL()
ENDIF

!real part
IF( PRESENT(R) )THEN
 ALLOCATE(Block%R(1:SIZE(R))) ; Block%R = R
ELSE
 Block%R => NULL()
ENDIF

!logical part
IF( PRESENT(L) )THEN
 ALLOCATE(Block%L(1:SIZE(L))) ; Block%L = L
ELSE
 Block%L => NULL()
ENDIF

!previous pointer
IF( PRESENT(PREV) )THEN
 Block%PREV => PREV
ELSE
 Block%PREV => NULL()
ENDIF

!next pointer
IF( PRESENT(NEXT) )THEN
 Block%NEXT => NEXT
ELSE
 Block%NEXT => NULL()
ENDIF

!
END SUBROUTINE

SUBROUTINE INSERT0_Block(Block,I,S,R,L)
!PURPOSE
!! Insert a new block to %PREV of the passed Block, reconnecting
!! the pointers appropriately.
!ARGUMENTS
TYPE(TYPE_Block)            ,POINTER    :: Block
INTEGER(KIND_I)             ,INTENT(IN) :: I
CHARACTER(*,KIND_S),OPTIONAL,INTENT(IN) :: S
REAL(KIND_R)       ,OPTIONAL,INTENT(IN) :: R
LOGICAL(KIND_L)    ,OPTIONAL,INTENT(IN) :: L
!LOCALS
TYPE(TYPE_Block),POINTER :: prevBlock
!
IF( ASSOCIATED(Block) )THEN
 !possible redirection to OVERWRITE
 IF( ASSOCIATED(Block%I) )THEN
  IF( Block%I(1)==-HUGE(I) )THEN
   CALL OVERWRITE0_Block( Block , I , S , R , L )
   RETURN
  ENDIF
 ENDIF

 !INSERT part
 prevBlock    => Block%PREV
 Block % PREV => NULL()
 CALL ALLOCATE0_Block( Block % PREV , I , S , R , L , PREV=prevBlock , NEXT=Block )
 IF( ASSOCIATED(prevBlock) )THEN
  prevBlock % NEXT => Block % PREV
 ENDIF
ELSE
 CALL ALLOCATE0_Block( Block , I , S , R , L , PREV=NULL(Block) , NEXT=NULL(Block) )
ENDIF
!
END SUBROUTINE

SUBROUTINE INSERT1_Block(Block,I,S,R,L)
!PURPOSE
!! Insert a new block to %PREV of the passed Block, reconnecting
!! the pointers appropriately.
!ARGUMENTS
TYPE(TYPE_Block)            ,POINTER    :: Block
INTEGER(KIND_I)    ,OPTIONAL,INTENT(IN) :: I(:)
CHARACTER(*,KIND_S),OPTIONAL,INTENT(IN) :: S
LOGICAL(KIND_L)    ,OPTIONAL,INTENT(IN) :: L(:)
REAL(KIND_R)       ,OPTIONAL,INTENT(IN) :: R(:)
!LOCALS
TYPE(TYPE_Block),POINTER :: prevBlock
!
IF( ASSOCIATED(Block) )THEN

 !possible redirection to OVERWRITE
 IF( ASSOCIATED(Block%I) )THEN
  IF( Block%I(1)==-HUGE(I) )THEN
   CALL OVERWRITE( Block , I , S , R , L )
   RETURN
  ENDIF
 ENDIF

 !INSERT part
 prevBlock    => Block%PREV
 Block % PREV => NULL()
 CALL ALLOCATE1_Block( Block % PREV , I , S , R , L , PREV=prevBlock , NEXT=Block )
 IF( ASSOCIATED(prevBlock) )THEN
  prevBlock % NEXT => Block % PREV
 ENDIF

ELSE
 CALL ALLOCATE1_Block( Block , I , S , R , L , PREV=NULL(Block) , NEXT=NULL(Block) )
ENDIF
!
END SUBROUTINE

SUBROUTINE APPEND0_Block(Block,I,S,R,L)
!PURPOSE
!! Append a new block to %NEXT of the passed Block, reconnecting
!! the pointers appropriately.
!ARGUMENTS
TYPE(TYPE_Block)            ,POINTER    :: Block
INTEGER(KIND_I)             ,INTENT(IN) :: I
CHARACTER(*,KIND_S),OPTIONAL,INTENT(IN) :: S
REAL(KIND_R)       ,OPTIONAL,INTENT(IN) :: R
LOGICAL(KIND_L)    ,OPTIONAL,INTENT(IN) :: L
!LOCALS
TYPE(TYPE_Block),POINTER :: nextBlock
!
IF( ASSOCIATED(Block) )THEN
 !possible redirection to OVERWRITE
 IF( ASSOCIATED(Block%I) )THEN
  IF( Block%I(1)==-HUGE(I) )THEN
   CALL OVERWRITE0_Block( Block , I , S , R , L )
   RETURN
  ENDIF
 ENDIF

 !APPEND part
 nextBlock     => Block%NEXT
 Block % NEXT  => NULL()
 CALL ALLOCATE0_Block( Block % NEXT , I , S , R , L , PREV=Block , NEXT=nextBlock)
 IF( ASSOCIATED(nextBlock) )THEN
  nextBlock % PREV => Block % NEXT
 ENDIF
ELSE
 CALL ALLOCATE0_Block( Block , I , S , R , L , PREV=NULL(Block) , NEXT=NULL(Block) )
ENDIF
!
END SUBROUTINE

SUBROUTINE APPEND1_Block(Block,I,S,R,L)
!PURPOSE
!! Append a new block to %NEXT of the passed Block, reconnecting
!! the pointers appropriately.
!ARGUMENTS
TYPE(TYPE_Block)            ,POINTER    :: Block
INTEGER(KIND_I)             ,INTENT(IN) :: I(:)
CHARACTER(*,KIND_S),OPTIONAL,INTENT(IN) :: S
REAL(KIND_R)       ,OPTIONAL,INTENT(IN) :: R(:)
LOGICAL(KIND_L)    ,OPTIONAL,INTENT(IN) :: L(:)
!LOCALS
TYPE(TYPE_Block),POINTER :: nextBlock
!
!possible redirection to OVERWRITE
IF( ASSOCIATED(Block) )THEN

 IF( ASSOCIATED(Block%I) )THEN
  IF( Block%I(1)==-HUGE(I) )THEN
   CALL OVERWRITE( Block , I , S , R , L )
   RETURN
  ENDIF
 ENDIF

 !APPEND part
 nextBlock     => Block%NEXT
 Block % NEXT  => NULL()
 CALL ALLOCATE1_Block( Block % NEXT , I , S , R , L , PREV=Block , NEXT=nextBlock)
 IF( ASSOCIATED(nextBlock) )THEN
  nextBlock % PREV => Block % NEXT
 ENDIF

ELSE
 CALL ALLOCATE1_Block( Block , I , S , R , L , PREV=NULL(Block) , NEXT=NULL(Block) )
ENDIF
!
END SUBROUTINE

SUBROUTINE OVERWRITE0_Block(Block,I,S,R,L)
!PURPOSE
!! Modify the I, S, R, L components of Block with scalar
!! arguments, overwriting all components with present arguments
!! and deallocating ones without present arguments.
!ARGUMENTS
TYPE(TYPE_Block)            ,POINTER    :: Block
INTEGER(KIND_I)             ,INTENT(IN) :: I
CHARACTER(*,KIND_S),OPTIONAL,INTENT(IN) :: S
REAL(KIND_R)       ,OPTIONAL,INTENT(IN) :: R
LOGICAL(KIND_L)    ,OPTIONAL,INTENT(IN) :: L
!LOCALS
INTEGER :: ns,jerr
!
IF( ASSOCIATED(Block) )THEN

 !integer part
 IF( ASSOCIATED(Block%I) )DEALLOCATE( Block%I , STAT=jerr )
 ALLOCATE(Block%I(1))
 Block%I = I

 !string part
 IF( ASSOCIATED(Block%S) )DEALLOCATE( Block%S , STAT=jerr )
 IF( PRESENT(S) )THEN
  ns = LEN_TRIM(S)/LEN_S + 1
  ALLOCATE( Block%S(1:ns) )
  CALL CLEAR( Block % S )
  Block%S = S
 ENDIF

 !real part
 IF( ASSOCIATED(Block%R) )DEALLOCATE( Block%R , STAT=jerr )
 IF( PRESENT(R) )THEN
  ALLOCATE(Block%R(1))
  Block%R = R
 ENDIF

 !logical part
 IF( ASSOCIATED(Block%L) )DEALLOCATE( Block%L , STAT=jerr )
 IF( PRESENT(L) )THEN
  ALLOCATE(Block%L(1))
  Block%L = L
 ENDIF

ELSE
 CALL ALLOCATE0_Block( Block , I , S , R , L , PREV=NULL(Block) , NEXT=NULL(Block) )
ENDIF
!
END SUBROUTINE

SUBROUTINE OVERWRITE1_Block(Block,I,S,R,L)
!PURPOSE
!! Modify the I, S, R, L components of Block with array
!! arguments, overwriting all components with present arguments
!! and deallocating ones without present arguments.
!ARGUMENTS
TYPE(TYPE_Block)            ,POINTER    :: Block
INTEGER(KIND_I)    ,OPTIONAL,INTENT(IN) :: I(:)
CHARACTER(*,KIND_S),OPTIONAL,INTENT(IN) :: S
REAL(KIND_R)       ,OPTIONAL,INTENT(IN) :: R(:)
LOGICAL(KIND_L)    ,OPTIONAL,INTENT(IN) :: L(:)
!LOCALS
INTEGER :: ns
!
IF( ASSOCIATED(Block) )THEN

 !integer part
 IF( ASSOCIATED(Block%I) )DEALLOCATE( Block%I )
 ALLOCATE(Block%I(1:SIZE(I)))
 Block%I = I

 !string part
 IF( ASSOCIATED(Block%S) )DEALLOCATE( Block%S )
 IF( PRESENT(S) )THEN
  Block%S => ptr_BlockConvert( S )
 ENDIF

 !real part
 IF( ASSOCIATED(Block%R) )DEALLOCATE( Block%R )
 IF( PRESENT(R) )THEN
  ALLOCATE(Block%R(1:SIZE(R)))
  Block%R = R
 ENDIF

 !logical part
 IF( ASSOCIATED(Block%L) )DEALLOCATE( Block%L )
 IF( PRESENT(L) )THEN
  ALLOCATE(Block%L(1:SIZE(L)))
  Block%L = L
 ENDIF

ELSE
 CALL ALLOCATE1_Block( Block , I , S , R , L , PREV=NULL(Block) , NEXT=NULL(Block) )
ENDIF

!
END SUBROUTINE

SUBROUTINE DEALLOCATE_Block(Block)
!PURPOSE
!! Deallocate a Block and connect pointers around it.
!ARGUMENTS
TYPE(TYPE_Block),POINTER :: Block
!LOCALS
TYPE(TYPE_Block),POINTER :: ptr_Block
INTEGER(KIND_I)          :: jerr
!
ptr_Block => Block
IF( ASSOCIATED(Block%PREV) ) Block%PREV%NEXT => ptr_Block%NEXT
IF( ASSOCIATED(Block%NEXT) ) Block%NEXT%PREV => ptr_Block%PREV
Block => Block%PREV
IF( ASSOCIATED(ptr_Block%I) )DEALLOCATE( ptr_Block%I , STAT=jerr )
IF( ASSOCIATED(ptr_Block%S) )DEALLOCATE( ptr_Block%S , STAT=jerr )
IF( ASSOCIATED(ptr_Block%R) )DEALLOCATE( ptr_Block%R , STAT=jerr )
IF( ASSOCIATED(ptr_Block%L) )DEALLOCATE( ptr_Block%L , STAT=jerr )
ptr_Block % PREV => NULL()
ptr_Block % NEXT => NULL()
DEALLOCATE( ptr_Block , STAT=jerr)
!
END SUBROUTINE

SUBROUTINE NULLIFY_Block(Block)
!PURPOSE
!! Nullifies a Block and connect pointers around it.
!ARGUMENTS
TYPE(TYPE_Block),POINTER :: Block
!LOCALS
TYPE(TYPE_Block),POINTER :: ptr_Block
INTEGER(KIND_I)          :: jerr
!
ptr_Block => Block
IF( ASSOCIATED(Block%PREV) ) Block%PREV%NEXT => ptr_Block%NEXT
IF( ASSOCIATED(Block%NEXT) ) Block%NEXT%PREV => ptr_Block%PREV
Block => Block%PREV
NULLIFY( ptr_Block%I )
NULLIFY( ptr_Block%S )
NULLIFY( ptr_Block%R )
NULLIFY( ptr_Block%L )
ptr_Block % PREV => NULL()
ptr_Block % NEXT => NULL()
DEALLOCATE( ptr_Block , STAT=jerr )
!
END SUBROUTINE

SUBROUTINE RELEASE0_Block(Block,I,S,R,L)
!PURPOSE
!! Releases the information in a single Block to the available
!! variables in I, S, R, L, then deallocates the block.
!ARGUMENTS
TYPE(TYPE_Block)            ,POINTER     :: Block
INTEGER(KIND_I)             ,INTENT(OUT) :: I
CHARACTER(*,KIND_S),OPTIONAL,INTENT(OUT) :: S
REAL(KIND_R)       ,OPTIONAL,INTENT(OUT) :: R
LOGICAL(KIND_L)    ,OPTIONAL,INTENT(OUT) :: L
!local
CHARACTER(LEN_S,KIND_S),POINTER :: S_(:)
!
!integer part
IF( ASSOCIATED(Block%I) )THEN
 I = Block%I(1)
ELSE
 I = -HUGE(I)
ENDIF

!string part
IF( PRESENT(S) )THEN
 IF( ASSOCIATED(Block%S) )THEN
  S_ => Block%S
  S = Sentence( S_ , delim="" )
  S_ => NULL()
 ELSE
  CALL CLEAR(S)
 ENDIF
ENDIF

!real part
IF( PRESENT(R) )THEN
 IF( ASSOCIATED(Block%R) )THEN
  R = Block%R(1)
 ELSE
  R = REAL(0,KIND_R)
 ENDIF
ENDIF

!logical part
IF( PRESENT(L) )THEN
 IF( ASSOCIATED(Block%L) )THEN
  L = Block%L(1)
 ELSE
  L = .FALSE._KIND_L
 ENDIF
ENDIF

!deallocate the block
CALL DEALLOCATE( Block )

!
END SUBROUTINE

SUBROUTINE RELEASE1_Block(Block,I,S,R,L)
!!#### PURPOSE
!! Releases the information in a single Block to the available
!! pointer variables in I, S, R, L, then nullify the block.
!ARGUMENTS
TYPE(TYPE_Block)            ,POINTER :: Block
INTEGER(KIND_I)    ,OPTIONAL,POINTER :: I(:)
CHARACTER(*,KIND_S),OPTIONAL,POINTER :: S(:)
REAL(KIND_R)       ,OPTIONAL,POINTER :: R(:)
LOGICAL(KIND_L)    ,OPTIONAL,POINTER :: L(:)
!
!integer part
IF( PRESENT(I) ) I => Block%I

!string part
IF( PRESENT(S) ) S => Block%S

!real part
IF( PRESENT(R) ) R => Block%R

!logical part
IF( PRESENT(L) ) L => Block%L

!deallocate the block
CALL NULLIFY( Block )

!
END SUBROUTINE

END MODULE

max_stars_repo_name: wawiesel/tapack

max_issues_repo_name: wawiesel/tapack

max_forks_repo_name: wawiesel/tapack


text:
! S07-alternate-return-argument.f90
! An alternate-return dummy argument in a subroutine statement
! causes the front end to fail an assertion in 'generateImplicitType'.

subroutine g(*)  ! assertion failure
  return 1
end subroutine

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
      SUBROUTINE MB03DZ( A, LDA, B, LDB, CO1, SI1, CO2, SI2 )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute unitary matrices Q1 and Q2 for a complex 2-by-2 regular
C     pencil aA - bB with A, B upper triangular, such that
C     Q2' (aA - bB) Q1 is still upper triangular but the eigenvalues are
C     in reversed order. The matrices Q1 and Q2 are represented by
C
C          (  CO1  SI1  )       (  CO2  SI2  )
C     Q1 = (            ), Q2 = (            ).
C          ( -SI1' CO1  )       ( -SI2' CO2  )
C
C     The notation M' denotes the conjugate transpose of the matrix M.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     A       (input) COMPLEX*16 array, dimension (LDA, 2)
C             On entry, the leading 2-by-2 upper triangular part of
C             this array must contain the matrix A of the pencil.
C             The (2,1) entry is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= 2.
C
C     B       (input) COMPLEX*16 array, dimension (LDB, 2)
C             On entry, the leading 2-by-2 upper triangular part of
C             this array must contain the matrix B of the pencil.
C             The (2,1) entry is not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= 2.
C
C     CO1     (output) DOUBLE PRECISION
C             The upper left element of the unitary matrix Q1.
C
C     SI1     (output) COMPLEX*16
C             The upper right element of the unitary matrix Q1.
C
C     CO2     (output) DOUBLE PRECISION
C             The upper left element of the unitary matrix Q2.
C
C     SI2     (output) COMPLEX*16
C             The upper right element of the unitary matrix Q2.
C
C     METHOD
C
C     The algorithm uses unitary transformations as described on page 42
C     in [1].
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, January 26, 2009.
C
C     REVISIONS
C
C     V. Sima, Aug. 2009 (SLICOT version of the routine ZBTUEX).
C     V. Sima, Nov. 2009, Nov. 2010, Dec. 2010.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue exchange, matrix pencil, upper triangular matrix.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER            LDA, LDB
      DOUBLE PRECISION   CO1, CO2
      COMPLEX*16         SI1, SI2
C
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * )
C
C     .. Local Scalars ..
      COMPLEX*16         D, G, TMP
C
C     .. External Subroutines ..
      EXTERNAL           ZLARTG
C
C     .. Executable Statements ..
C
C     For efficiency, the input arguments are not tested.
C
C     Computations.
C
      G = A( 1, 1 )*B( 2, 2 ) - A( 2, 2 )*B( 1, 1 )
      D = A( 1, 2 )*B( 2, 2 ) - A( 2, 2 )*B( 1, 2 )
      CALL ZLARTG( D, G, CO1, SI1, TMP )
      D = A( 1, 2 )*B( 1, 1 ) - A( 1, 1 )*B( 1, 2 )
      CALL ZLARTG( D, G, CO2, SI2, TMP )
C
      RETURN
C *** Last line of MB03DZ ***
      END

max_stars_repo_name: bgin/MissileSimulation

max_issues_repo_name: bgin/MissileSimulation

max_forks_repo_name: bgin/MissileSimulation


text:
C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
C NAME
C     panel_diagonal -- Locate the piece of the diagonal running through
C     the panel.
C
C REVISION
C     $Id$
C
C SYNOPSIS
      Logical function Panel_Diagonal( Ilo, Ihi, Jlo, Jhi, Dlo, Dhi)
      Implicit NONE
      Integer Ilo, Ihi, Jlo, Jhi, Dlo, Dhi
C
C ARGUMENTS
C     The panel is described by (Ilo:Ihi, Jlo:Jhi) [IN], and the
C     diagonal contained within the panel is (Dlo:Dhi) [OUT].
C     If the panel does not contain any elements of the diagonal
C     the function returns .FALSE.
C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
C LOCAL VARIABLES
      Integer UR, LL
C
C     Check that the ranges overlap.  These two will be the same sign
C     if the do NOT overlap
C
      UR = Ihi - Jlo
      LL = Ilo - Jhi
C
      If ( UR*LL .gt. 0) then
         Panel_Diagonal = .FALSE.
         Return
      Else
         Panel_Diagonal = .TRUE.
      EndIf
C
C     Now we must locate the overlap of the ranges, since that must
C     be where the diagonal occurs.
C
      Dlo = Max( Ilo, Jlo)
      Dhi = Min( Ihi, Jhi)
C
      Return
      End

max_stars_repo_name: dinisAbranches/nwchem

max_issues_repo_name: dinisAbranches/nwchem

max_forks_repo_name: dinisAbranches/nwchem


text:
+incdir+${PROJECT_LOC}/tests
${PROJECT_LOC}/tests/wb_dma_tests_pkg.sv


text:
!
! Copyright (C) 2001 PWSCF group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!----------------------------------------------------------------------------
SUBROUTINE h_1psi( lda, n, psi, hpsi, spsi )
  !----------------------------------------------------------------------------
  !
  ! ... This routine applies the Hamiltonian and the S matrix
  ! ... to a vector psi and puts the result in hpsi and spsi
  ! ... Wrapper routine - calls h_psi and s_psi
  !
  USE kinds, ONLY: DP

  !
  IMPLICIT NONE
  !
  integer, parameter :: npol=1 !substitute for noncollin_module%npol
  INTEGER           :: lda, n
  COMPLEX (DP) :: psi(lda*npol,1), hpsi(n), spsi(n,1)
  !
  !
  CALL start_clock( 'h_1psi' )
  !
  !OBM: I know this form is somewhat inelegant but, leaving the pre-real_space part intact
  !     makes it easier to debug probable errors, please do not "beautify"
  CALL h_psi( lda, n, 1, psi, hpsi )
  CALL s_psi( lda, n, 1, psi, spsi )
  !
  CALL stop_clock( 'h_1psi' )
  !
  RETURN
  !
END SUBROUTINE h_1psi

max_stars_repo_name: utdsimmons/ohpc

max_issues_repo_name: utdsimmons/ohpc

max_forks_repo_name: utdsimmons/ohpc


SUBROUTINE LocalSmoothing3D(nx,ny,nz,itime,fop)
  !
  ! This subroutine attempts to apply automatic localized smoothing to avoid any
  ! breakdowns due to discontinuities in the free-surface.  We check the Lagrangian
  ! downward vertical acceleration everywhere and when it exceeds a given factor times g
  ! we smooth a 10-point region centered at the point with the classical 3-point
  ! filter [.25 .5 .25].  The feature is turned off by switching the threshold
  ! factor to something larger than 100.
  !
  ! **  This is the initial 3D version with smoothing along x-lines only **
  !
  USE GlobalVariables
  IMPLICIT NONE
  INTEGER :: nx, ny, nz, itime, fop

  ! Local variables and automatic workspace
  INTEGER, SAVE :: i_first=0
  INTEGER ::  i, j, i_flag, N_smoothed, i_smoothed(nx*ny), j_smoothed(nx*ny), k
  REAL(KIND=long)  accel_tol, dt_inv, Max_accel
  REAL(KIND=long), POINTER :: et(:,:), ph(:,:), x(:,:), y(:,:), WHist(:,:,:), etax(:,:),      &
       etay(:,:), hx(:,:), hy(:,:), z(:), h(:,:), EtatHist(:,:,:)
  REAL(KIND=long) :: etatem(nx,ny), Phitem(nx,ny), etatt(nx,ny), alpha_s(nx,ny), Wt(nx,ny),   &
       dWdt(nx,ny)
  REAL(KIND=long) :: U(Nz,Nx,Ny), V(Nz,Nx,Ny), W(Nz,Nx,Ny), Wz(Nz,Nx,Ny), Wx(Nz,Nx,Ny),       &
       Wy(Nz,Nx,Ny), d(Nx,Ny)
  !
  ! Initial set up of the output file
  !
  IF(i_first==0)THEN
     i_first=1
     OPEN(fop,file='local.smoothing',status='unknown')
     WRITE(fop,10)accel_tol_fact
10   FORMAT('# Points where Lagrangian -dw/dt exceeded',e10.2, &
          ' times g and local smoothing was applied:  t, x, y, dw/dt')
  END IF
  !
  ! Do nothing for a factor larger than 100
  !
  IF(accel_tol_fact .le. 100. .and. itime .ge. 3)THEN
     !
     ! Search for high accelerations and smooth an area around points where they occur.
     !
     !
     ! Initialize
     !
     x => FineGrid%x; y => FineGrid%y; et => WaveField%E; ph => WaveField%P; WHist => WaveField%WHist;
     etax => WaveField%Ex; etay => WaveField%Ey; hx => FineGrid%hx; hy => FineGrid%hy;
     z => FineGrid%z; h => FineGrid%h; EtatHist => WaveField%EtatHist;
     etatem=et
     Phitem=ph
     alpha_s=zero
     Do j=1,Ny
        Do i=1,Nx
           d(i,j)=h(i,j)+etatem(i,j);
        end Do
     End Do
     !
     ! Take the computational-space derivatives of phi
     !
     CALL DiffXEven(phi,U,1,FineGrid%Nx+2*GhostGridX,FineGrid%Ny+2*GhostGridY,  &
          FineGrid%Nz+GhostGridZ,FineGrid%DiffStencils,alpha)
     CALL DiffXEven(phi,V,1,FineGrid%Nx+2*GhostGridX,FineGrid%Ny+2*GhostGridY,  &
          FineGrid%Nz+GhostGridZ,FineGrid%DiffStencils,beta)
     CALL DiffZArbitrary(phi,W,1,FineGrid%Nx+2*GhostGridX,FineGrid%Ny+2*GhostGridY,  &
          FineGrid%Nz+GhostGridZ,FineGrid%DiffStencils,gamma)
     !
     ! Form the Eulerian fluid velocities
     !
     Do j=1,Ny
        Do i=1,Nx
           Do k=1,Nz
              W(k,i,j) = W(k,i,j)/d(i,j)
              U(k,i,j) = U(k,i,j) + ((1-z(k))*hx(i,j)-z(k)*etax(i,j))*W(k,i,j)
              V(k,i,j) = V(k,i,j) + ((1-z(k))*hy(i,j)-z(k)*etay(i,j))*W(k,i,j)
           END Do
        END Do
     END Do
     !
     ! Take computational-space derivatives of w and convert to physical-space derivatives.
     !
     CALL DiffZArbitrary(W,Wz,1,FineGrid%Nx+2*GhostGridX,FineGrid%Ny+2*GhostGridY,  &
          FineGrid%Nz+GhostGridZ,FineGrid%DiffStencils,gamma)
     CALL DiffXEven(W,Wx,1,FineGrid%Nx+2*GhostGridX,FineGrid%Ny+2*GhostGridY,  &
          FineGrid%Nz+GhostGridZ,FineGrid%DiffStencils,alpha)
     CALL DiffYEven(W,Wy,1,FineGrid%Nx+2*GhostGridX,FineGrid%Ny+2*GhostGridY,  &
          FineGrid%Nz+GhostGridZ,FineGrid%DiffStencils,beta)
     Do j=1,Ny
        Do i=1,Nx
           Do k=1,Nz
              Wz(k,i,j) = Wz(k,i,j)/d(i,j)
              Wx(k,i,j) = Wx(k,i,j) + ((1-z(k))*hx(i,j)-z(k)*etax(i,j))*Wz(k,i,j)
              Wy(k,i,j) = Wy(k,i,j) + ((1-z(k))*hy(i,j)-z(k)*etay(i,j))*Wz(k,i,j)
           END Do
        END Do
     END DO
     !
     ! Take a 3-point one-sided difference to get the computational-space dw/dt at the
     ! current time step and convert it to a physical-space dw/dt.   This is only done
     ! on the free-surface, i.e. at vertical grid point k=nz.
     !
     dt_inv=one/dt
     Do j=1,Ny
        DO i=1,nx
           Wt(i,j)=half*dt_inv*(three*WHist(i,j,1)-four*WHist(i,j,2)+WHist(i,j,3)) &
                -Wz(Nz,i,j)*EtatHist(i,j,1)
        END Do
     END DO
     !
     ! Form the vertical particle acceleration on the free-surface, (the Lagrangian dw/dt).
     !
     Do j=1,Ny
        DO i=1,nx
           Wt(i,j)=Wt(i,j)+U(Nz,i,j)*Wx(Nz,i,j) + V(Nz,i,j)*Wy(Nz,i,j) + W(Nz,i,j)*Wz(Nz,i,j)
        END DO
     END Do
     !
     ! First build a coefficient vector which is .25 at those points which surround a point
     ! of high accelerations.
     !
     accel_tol=accel_tol_fact*g
     i_flag=0
     N_smoothed=0; Max_accel=zero;
     Do j=1,ny
        DO i=6,nx-5
           !
           ! If the downward vertical acceleration exceeds the tolerance, we smooth.
           !
           IF(-Wt(i,j) >= accel_tol)THEN
              i_flag=1
              N_smoothed=N_smoothed+1
              i_smoothed(N_smoothed)=i
              j_smoothed(N_smoothed)=j
              alpha_s(i-5:i+5,j)=0.25_long
           END IF
        END DO
     END Do
     IF(i_flag==1)THEN
        !
        ! Smooth the elevation and surface velocity.
        !
        Do j=1,ny
           DO i=2,nx-1
              et(i,j)=alpha_s(i,j)*etatem(i-1,j)+(one-two*alpha_s(i,j))*etatem(i,j) &
                   +alpha_s(i,j)*etatem(i+1,j)
              ph(i,j)=alpha_s(i,j)*Phitem(i-1,j)+(one-two*alpha_s(i,j))*Phitem(i,j) &
                   +alpha_s(i,j)*Phitem(i+1,j)
           END DO
        END Do
        !
        ! Write the positions where smoothing was applied and the accelerations found.
        !
        WRITE(fop,11)
        DO i=1,N_smoothed
           WRITE(fop,12)(itime-1)*dt,x(i_smoothed(i),j_smoothed(i)),                &
                y(i_smoothed(i),j_smoothed(i)),Wt(i_smoothed(i),j_smoothed(i))
        END DO
11      FORMAT()
12      FORMAT(4e16.4)
     END IF

  END IF
  RETURN
END SUBROUTINE LocalSmoothing3D


text:
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Convert from camera coordinates (line,sample) to ring plane coordinates
C (radius,longitude) for a perspective projection camera system.  The
C line-sample coordinates are assumed to be in object space.
C
      SUBROUTINE RING_INV(OM,VSC,FL,OAL,OAS,SCALE,RLINE,RSAMP,
     &		radius,rlon,ind)
      IMPLICIT NONE
      REAL*8 OM(3,3)		!Camera to planet transformation matrix
      REAL*8 VSC(3)		!Vector from target center to spacecraft (RS)
      REAL*4 FL			!Camera focal length in mm
      REAL*4 OAL,OAS		!Optical axis intercept line-sample
      REAL*4 SCALE 		!Picture scale in pixels/mm
      REAL*8 RLINE,RSAMP 	!Input image coordinates
      REAL*8 RADIUS,RLON	!Output ring coordinates.
      INTEGER*4 IND		! =1 If RADIUS,RLON are valid, =0 otherwise

      REAL*8 x0,y0,z0,xc,yc,zc,x,y,S
      REAL*8 PI/3.141592653589793D0/,DPR

      DPR = 180.D0/PI          !degrees per radian

C     ...Vector from spacecraft to point on ring in camera coordinate system
      x0 = RSAMP - OAS
      y0 = RLINE - OAL
      z0 = FL*SCALE
C     ...Convert vector to target-centered coordinates
      xc = OM(1,1)*x0 + OM(2,1)*y0 + OM(3,1)*z0
      yc = OM(1,2)*x0 + OM(2,2)*y0 + OM(3,2)*z0
      zc = OM(1,3)*x0 + OM(2,3)*y0 + OM(3,3)*z0

      S = -VSC(3)/zc		!Scale in km per pixel
      IF (S.LT.0.) THEN		!Camera is looking away from ring plane
	IND = 0
        RETURN
      ENDIF

      X = S*xc + VSC(1)
      Y = S*yc + VSC(2)
      RADIUS = DSQRT(X**2+Y**2)
      RLON = - DMOD(DATAN2(Y,X)*DPR,360.D0)	!West longitude
      IF (RLON .LT. 0.D0) RLON= RLON+360.D0
      IND = 1
      RETURN
      END

max_stars_repo_name: NASA-AMMOS/VICAR

max_issues_repo_name: NASA-AMMOS/VICAR

max_forks_repo_name: NASA-AMMOS/VICAR


text:
C******************************************************************************
C
      PROGRAM EXAMPLE2
      IMPLICIT NONE
      REAL ::           AA(10),SPS,CPS,BB(3),PSI,CC(18)
      COMMON /GEOPACK1/ AA,SPS,CPS,BB,PSI,CC
C
c be sure to include an EXTERNAL statement with the names of (i) a magnetospheric
c external field model and (ii) Earth's internal field model.
c
      EXTERNAL DIP_08
      EXTERNAL IGRF_GSW_08
      EXTERNAL TA_2015_B
C
C  X,Y,Z Locations
C
      REAL*8, DIMENSION(10) :: PARMOD

      INTEGER, PARAMETER :: ounit=20
      INTEGER, PARAMETER :: iunit=21
      INTEGER :: i, j, k
      INTEGER, PARAMETER :: DIMX=600
      INTEGER, PARAMETER :: DIMY=1
      INTEGER, PARAMETER :: DIMZ=600

      INTEGER, PARAMETER :: LIMR=1.5
      REAL*8 :: D2 = 0.D0
      REAL*8 :: R2 = 0.D0
      REAL*8 :: Z = 0.D0

      REAL*8, DIMENSION(DIMX) :: XGSW
      REAL*8, DIMENSION(DIMY) :: YGSW
      REAL*8, DIMENSION(DIMZ) :: ZGSW

      REAL*8 :: PS    = 0.D0
      REAL*8 :: BXGSW = 0.D0
      REAL*8 :: BYGSW = 0.D0
      REAL*8 :: BZGSW = 0.D0
      REAL   :: HXGSW = 0.D0
      REAL   :: HYGSW = 0.D0
      REAL   :: HZGSW = 0.D0
      REAL   :: IXGSW = 0.D0
      REAL   :: IYGSW = 0.D0
      REAL   :: IZGSW = 0.D0

      REAL*8 :: Xbeg = -40.D0
      REAL*8 :: Ybeg = 0.D0
      REAL*8 :: Zbeg = -30.D0
      REAL*8 :: dx = 0.1D0
      REAL*8 :: dy = 0.D0
      REAL*8 :: dz = 0.1D0

      INTEGER :: IOPT
      INTEGER :: Year
      INTEGER :: DOY
      INTEGER :: Hour
      INTEGER :: Minute
      REAL :: PDYN
      REAL :: DST
      REAL :: TI
      REAL :: B0y
      REAL :: B0z
      REAL :: XIND
      REAL :: VGSEX
      REAL :: VGSEY
      REAL :: VGSEZ
      REAL :: N
      REAL :: B

      INTEGER :: status
      INTEGER :: ID
      CHARACTER(len=10) :: filename
      CHARACTER(len=10) :: inputfile
      CHARACTER(len=6) :: outfolder

      print *, '  enter filename of input'
      read*, inputfile
C Automatic output folder choosing for reference case
      IF (inputfile == 'reference') THEN
            outfolder = 'refout'
      ELSE
            outfolder = 'output'
      ENDIF

C XIND: solar-wind-magnetosphere driving index,
C Typical values of XIND: between 0 (quiet) and 2 (strongly disturbed)
      DO k = 1, DIMZ
        ZGSW (k) = Zbeg + (k-1)*dz
      ENDDO
      DO j = 1, DIMY
        YGSW (j) = Ybeg + (j-1)*dy
      ENDDO
      DO i = 1, DIMX
        XGSW (i) = Xbeg + (i-1)*dx
      ENDDO
C
C   First, call RECALC_08, to define the main field coefficients and, hence, the magnetic
C      moment of the geodipole for IYEAR=1997 and IDAY=350.
C   The universal time and solar wind direction does not matter in this example,
C   because here we explicitly specify the tilt angle (hence, the orientation of
C   dipole in the GSW coordinates), so we arbitrarily set IHOUR=MIN=ISEC=0 and
C   VGSEX=-400.0, VGSEY=VGSEZ=0 (any other values would be equally OK):
C
C      CALL RECALC_08 (2004,129,9,0,0,-400.0,0.0,0.0)
C
C  Specify the dipole tilt angle PS, its sine SPS and cosine CPS, entering
c    in the common block /GEOPACK1/:
C

      OPEN (UNIT=iunit,FILE=inputfile,ACTION="read")

C Skip first line with column names
      read(iunit,*)

      DO
        read(iunit,*,IOSTAT=status) ID,Year,DOY,Hour,Minute,
     *  B0y,B0z,VGSEX,VGSEY,VGSEZ,PDYN,DST,N,B

        write(*, *) 'generating file', ID

       CALL RECALC_08 (Year,DOY,Hour,Minute,0,VGSEX,VGSEY,VGSEZ)

C        PS    = 0.D0
        BXGSW = 0.D0
        BYGSW = 0.D0
        BZGSW = 0.D0
        XIND = B

        IF (status < 0) THEN
          ! In case end of file is reached
          EXIT
        END IF
C Specify name of output file
        IF (ID < 10) THEN
          write (filename, "(A3,I1,I1,A4)") "OUT",0,ID,".DAT"
        ELSE
          write (filename, "(A3,I2,A4)") "OUT",ID,".DAT"
        ENDIF

C        PSI=TI
        SPS=SIN(PSI)
        CPS=COS(PSI)

        PARMOD(1) = PDYN
        PARMOD(2) = B0y
        PARMOD(3) = B0z
        PARMOD(4) = XIND
        PARMOD(5:10) = (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0 /)
        PS = TI

        OPEN (UNIT=ounit,FILE=outfolder//"/"//filename,ACTION="write",
     *        STATUS="replace")

        DO k = 1, DIMZ
          DO j = 1, DIMY
            DO i = 1, DIMX

              R2 = XGSW(i)*XGSW(i)+YGSW(j)*YGSW(j)+ZGSW(k)*ZGSW(k)

              IF (R2.LT.LIMR) THEN
                D2 = 1 - XGSW(i)*XGSW(i)-YGSW(j)*YGSW(j)
                Z = SQRT(D2)
              ELSE
                Z = ZGSW(k)
              ENDIF

              CALL TA_2015_B (IOPT,PARMOD,PS,
     *                     XGSW(i),YGSW(j),Z,
     *                     BXGSW,BYGSW,BZGSW)
C -- Routines to include internal B field:
              CALL DIP_08 (REAL(XGSW(i)),REAL(YGSW(j)),
     *          REAL(Z),HXGSW,HYGSW,HZGSW)
C            CALL IGRF_GSW_08 (REAL(XGSW(i,j,k)),0.D0,
C     *                   REAL(ZGSW(i,k)),IXGSW,IYGSW,IZGSW)
C -- Save output to file
                WRITE(ounit,*) XGSW(i),YGSW(j),ZGSW(k),
C     *                   BXGSW, BYGSW, BZGSW
     *                   BXGSW+DBLE(HXGSW),!+DBLE(IXGSW),
     *                   BYGSW+DBLE(HYGSW),!+DBLE(IYGSW),
     *                   BZGSW+DBLE(HZGSW)!+DBLE(IZGSW)
          ENDDO
        ENDDO
      ENDDO

      CLOSE(ounit)
      ENDDO
      END

ext: for

max_stars_repo_name: brechtlaperre/Tsyganenko

max_issues_repo_name: brechtlaperre/Tsyganenko

max_forks_repo_name: brechtlaperre/Tsyganenko


text:
 implicit none

 real(4) :: a
 real(8) :: b
 real(16) :: c

 print*,kind(1.),kind(1.d0)
 a=3.14159265358979328e0
 print*,a
 b=3.14159265358979328
 print*,b
 b=3.14159265358979328d0
 print*,b
 c=3.14159265358979328q0
 print*,c

 end

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework


text:
Longboarding is a prominent method of transportation utilized primarily by students in Davis to get from place to place. Longboards are characterized by their longer lengths and widths in comparison to normal skateboarding skateboards.   Longboarding originated back in the 50s as a way to try sidewalk surfing  in California, with the added benefit of getting higher cruising speeds.  Its design allows for smoother, longer strides due to its increased momentum and better balance.  Unfortunately, conventional mainstream skateboard tricks are very difficult, which used to deter many riders from longboards.  Over the last decade, longboards have started regaining popularity with younger riders due to the development of longboard dancing, which is a new interpretation of old school tricks.

Because Davis isnt flat Davis is flat and the streets are so long and straight, longboards are an ideal method of getting around the city and campus and offer a viable alternative to biking.  Their great speed, ease of use and improved balance/smoothness of ride actually makes them preferable to traditional skateboards for many people. Because of their awesome capacity for cruising, it takes a whole lot less exertion than a normal skateboard.  All this of course is at cost of a little bit of manueverability  inexperienced longboarders should avoid flashmob crowds.  A few kicks and away you go!  However, one major drawback for boarding in this town is Sidewalk crack project cracks in the pavement which can easily send a rider down and the board flying.  This isnt usually a problem except at night, mostly because of the light ordinance which makes it downright unsafe for riders when you cant see what youre about to roll over...or into.

The only real place to get a quality longboard in Davis is at Ground Zero, which sells longboards (mostly https://www.sector9.com/ Sector9) ranging from $150 to $300.  The internet is typically a better place to shop and price match for longboards, but you wont be able to test ride different types.  If you do buy one elsewhere, Ground Zero does apply grip tape for just a few bucks.  You can sometimes find great used ones locally on http://sacramento.craigslist.org/search/sss?querylongboard&minAskmin&maxAskmax Craigslist.

I have a sector nine that is super springy, I love it  Users/StevenDaubert


text:
      subroutine DOTPRODUCT(
     &           dotprodout
     &           ,afab
     &           ,iafablo0,iafablo1,iafablo2
     &           ,iafabhi0,iafabhi1,iafabhi2
     &           ,nafabcomp
     &           ,bfab
     &           ,ibfablo0,ibfablo1,ibfablo2
     &           ,ibfabhi0,ibfabhi1,ibfabhi2
     &           ,nbfabcomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,startcomp
     &           ,endcomp
     &           )
      implicit none
      REAL*8 dotprodout
      integer nafabcomp
      integer iafablo0,iafablo1,iafablo2
      integer iafabhi0,iafabhi1,iafabhi2
      REAL*8 afab(
     &           iafablo0:iafabhi0,
     &           iafablo1:iafabhi1,
     &           iafablo2:iafabhi2,
     &           0:nafabcomp-1)
      integer nbfabcomp
      integer ibfablo0,ibfablo1,ibfablo2
      integer ibfabhi0,ibfabhi1,ibfabhi2
      REAL*8 bfab(
     &           ibfablo0:ibfabhi0,
     &           ibfablo1:ibfabhi1,
     &           ibfablo2:ibfabhi2,
     &           0:nbfabcomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      integer startcomp
      integer endcomp
      integer i0,i1,i2
      integer nv
      dotprodout = 0
      do nv=startcomp,endcomp,1
      do i2 = iregionlo2,iregionhi2
      do i1 = iregionlo1,iregionhi1
      do i0 = iregionlo0,iregionhi0
         dotprodout = dotprodout +
     &        afab(i0,i1,i2,nv)*
     &        bfab(i0,i1,i2,nv)
      enddo
      enddo
      enddo
      enddo
      return
      end

max_stars_repo_name: boywert/chombo

max_issues_repo_name: boywert/chombo

max_forks_repo_name: boywert/chombo


text:
<!DOCTYPE html>

    <meta charset="utf-8">
    <meta http-equiv="X-UA-Compatible" content="IE=edge,chrome=1">
    <title>Class SendingFailedTransition
   </title>
    <meta name="viewport" content="width=device-width">
    <meta name="title" content="Class SendingFailedTransition
   ">
    <meta name="generator" content="docfx 2.51.0.0">

    <link rel="shortcut icon" href="../favicon.ico">
    <link rel="stylesheet" href="../styles/docfx.vendor.css">
    <link rel="stylesheet" href="../styles/docfx.css">
    <link rel="stylesheet" href="../styles/main.css">
    <meta property="docfx:navrel" content="../toc.html">
    <meta property="docfx:tocrel" content="toc.html">

              <button type="button" class="navbar-toggle" data-toggle="collapse" data-target="#navbar">
                Toggle navigation

              </button>

              <form class="navbar-form navbar-right" role="search" id="search">

                  <input type="text" class="form-control" id="search-query" placeholder="Search" autocomplete="off">

              </form>

          Show / Hide Table of Contents

Class SendingFailedTransition

Class that represents a sending failed transition

Inheritance

System.Object

PASSProcessModelElement

BehaviorDescriptionComponent

Transition

SendingFailedTransition

Implements

ISendingFailedTransition

ITransition

IBehaviorDescriptionComponent

IPASSProcessModellElement

IOwlThing

Inherited Members

      Transition.setBelongsToAction(IAction)

      Transition.setSourceState(IState)

      Transition.setTargetState(IState)

      Transition.setTransitionCondition(ITransitionCondition)

      Transition.getBelongsToAction()

      Transition.getSourceState()

      Transition.getTargetState()

      Transition.getTransitionCondition()

      Transition.getTmpBelonstToAction()

      Transition.getTmpTargetState()

      Transition.getTmpTransitionCondition()

      BehaviorDescriptionComponent.setBelongsToSubjectBehavior(ISubjectBehavior)

      BehaviorDescriptionComponent.getSubjectBehavior()

      PASSProcessModelElement.setAdditionalAttribute(List<String>)

      PASSProcessModelElement.getAdditionalAttribute()

      PASSProcessModelElement.setModelComponentID(String)

      PASSProcessModelElement.getModelComponentID()

      PASSProcessModelElement.setModelComponentLabel(List<String>)

      PASSProcessModelElement.getModelComponentLabel()

      PASSProcessModelElement.setComment(String)

      PASSProcessModelElement.getComment()

      PASSProcessModelElement.setAdditionalAttributeType(List<String>)

      PASSProcessModelElement.getAdditionalAttributeType()

      PASSProcessModelElement.emptyAdditionalAttribute()

      PASSProcessModelElement.createInstance(List<String>, String, List<String>, String)

      PASSProcessModelElement.createInstance(List<String>, List<String>)

      System.Object.ToString()

      System.Object.Equals(System.Object)

      System.Object.Equals(System.Object, System.Object)

      System.Object.ReferenceEquals(System.Object, System.Object)

      System.Object.GetHashCode()

      System.Object.GetType()

      System.Object.MemberwiseClone()

Namespace: alps_.net_api

Assembly: alps.net_api.dll

Syntax

public class SendingFailedTransition : Transition, ISendingFailedTransition, ITransition, IBehaviorDescriptionComponent, IPASSProcessModellElement, IOwlThing

Constructors

SendingFailedTransition()

Constructor that creates a new empty instance of the sending failed transition class

Declaration

public SendingFailedTransition()

  <h4 id="alps__net_api_SendingFailedTransition__ctor_System_Collections_Generic_List_System_String__System_String_System_Collections_Generic_List_System_String__System_String_alps__net_api_SubjectBehavior_alps__net_api_Action_alps__net_api_State_alps__net_api_State_alps__net_api_TransitionCondition_alps__net_api_SendState_alps__net_api_SendingFailedCondition_" data-uid="alps_.net_api.SendingFailedTransition.#ctor(System.Collections.Generic.List{System.String},System.String,System.Collections.Generic.List{System.String},System.String,alps_.net_api.SubjectBehavior,alps_.net_api.Action,alps_.net_api.State,alps_.net_api.State,alps_.net_api.TransitionCondition,alps_.net_api.SendState,alps_.net_api.SendingFailedCondition)">SendingFailedTransition(List<String>, String, List<String>, String, SubjectBehavior, Action, State, State, TransitionCondition, SendState, SendingFailedCondition)

Constructor that creates a new fully specified instance of the sending failed transition class

Declaration

public SendingFailedTransition(List<string> additionalAttribute, string modelComponentID, List<string> modelComponentLabel, string comment, SubjectBehavior subjectBehavior, Action belongsToaction, State sourceState, State targetState, TransitionCondition transitionCondition, SendState sendState, SendingFailedCondition sendingFailedCondition)

Parameters

        Type
        Name
        Description

        System.Collections.Generic.List<System.String>
        additionalAttribute

        System.String
        modelComponentID

        System.Collections.Generic.List<System.String>
        modelComponentLabel

        System.String
        comment

        SubjectBehavior
        subjectBehavior

        Action
        belongsToaction

        State
        sourceState

        State
        targetState

        TransitionCondition
        transitionCondition

        SendState
        sendState

        SendingFailedCondition
        sendingFailedCondition

Fields

className

Name of the class

Declaration

public const string className = "SendingFailedTransition"

Field Value

        Type
        Description

        System.String

Methods

factoryMethod()

Factory method that creates and returns a new empty instance of the sending failed transition class

Declaration

public SendingFailedTransition factoryMethod()

Returns

        Type
        Description

        SendingFailedTransition

A new empty instance of the sending failed transition class

getSendingFailedCondition()

Method that returns the sending failed condition attribute of the instance

Declaration

public ISendingFailedCondition getSendingFailedCondition()

Returns

        Type
        Description

        ISendingFailedCondition

The sending failed condition attribute of the instance

getSourceSendState()

Method that returns the send state attribute of the instance

Declaration

public ISendState getSourceSendState()

Returns

        Type
        Description

        ISendState

The send state attribute of the instance

getTmpSendingFailedCondition()

Declaration

public string getTmpSendingFailedCondition()

Returns

        Type
        Description

        System.String

getTmpSourceState()

Declaration

public string getTmpSourceState()

Returns

        Type
        Description

        System.String

setSourceState(ISendState)

Method that sets the send state attribute of the instance

Declaration

public void setSourceState(ISendState sendState)

Parameters

        Type
        Name
        Description

        ISendState
        sendState

setTransitionCondition(ISendingFailedCondition)

Method that sets the sending failed condition attribute of the instance

Declaration

public void setTransitionCondition(ISendingFailedCondition sendingFailedCondition)

Parameters

        Type
        Name
        Description

        ISendingFailedCondition
        sendingFailedCondition

Implements

      ISendingFailedTransition

      ITransition

      IBehaviorDescriptionComponent

      IPASSProcessModellElement

      IOwlThing

              Back to top

            Generated by DocFX

ext: fpp


text:
C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE GETXAX (NCHANX,IRC)
      IMPLICIT NONE
C
C Purpose: Read 1 frame of data from specified file and put in
C          X-axis data buffer.
C
      INTEGER NCHANX,IRC
C
C NCHANX : NOS. OF X CHANNELS
C IRC    : RETURN CODE
C
      INCLUDE 'COMMON.FOR'
C
C Calls   4: GETHDR , OPNFIL
C Called by: OTOKO
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      INTEGER IHFMAX,IFRMAX,IMEM,NCHAN,NFRAME,K
      INTEGER ISPEC,LSPEC,MEM,IFFR,ILFR,INCR,IFINC
      CHARACTER*13 HFNAM
C
C IRC    : Return code
C IFRAME : Total nos. of frames
C IFRMAX : Nos. of frames in sequence
C IHFMAX : Nos. of header file in sequence
C KREC   : Output file record
C ISPEC  : First header file of sequence
C LSPEC  : Last header file in sequence
C MEM    : Positional or calibration data indicator
C IFFR   : First frame in sequence
C ILFR   : Last frame in sequence
C INCR   : Header file increment
C IFINC  : Frame increment
C HFNAM  : Header filename
C IMEM   : Output memory dataset
C NCHAN  : Nos. of data points in spectrum
C NFRAME : Nos. of time frames
C
      DATA  IMEM/1/
C
C-----------------------------------------------------------------------
C
10    CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM,ISPEC,LSPEC,INCR,MEM,IFFR,
     1             ILFR,IFINC,IHFMAX,IFRMAX,NCHAN,IRC)
      IF (IRC.NE.0) GOTO 999
C
      CALL OPNFIL (JUNIT,HFNAM,ISPEC,MEM,IFFR,ILFR,NCHAN,NFRAME,IRC)
      IF (IRC.NE.0) GOTO 10
C
      READ (JUNIT,REC=IFFR) (XAX(K),K=1,NCHAN)
      CLOSE (UNIT=JUNIT)
      NCHANX=NCHAN
999   RETURN
C
      END


text:
Don Ho is a fourth year Psychology major and a Environmental Policy Analysis and Planning minor who enjoys candlelit dinners and long walks on the beach. Around campus, you can see him frolic from class to class. He was also a successful candidate for ASUCD Senate in the Fall 2009 ASUCD election.

Don can cook 30 minute brownies in 20 minutes, once discovered the meaning of life but forgot to write it down, and on weekends to let off steam, participates in full contact origami.

His past and present involvement on campus includes:

     ASUCD Controller
     Chancellors Undergraduate Advisory Board
     Student Services and Fees Administrative Advisory Committee (SSFAAC)
     Student Services Health Fee SHS Health Fee Oversight Committee (HFOC)
     Campus Unions and Recreations Board
     Center for Student Involvement Advisory Board
     ASUCD Internal Affairs Commission (IAC)
     ASUCD Business and Finance Commission (BnF)
     UC Davis Campus Media Board
     SPAC Club Finance Council Chair (CFC)
     UC Davis Mens Lacrosse
     Gilhooly and The Veloyce Glenn Winslow, Jr. Award  Winslow Award Selection Committee
     The Veloyce Glenn Winslow, Jr. Award Winner
     Aggie Pack Volunteer
     Entertainment Council Volunteer (EC)

School stuff

     Institute of Transportation Studies Research Assistant
     Debra Long Language and Cognition Laboratory Research Assistant
     Asian American Center on Disparities Research Laboratory Research Assistant
     Phi Kappa Phi Honors Society
     Psi Chi Honors Fraternity
     Plant Sciences 21 TA


text:
C> \file axbt.f
C> Matrix multiply
C>
C> \ingroup selci
C> @{
C>
C> \brief Matrix multiply
C>
C> Performs the matrix-matrix multiplication
C> \f{eqnarray*}{
C>   C &=& A * B^T
C> \f}
C>
      subroutine selci_axbt(a,mrowa,b,mrowb,c,mrowc,ncol,nlink,nrow)
*
* $Id$
*
      implicit real*8 (a-h,o-z)
      integer mrowa !< [Input] The number of rows in A
      integer mrowb !< [Input] The number of rows in B
      integer mrowc !< [Input] The number of rows in C
      integer ncol  !< [Input] The length of a column in C
      integer nrow  !< [Input] The length of a row in C
      integer nlink !< [Input] The length of the contraction
      parameter (zero=0.0d0)
      double precision a(mrowa,nlink) !< [Input] Matrix A
      double precision b(mrowb,nlink) !< [Input] Matrix B
      double precision c(mrowc,nrow)  !< [Output] Matrix C
c
c     matrix multiply c = a*bt
c
*     mdc*if alliant
*     c(1:ncol,1:nrow) = matmul(a(1:ncol,1:nlink),
*     $     transpose(b(1:nrow,1:nlink)))
*     mdc*else
c
c     Assumed that this is being used on small sparse matrices
c
c     Optimize with loop unrolling
c
      integer ind(3)
      real*8  bjk(3)
c
c     small cases
c
      if (nlink .eq. 1) then
         do j = 1, nrow
            do i = 1, ncol
               c(i,j) = a(i,1)*b(j,1)
            enddo
         enddo
         return
      else if (nlink.eq.2) then
         do j = 1, nrow
            do i = 1, ncol
               c(i,j) = a(i,1)*b(j,1) + a(i,2)*b(j,2)
            enddo
         enddo
         return
      else if (nlink .eq. 3) then
         do j = 1, nrow
            do i = 1, ncol
               c(i,j) = a(i,1)*b(j,1) + a(i,2)*b(j,2) + a(i,3)*b(j,3)
            enddo
         enddo
         return
      endif
c
c     general case
c
      do j = 1,nrow
         do i = 1,ncol
            c(i,j) = zero
         enddo
c
         ndo = 0
         do k = 1,nlink
            test = b(j,k)
            if (test .ne. 0.0d0) then
               ndo = ndo + 1
               ind(ndo) = k
               bjk(ndo) = test
            endif
            if (ndo.eq.3) then
               k1 = ind(1)
               k2 = ind(2)
               k3 = ind(3)
               bjk1 = bjk(1)
               bjk2 = bjk(2)
               bjk3 = bjk(3)
               do i = 1,ncol
                  c(i,j)=c(i,j)+a(i,k1)*bjk1+a(i,k2)*bjk2+a(i,k3)*bjk3
               enddo
               ndo = 0
            endif
         enddo
         if (ndo.eq.2) then
            k1 = ind(1)
            k2 = ind(2)
            bjk1 = bjk(1)
            bjk2 = bjk(2)
            do i = 1,ncol
               c(i,j) = c(i,j) + a(i,k1)*bjk1 + a(i,k2)*bjk2
            enddo
         else if (ndo.eq.1) then
            k1 = ind(1)
            bjk1 = bjk(1)
            do i = 1,ncol
               c(i,j) = c(i,j) + a(i,k1)*bjk1
            enddo
         endif
c
      enddo
*     *mdc*endif
*     c
*     call selci_mxma(a,1,mrowa,b,mrowb,1,c,1,mrowc,ncol,nlink,nrow)
*
*     call dgemm( 'n', 't', ncol, nrow, nlink, 1.0d0, a, mrowa,
*     *     b, mrowb, 0.0d0, c, mrowc )
c
      end
C>
C> @}


text:
module sisen
	implicit none
	integer, parameter :: imax=1000,jmax=1000
	real, parameter :: dx=10.0,dy=10.0,pie=3.1415927
	integer,dimension(imax,jmax) :: VAL,VISIT
	real,dimension(imax,jmax) :: DEM
! VISIT :: dummy

contains
    integer function point_view(is,js,ie,je)
	integer is,js,ie,je
	integer x,y,x1,x2,y1,y2
	integer ise,jse
	integer inc
	real xx,yy,dx,dy
	real zs,ze,za,zb,z1,z2

	zs=DEM(is,js)
	ze=DEM(ie,je)
	ise=abs(is-ie) ; jse=abs(js-je)
!	write(*,*) ise,jse
	inc=1 ; point_view=1
	if (max(ise,jse).le.1) then
		point_view=0 ; return
	endif
	if (ise .ge. jse) then
		if (is .ge. ie) then
			inc=-inc
		endif
!		do x=is+inc,ie-inc,inc
		do x=ie-inc,is+inc,-inc
			xx=real(x)
			yy=js+(je-js)*(xx-is)/(ie-is)
			y1=int(yy) ; y2=y1+1 ; dy=yy-y1
			za=zs+(ze-zs)*(xx-is)/(ie-is)
			z1=DEM(x,y1) ; z2=DEM(x,y2)
			zb=z1+(z2-z1)*dy
			if (zb .gt. za) then
				point_view=0 ; return
			endif
		enddo
	else
		if (js .ge. je) then
			inc=-inc
		endif
!		do y=js+inc,je-inc,inc
		do y=je-inc,js+inc,-inc
			yy=real(y)
			xx=is+(ie-is)*(yy-js)/(je-js)
			x1=int(xx) ; x2=x1+1 ; dx=xx-x1
			za=zs+(ze-zs)*(yy-js)/(je-js)
			z1=DEM(x1,y) ; z2=DEM(x2,y)
			zb=z1+(z2-z1)*dx
			if (zb .gt. za) then
				point_view=0 ; return
			endif
		enddo
	endif
	return
    end function point_view

    subroutine view(is,js)
	integer is,js
	integer ie,je
	VAL=0
	do je=3,jmax-2
	do ie=3,imax-2
		VAL(ie,je)=point_view(is,js,ie,je)
	enddo
	enddo
    end subroutine view

end module sisen

max_stars_repo_name: y-iikura/ViewShed

max_issues_repo_name: y-iikura/ViewShed

max_forks_repo_name: y-iikura/ViewShed


subroutine totzsp(rmncc,rmnss,zmncs,zmnsc,lmncs,lmnsc, &
                  r1,ru,rv,   z1,zu,zv,   lu,lv,       &
                  rcon,zcon, work1,work2,work3)

      use stel_kinds, only: dp
      use name0,      only: czero, c2p0
      use name1,      only: nmax, mpol1, nzeta, ntheta2
      use scalars,    only: ns
      use realsp,     only: clear_realsp
      use mnarray,    only: jmin1, xmpq
      use trignew,    only: cosnv, sinnv, cosnvn, sinnvn, &
                            cosmu, sinmu, cosmum, sinmum

      implicit none

      ! need inout to do extrapolation towards axis
      real(kind=dp), intent(inout) :: rmncc(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(inout) :: rmnss(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(inout) :: zmncs(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(inout) :: zmnsc(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(inout) :: lmncs(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(inout) :: lmnsc(ns,0:nmax,0:mpol1)

      real(kind=dp), intent(out)   ::   r1(ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(out)   ::   ru(ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(out)   ::   rv(ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(out)   ::   z1(ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(out)   ::   zu(ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(out)   ::   zv(ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(out)   ::   lu(ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(out)   ::   lv(ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(out)   :: rcon(ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(out)   :: zcon(ns*nzeta,ntheta2,0:1)

      ! NOTE: work1-work3 all refer to the same array, but with different indices !!!
      real(kind=dp) :: work1(ns*nzeta*12)
      real(kind=dp) :: work2(ns*nzeta,12)
      real(kind=dp) :: work3(ns,nzeta,12)

      integer       :: i, js, jk, k, l, m, n
      integer       :: mparity
      real(kind=dp) :: cosmux, sinmux

      ! THIS ROUTINE ASSUMES THE FOLLOWING STACKING OF R, Z, LAMBDA ARRAYS:
      ! rmncc(ns,0:nmax,0:mpol1),rmnss,zmncs,zmncc,lmncs,lmnsc

      ! INITIALIZATION BLOCK
      call clear_realsp ! in module realsp

      ! EXTRAPOLATION AT JS=1 FOR M=1 MODES
      do n = 0,nmax
        rmncc(1,n,1) = c2p0*rmncc(2,n,1) - rmncc(3,n,1)
        rmnss(1,n,1) = c2p0*rmnss(2,n,1) - rmnss(3,n,1)
        zmncs(1,n,1) = c2p0*zmncs(2,n,1) - zmncs(3,n,1)
        zmnsc(1,n,1) = c2p0*zmnsc(2,n,1) - zmnsc(3,n,1)
        lmncs(1,n,1) = c2p0*lmncs(2,n,1) - lmncs(3,n,1)
        lmnsc(1,n,1) = c2p0*lmnsc(2,n,1) - lmnsc(3,n,1)
      end do

      ! COMPUTE R, Z, AND LAMBDA IN REAL SPACE
      ! BEGIN INVERSE TRANSFORM IN N-ZETA
      do m = 0,mpol1
        mparity = mod(m,2)

        do l = 1, 12*ns*nzeta
          work1(l) = czero
        enddo

        do n = 0, nmax
          do k = 1, nzeta
            do js= jmin1(m), ns
              work3(js,k,1) = work3(js,k,1) + rmncc(js,n,m)*cosnv (k,n)
              work3(js,k,2) = work3(js,k,2) + rmnss(js,n,m)*sinnv (k,n)
              work3(js,k,3) = work3(js,k,3) + rmncc(js,n,m)*sinnvn(k,n)
              work3(js,k,4) = work3(js,k,4) + rmnss(js,n,m)*cosnvn(k,n)
              work3(js,k,5) = work3(js,k,5) + zmncs(js,n,m)*sinnv (k,n)
              work3(js,k,6) = work3(js,k,6) + zmnsc(js,n,m)*cosnv (k,n)
              work3(js,k,7) = work3(js,k,7) + zmncs(js,n,m)*cosnvn(k,n)
              work3(js,k,8) = work3(js,k,8) + zmnsc(js,n,m)*sinnvn(k,n)
              work3(js,k,9) = work3(js,k,9) + lmncs(js,n,m)*sinnv (k,n)
              work3(js,k,10)= work3(js,k,10)+ lmnsc(js,n,m)*cosnv (k,n)
              work3(js,k,11)= work3(js,k,11)+ lmncs(js,n,m)*cosnvn(k,n)
              work3(js,k,12)= work3(js,k,12)+ lmnsc(js,n,m)*sinnvn(k,n)
            enddo
          enddo
        enddo

        ! INVERSE TRANSFORM IN M-THETA
        do i = 1, ntheta2
          cosmux = xmpq(m,1)*cosmu(i,m)
          sinmux = xmpq(m,1)*sinmu(i,m)

          do jk = 1, nzeta*ns
            r1(jk,i,mparity)   =   r1(jk,i,mparity) + work2(jk,01)*cosmu (i,m) + work2(jk,02)*sinmu (i,m)
            ru(jk,i,mparity)   =   ru(jk,i,mparity) + work2(jk,02)*cosmum(i,m) + work2(jk,01)*sinmum(i,m)
            rv(jk,i,mparity)   =   rv(jk,i,mparity) + work2(jk,03)*cosmu (i,m) + work2(jk,04)*sinmu (i,m)
            z1(jk,i,mparity)   =   z1(jk,i,mparity) + work2(jk,05)*cosmu (i,m) + work2(jk,06)*sinmu (i,m)
            zu(jk,i,mparity)   =   zu(jk,i,mparity) + work2(jk,06)*cosmum(i,m) + work2(jk,05)*sinmum(i,m)
            zv(jk,i,mparity)   =   zv(jk,i,mparity) + work2(jk,07)*cosmu (i,m) + work2(jk,08)*sinmu (i,m)
            lu(jk,i,mparity)   =   lu(jk,i,mparity) + work2(jk,10)*cosmum(i,m) + work2(jk,09)*sinmum(i,m) !  d(lambda)/du
            lv(jk,i,mparity)   =   lv(jk,i,mparity) - work2(jk,11)*cosmu (i,m) - work2(jk,12)*sinmu (i,m) ! -d(lambda)/dv

            rcon(jk,i,mparity) = rcon(jk,i,mparity) + work2(jk,01)*cosmux      + work2(jk,02)*sinmux
            zcon(jk,i,mparity) = zcon(jk,i,mparity) + work2(jk,05)*cosmux      + work2(jk,06)*sinmux
          enddo
        enddo

      enddo ! loop over m

      return

end


text: The Davis Water Company is mentioned in a State sanitation report about Davis in 1915.


text:
Globe artichokes (Cynara scolymus) are in the Asteraceae family and though classified as a perennial herb, are also identified as a noxious/invasive weed. This is the same Mediterranean vegetable you find in supermarkets  in the garden however, it grows anywhere from four to sixfeet in height and breadth under full sun, and when left to bloom, sport beautiful spiky bluepurple heads by midsummer. In its full glory, one can easily see the artichokes relationship to Yellow Starthistle thistle, with its jagged silvergrey foliage and tufted seeds which together form an impressive deerresistant plant. (My rabbit still found it tasty ~SD) The flower stems grow straight and are terminated by a large globeshaped flower bud of oval spiny scales tinged with purple. The bud opens in midsummer to reveal a bluepurple mass of florets. If youre growing artichokes for their flower or simply leave a few large buds on the plant to bloom, beware of volunteer plants the following season! This plant selfsows freely and requires only average watering to germinate and produce.

Though related to thistles, the globe artichoke has been selectively bred to exclude spines on the bracts (unless planted from seed). Globe artichokes are one of the worlds oldest cultivated vegetables, farmed by the Greeks and Romans as far back as 371 BC, who obtained them from the sandy shores of North Africa. According to ancient legend, the first artichoke was a lovely young girl named Cynara, who lived on the Aegean island of Zinari. The god, Zeus was visiting his brother Poseidon when he spied the beautiful young mortal. She did not seem frightened by the presence of a god, and Zeus seized the opportunity to seduce her. He was so pleased with the girl that he decided to make her a goddess, so she could be near his home on Olympia. Cynara agreed, and Zeus looked forward to his trysts with Cynara whenever his wife Hera was away. However, Cynara soon grew homesick and snuck back to the world of mortals for a brief visit. Enraged, Zeus hurled her back to earth and transformed her into the plant we know as the artichoke.

Back on Earth, artichokes were considered an aristocratic vegetable and thought to be an aphrodisiac. In fact, European women werent allowed to eat artichokes in the 16th century specifically because of their believed aphrodisiac qualities! Extracts of the leaves and root are said to be helpful in preventing arteriosclerosis while other herbal remedies for jaundice, dyspepsia, liver insufficiency, chronic albuminuria, and postoperative anemia are claimed as well. Most recently, the discovery of cynarin within its leaves has been found to improve liver and gall bladder function, stimulate the secretion of digestive juices, and lowers blood cholesterol levels.

Almost all globe artichokes purchased in American grocery stores are grown in California. The major California production areas for artichokes are the central coast (Monterey, Santa Cruz, and San Mateo Counties); south coast (Santa Barbara, Ventura, Orange, and San Diego Counties); desert (Riverside and Imperial Counties); and the Central Valley. In coastal region they are grown as perennials; they are grown as an annual crop elsewhere. Home gardeners can grow them as perennials. Reference: http://anrcatalog.ucdavis.edu/pdf/7221.pdf

French immigrants brought artichokes to the US when they settled in the Louisiana Territory in 1806, but they disappeared for a time before being reestablished in the Monterey area by Spaniards later in the century. Marilyn Monroe became our first official California Artichoke Queen in 1949. The frostsensitive plants are equally deterred by heat, which opens buds quickly making the plants inedible. And, while tolerant of dry soils in areas with weather mild winters, such as we see in Davis, our hot summers may make production of large edible buds difficult; gardeners wishing to cultivate table specimens should remove all lateral heads when they are about the size of a large egg to encourage growth of a single large terminal head. Plants intended for vegetable production should be cut below the soil surface every five years to stimulate development of new shoots. In California, we enjoy peak artichoke production seasons in both spring and fall, though they are available year round. Elsewhere, artichokes are cultivated in France, Italy, and Spain.

For a listing of other edible and ornamental plants found in Davis, visit our Town Flora.


text:
Wiki Gnomes are users who focus on taking care of the wiki by handling the little things.  Gnomes are ordinary editors just like you  if you want to be a gnome, just dive right in and start editing: fix links, create new links, fix wording for grammar or clarity, etc.  In fact, you may already be a gnome and not know it!  See the wiki:gnome:Front Page Wiki Gnome Headquarters or wiki:c2:WikiGnome Wiki Gnome on Wards Wiki for more information.

Old gnomes may suffer from Wiki Community/Wiki Fatigue wiki fatigue and appear cranky even when they have the best interests of the wiki at heart. Usually a vacation away from the wiki will help return the gnome back to their usual helpful and welcoming self. You can prevent gnome abuse by helping out overworked or overwhelmed gnomes.

Some gnomes are also Wiki Gnome/Philosophy philosophers.

 Gnome Tools

  Recent Changes  Gnomes read other peoples edits and watch for edit or revert wars.
  Outgoing Links  Gnomes try to add links to pages that dont have any links to other pages on the wiki.
  Orphaned Pages  Gnomes try to find places to link to a page that doesnt have any links to it.
  Wanted Pages  Sometimes Gnomes will go looking for pages that are linked from other places that dont yet exist. Sometimes they unlink the links on the requesting pages, and other times they create the wanted page.

20081207 15:39:17 nbsp Those gnome hats are SO last year.  No self respecting gnome would be caught wearing one of those any more.  All the fashionable gnomes wear bowler hats made from real bowlers now... Users/IDoNotExist
  The preceding comment brought to you by the author of Wiki Completeness and Wikiwords. As to the fashion sense of various gnomes... the gnomes pictured are among those who do not insult others for their sartorial choices, but rather work to create a safe space for creatures of all kinds to feel safe wearing what makes them comfortable. Rather than being a red hat hater why not come over to the light side? Users/JasonAller

20081207 17:12:43 nbsp Ummm...it was a joke.  Really.  Wow. Users/IDoNotExist


text:
      program aritmetica
        implicit none

        real :: pi
        real :: radio_cilindro
        real :: altura_cilindro
        real :: area_cilindro
        real :: volumen_cilindro

        pi=3.1415926535
        !  3.14159265358979323846264338

        print *, 'Introduzca el radio de la base del cilindro:'
        read(*,*) radio_cilindro

        print *, 'Introduzca la altura del cilindro:'
        read(*,*) altura_cilindro

        area_cilindro = pi*radio_cilindro**2.0
        volumen_cilindro = area_cilindro*altura_cilindro

        print *, 'Radio del cilindro: ', radio_cilindro
        print *, 'Altura del cilindro: ',altura_cilindro
        print *, 'Area del cilindro: ',area_cilindro
        print *, 'Volumen del cilindro: ',volumen_cilindro
      end program aritmetica

max_stars_repo_name: Marc-xyz/InicioRapidoEnFortran

max_issues_repo_name: Marc-xyz/InicioRapidoEnFortran

max_forks_repo_name: Marc-xyz/InicioRapidoEnFortran


text:
c
c
c
c     =====================================================
       subroutine qinit(meqn,mbc,mx,my,xcorn,ycorn,
     &                   dx,dy,q,maux,aux,lstgrd,irr)
c     =====================================================
c
c     # Set initial conditions for q.
c     # rotated channel problem
c
       use amr_module
       implicit double precision (a-h,o-z)

       dimension q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
       dimension aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)
       integer irr(1-mbc:mx+mbc, 1-mbc:my+mbc)

c  put these vals in for solid cells
       rhoSolid = 1.d0
       uSolid   = 0.0d0
       vSolid   = 0.0d0
       pSolid   = 1.0d0

c      use pointwise evaluation of exact solution
c      for higher order methods would have to compute integral average

       do 20 i = 1-mbc, mx+mbc
       do 20 j = 1-mbc, my+mbc
          kuse = irr(i,j)
          if (kuse .ne. -1 .and. kuse .ne. lstgrd) then
             xcen = xcirr(kuse)
             ycen = ycirr(kuse)
          else
             xcen = xcorn + (i-0.5d0)*dx
             ycen = ycorn + (j-0.5d0)*dy
          endif
          call ssvInit(xcen,ycen,rhot,ut,vt,pt)
          if (kuse .eq. -1) then
            q(1,i,j) = rhoSolid
            q(2,i,j) = 0.d0
            q(3,i,j) = 0.d0
            q(4,i,j) = pSolid/.4d0
          else
            q(1,i,j) = rhot
            q(2,i,j) = rhot * ut
            q(3,i,j) = rhot * vt
            q(4,i,j) = pt/.4d0 + 0.5d0*rhot*(ut**2 + vt**2)
          endif
  20   continue

       return
       end


text:
      MODULE jthn_I
      INTERFACE
!
      INTEGER FUNCTION JTHN(K,N,I)
      INTEGER, INTENT(IN) :: I, N, K
      END FUNCTION
      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


module solutions
  use pf_mod_dtype
  use pf_mod_ndarray_oc
  use probin, only : sizex
  implicit none

contains

  ! Set initial condition.
  subroutine initial(q0, t0, tend)
    type(pf_ndarray_oc_t), intent(inout) :: q0
    real(pfdp),       intent(in)    :: t0, tend
    integer             :: nvars, i
    real(pfdp)          :: dx, x

    q0%yflatarray = 0.0_pfdp
    nvars = size(q0%yflatarray)
    dx = sizex/dble(nvars)
    do i = 1, nvars
       x = dble(i-1)*dx
        if( x >= 9.0 .and. x <= 11.0 ) q0%yflatarray(i) = 1.2*sqrt(3.0)
!        if( x < 10.0 ) q0%yflatarray(i) = -1.2*sqrt(3.0)
!        if( x > 10.0 ) q0%yflatarray(i) =  1.2*sqrt(3.0)
    end do

    !print *, 'initial', t0, tend
    !call exact_y(t0, size(q0%yflatarray), q0%yflatarray)
    q0%pflatarray = 0.0_pfdp ! for adjoint, all zero terminal condition
    !call exact_p(tend, size(q0%pflatarray), q0%pflatarray)

  end subroutine initial

end module solutions