text:
      SUBROUTINE STPAX2 (SORC,TI)
C
C     THIS ROUTINE IS PHASE II OF STRESS RECOVERY FOR THE TRAPEZOIDAL
C     CROSS SECTION RING
C
C     OUTPUTS FROM PHASE I ARE THE FOLLOWING..
C     IDEL, IGP(4), TZ, SEL(360), TS(06), AK(144), PHI(14)
C     AKUPH(48), AKPH2(16), SELP1(120), SELP2(180), SELP3(60)
C
C     ANY GROUP OF STATEMENTS PREFACED BY AN IF STATEMENT CONTAINING
C     ...KSYS78 OR LSYS78 ...  INDICATES CODING NECESSARY FOR THIS
C     ELEMENT*S PIEZOELECTRIC CAPABILITY
C
C     KSYS78 = 0   ELASTIC, NON-PIEZOELECTRIC MATERIAL
C     KSYS78 = 1   ELECTRICAL-ELASTIC COUPLED, PIEZOELETRIC MATERIAL
C     KSYS78 = 2   ELASTIC ONLY, PIEZOELECTRIC MATERIAL
C     LSYS78 = .TRUE. IF KSYS78 = 0, OR 2
C
      LOGICAL         ZERO,ZERON,LSYS78
      INTEGER         SORC,IBLOCK(62,14),ISTRES(100),IFORCE(25),ELEMID,
     1                ICLOCK(62,14)
      REAL            NPHI
      DIMENSION       TI(4),DUM3(225),STRES(100),FORCE(25),AKUPH(48),
     1                AKPH2(16),SELP1(120),SELP2(180),SELP3(60),D4(4),
     2                D15(15),D30(30),DISPP(4),ECHRG(4),EFLUX(15)
C
C     SDR2 VARIABLE CORE
C
      COMMON /ZZZZZZ/ ZZ(1)
C
C     SDR2 BLOCK FOR POINTERS AND LOADING  TEMPERATURES
C
      COMMON /SDR2X4/ DUM1(33),ICSTM,NCSTM,IVEC,IVECN,TEMPLD,ELDEFM,
     1                DUM4(12),KTYPE
C
C     SCRATCH BLOCK
C
      COMMON /SDR2X8/ DISP(12),EFORC(12),ESTRES(30),HARM,N,SINPHI,
     1                CONPHI,NPHI,NANGLE,ELEMID,UNU(93),NELHAR,KANGLE,
     2                KLEMID
C
C     SDR2 INPUT AND OUTPUT BLOCK
C
      COMMON /SDR2X7/ IDEL,IGP(4),TZ,SEL(360),TS(6),AK(144),PHI(14),
     1                DUM2(424),BLOCK(62,14),CLOCK(62,14)
C
      COMMON /SYSTEM/ KSYSTM(77),KSYS78
      COMMON /SDR2DE/ DUM5(33), IPART
      COMMON /CONDAS/ CONSTS(5)
      EQUIVALENCE     (IBLOCK(1,1),BLOCK(1,1)),(ICLOCK(1,1),CLOCK(1,1)),
     1                (DUM3(1),IDEL),(DUM3(101),STRES(1),ISTRES(1)),
     2                (DUM3(201),FORCE(1),IFORCE(1)),(CONSTS(4),DEGRAD),
     3                (LDTEMP,TEMPLD),(DUM2(1),AKUPH(1)),
     4                (DUM2(49),AKPH2(1)),(DUM2(65),SELP1(1)),
     5                (DUM2(185),SELP2(1)),(DUM2(365),SELP3(1)),
     6                (UNU(1),D4(1)),(UNU(5),D15(1)),(UNU(20),D30(1))
      DATA    ZERON / .FALSE. /
      DATA    IOSORC/ 0       /
C
      ELEMID = IDEL / 1000
      NELHAR = IDEL - ELEMID*1000
      KLEMID = ELEMID
      LSYS78 =.FALSE.
      IF (KSYS78.EQ.0 .OR. KSYS78.EQ.2) LSYS78 = .TRUE.
C
C     SET BLOCK = 0 IF HARMONIC = 0
C
      N = NELHAR - 1
      IF (N .NE. 0) GO TO 21
      IF (N.EQ.0 .AND. ZERON .AND. IOSORC .NE. SORC) GO TO 14
      ZERON  = .TRUE.
      IOSORC = SORC
      DO 15 I = 2,62
      DO 15 J = 1,14
      IF (KTYPE.NE.2 .OR. IPART.NE.2) BLOCK(I,J) = 0.0
      CLOCK(I,J) = 0.0
   15 CONTINUE
C
C     SET ANGLES CONTROL FOR SUMMATION
C
      ZERO = .FALSE.
      J = 0
      DO 16 I = 1,14
      IF (PHI(I)) 17,18,17
   18 IF (ZERO) GO TO 16
      ZERO = .TRUE.
   17 J = J + 1
      BLOCK(1,J) = PHI(I)
      CLOCK(1,J) = PHI(I)
   16 CONTINUE
      J = J + 1
      IF (J .GT. 14) GO TO 21
      IBLOCK(1,J) = 1
      ICLOCK(1,J) = 1
      GO TO 21
   14 ZERON = .FALSE.
   21 HARM  = N
C
C     INITIALIZE LOCAL VARIABLES
C
      NDOF  = 3
      NUMPT = 4
      N     = NDOF*NUMPT
      NSP   = 5
      NCOMP = 6
      NS    = NSP*NCOMP
C
C     FIND GRID POINTS DISPLACEMENTS
C
      K = 0
      DO 100 I = 1,NUMPT
      ILOC = IVEC + IGP(I) - 2
C
      IF (LSYS78) GO TO 90
      ILOCP = ILOC + 4
      DISPP(I) = ZZ(ILOCP)
   90 CONTINUE
C
      DO 100 J = 1,NDOF
      ILOC = ILOC + 1
      K = K + 1
      DISP(K) = ZZ(ILOC)
  100 CONTINUE
C
C     COMPUTE THE GRID POINT FORCES
C
      CALL GMMATS (AK(1),N,N,0, DISP(1),N,1,0, EFORC(1))
C
      DO 109 I = 1,4
  109 ECHRG(I) = 0.0
C
      IF (LSYS78) GO TO 125
      CALL GMMATS (AKUPH(1),N,NUMPT,0, DISPP(1),NUMPT,1,0, D15(1))
      DO 110 I = 1,12
  110 EFORC(I) = EFORC(I) + D15(I)
C
      CALL GMMATS (AKUPH(1),N,NUMPT,1, DISP(1),N,1,0, D4(1))
      CALL GMMATS (AKPH2(1),NUMPT,NUMPT,0, DISPP(1),NUMPT,1,0, ECHRG(1))
      DO 120 I = 1,4
  120 ECHRG(I) = ECHRG(I) + D4(I)
  125 CONTINUE
C
C     COMPUTE THE STRESSES
C
      CALL GMMATS (SEL(1),NS,N,0, DISP(1),N,1,0, ESTRES(1))
C
      DO 129 I = 1,15
  129 EFLUX(I) = 0.0
C
      IF (LSYS78) GO TO 145
      CALL GMMATS (SELP1(1),NS,NUMPT,0, DISPP(1),NUMPT,1,0, D30(1))
      DO 130 I = 1,30
  130 ESTRES(I) = ESTRES(I) + D30(I)
C
      CALL GMMATS (SELP2(1),15,N,0, DISP(1),N,1,0, EFLUX(1))
      CALL GMMATS (SELP3(1),15,NUMPT,0, DISPP(1),NUMPT,1,0, D15(1))
      DO 140 I = 1,15
  140 EFLUX(I) = EFLUX(I) + D15(I)
  145 CONTINUE
C
C     COMPUTE THERMAL STRESS IF IT IS EXISTS
C
      IF (LDTEMP .EQ. -1) GO TO 300
      K = 0
      T = TZ
      IF (HARM .GT. 0.0) T = 0.0
      DO 200 I = 1,NSP
      DT = TI(I) - T
      IF (I .EQ. 5) DT = (TI(1)+TI(2)+TI(3)+TI(4))/4.0 - T
      DO 200 J = 1,NCOMP
      K = K + 1
      ESTRES(K) = ESTRES(K) - DT*TS(J)
  200 CONTINUE
  300 CONTINUE
C
C     BRANCH TO INSERT HARMONIC STRESSES AND FORCES INTO BLOCK OR CLOCK
C
C     KTYPE = 1 - REAL OUTPUT, STORED IN BLOCK, NOTHING IN CLOCK
C     KTYPE = 2 - COMPLEX OUTPUT
C     IPART = 1 - IMAGINARY PART OF COMPLEX OUTPUT, STORED IN BLOCK
C     IPART = 2 - REAL PART OF COMPLEX OUTPUT, STORED IN CLOCK
C
      IF (KTYPE.EQ.2 .AND. IPART.EQ.2) GO TO 550
C
C     INSERT HARMONIC STRESSES AND FORCES INTO BLOCK
C
      DO 370 I = 1,14
      IF (IBLOCK(1,I) .EQ. 1) GO TO 380
      IF (HARM .EQ. 0.0) GO TO 350
      NPHI   = HARM*BLOCK(1,I)*DEGRAD
      SINPHI = SIN(NPHI)
      CONPHI = COS(NPHI)
      GO TO (330,310), SORC
C
  310 CONTINUE
      DO 315 IE = 1,5
      KE   = 9*(IE-1)
      KEPZ = 6*(IE-1)
      BLOCK(2+KE,I) = BLOCK(2+KE,I) + CONPHI*ESTRES(1+KEPZ)
      BLOCK(3+KE,I) = BLOCK(3+KE,I) + CONPHI*ESTRES(2+KEPZ)
      BLOCK(4+KE,I) = BLOCK(4+KE,I) + CONPHI*ESTRES(3+KEPZ)
      BLOCK(5+KE,I) = BLOCK(5+KE,I) + CONPHI*ESTRES(4+KEPZ)
      BLOCK(6+KE,I) = BLOCK(6+KE,I) + SINPHI*ESTRES(5+KEPZ)
      BLOCK(7+KE,I) = BLOCK(7+KE,I) + SINPHI*ESTRES(6+KEPZ)
C
      IF (LSYS78) GO TO 315
      KEPZ2 = KEPZ/2
      BLOCK( 8+KE,I) = BLOCK( 8+KE,I) + CONPHI*EFLUX (1+KEPZ2)
      BLOCK( 9+KE,I) = BLOCK( 9+KE,I) + CONPHI*EFLUX (2+KEPZ2)
      BLOCK(10+KE,I) = BLOCK(10+KE,I) + SINPHI*EFLUX (3+KEPZ2)
  315 CONTINUE
C
      DO 320 IR = 1,4
      KR   = 4*(IR-1)
      KRPZ = 3*(IR-1)
      BLOCK(47+KR,I) = BLOCK(47+KR,I) + CONPHI*EFORC(1+KRPZ)
      BLOCK(48+KR,I) = BLOCK(48+KR,I) + SINPHI*EFORC(2+KRPZ)
      BLOCK(49+KR,I) = BLOCK(49+KR,I) + CONPHI*EFORC(3+KRPZ)
      KR3 = 1 + KRPZ/3
      IF(.NOT.LSYS78) BLOCK(50+KR,I) = BLOCK(50+KR,I) +CONPHI*ECHRG(KR3)
  320 CONTINUE
      GO TO 370
C
  330 CONTINUE
      DO 335 IE = 1,5
      KE   = 9*(IE-1)
      KEPZ = 6*(IE-1)
      BLOCK(2+KE,I) = BLOCK(2+KE,I) + SINPHI*ESTRES(1+KEPZ)
      BLOCK(3+KE,I) = BLOCK(3+KE,I) + SINPHI*ESTRES(2+KEPZ)
      BLOCK(4+KE,I) = BLOCK(4+KE,I) + SINPHI*ESTRES(3+KEPZ)
      BLOCK(5+KE,I) = BLOCK(5+KE,I) + SINPHI*ESTRES(4+KEPZ)
      BLOCK(6+KE,I) = BLOCK(6+KE,I) - CONPHI*ESTRES(5+KEPZ)
      BLOCK(7+KE,I) = BLOCK(7+KE,I) - CONPHI*ESTRES(6+KEPZ)
C
      IF (LSYS78) GO TO 335
      KEPZ2 = KEPZ/2
      BLOCK( 8+KE,I) = BLOCK( 8+KE,I) + SINPHI*EFLUX(1+KEPZ2)
      BLOCK( 9+KE,I) = BLOCK( 9+KE,I) + SINPHI*EFLUX(2+KEPZ2)
      BLOCK(10+KE,I) = BLOCK(10+KE,I) - CONPHI*EFLUX(3+KEPZ2)
  335 CONTINUE
C
      DO 340 IR = 1,4
      KR   = 4*(IR-1)
      KRPZ = 3*(IR-1)
      BLOCK(47+KR,I) = BLOCK(47+KR,I) + SINPHI*EFORC(1+KRPZ)
      BLOCK(48+KR,I) = BLOCK(48+KR,I) - CONPHI*EFORC(2+KRPZ)
      BLOCK(49+KR,I) = BLOCK(49+KR,I) + SINPHI*EFORC(3+KRPZ)
      KR3 = 1 + KRPZ/3
      IF(.NOT.LSYS78) BLOCK(50+KR,I) = BLOCK(50+KR,I) +SINPHI*ECHRG(KR3)
  340 CONTINUE
      GO TO 370
C
  350 DO 355 IE = 1,5
      KE   = 9*(IE-1)
      KEPZ = 6*(IE-1)
      BLOCK(2+KE,I) = ESTRES(1+KEPZ)
      BLOCK(3+KE,I) = ESTRES(2+KEPZ)
      BLOCK(4+KE,I) = ESTRES(3+KEPZ)
      BLOCK(5+KE,I) = ESTRES(4+KEPZ)
      BLOCK(6+KE,I) = ESTRES(5+KEPZ)
      BLOCK(7+KE,I) = ESTRES(6+KEPZ)
C
      IF (LSYS78) GO TO 355
      KEPZ2 = KEPZ/2
      BLOCK( 8+KE,I) = EFLUX(1+KEPZ2)
      BLOCK( 9+KE,I) = EFLUX(2+KEPZ2)
      BLOCK(10+KE,I) = EFLUX(3+KEPZ2)
  355 CONTINUE
C
      DO 360 IR = 1,4
      KR   = 4*(IR-1)
      KRPZ = 3*(IR-1)
      BLOCK(47+KR,I) = EFORC(1+KRPZ)
      BLOCK(48+KR,I) = EFORC(2+KRPZ)
      BLOCK(49+KR,I) = EFORC(3+KRPZ)
      KR3 = 1 + KRPZ/3
      IF(.NOT.LSYS78) BLOCK(50+KR,I) = ECHRG(KR3)
  360 CONTINUE
C
  370 CONTINUE
C
C     COPY STRESSES AND FORCES INTO OUTPUT BLOCKS
C
  380 CONTINUE
      J = 2
      K = 1
      L = 0
      ISTRES (1) = ELEMID
      ISTRES (2) = NELHAR
      DO 400 I = 1,NS
      J = J + 1
      STRES(J) = ESTRES(I)
C
      IF (I/6 .NE. K) GO TO 400
      K = K + 1
      DO 390 II = 1,3
      J = J + 1
      L = L + 1
      STRES(J) = EFLUX(L)
  390 CONTINUE
C
  400 CONTINUE
      K = 0
      J = 2
      L = 1
      IFORCE(1) = ELEMID
      IFORCE(2) = NELHAR
      DO 500 I  = 1,NUMPT
      DO 500 KK = 1,NDOF
      J = J + 1
      K = K + 1
      FORCE(J) = EFORC(K)
C
      IF (K/3 .NE. L) GO TO 500
      J = J + 1
      FORCE(J) = ECHRG(L)
      L = L + 1
C
  500 CONTINUE
C
      IF (KTYPE.EQ.1 .OR. (KTYPE.EQ.2 .AND. IPART.EQ.1)) GO TO 1001
  550 CONTINUE
C
C     INSERT HARMONIC STRESSES AND FORCES INTO CLOCK
C
      DO 690 I = 1,14
      IF (ICLOCK(1,I) .EQ. 1) GO TO 700
      IF (HARM .EQ. 0.0) GO TO 660
      NPHI   = HARM*CLOCK(1,I)*DEGRAD
      SINPHI = SIN(NPHI)
      CONPHI = COS(NPHI)
      GO TO (630,600), SORC
  600 CONTINUE
C
      DO 610 IE = 1,5
      KE   = 9*(IE-1)
      KEPZ = 6*(IE-1)
      CLOCK(2+KE,I) = CLOCK(2+KE,I) + CONPHI*ESTRES(1+KEPZ)
      CLOCK(3+KE,I) = CLOCK(3+KE,I) + CONPHI*ESTRES(2+KEPZ)
      CLOCK(4+KE,I) = CLOCK(4+KE,I) + CONPHI*ESTRES(3+KEPZ)
      CLOCK(5+KE,I) = CLOCK(5+KE,I) + CONPHI*ESTRES(4+KEPZ)
      CLOCK(6+KE,I) = CLOCK(6+KE,I) + SINPHI*ESTRES(5+KEPZ)
      CLOCK(7+KE,I) = CLOCK(7+KE,I) + SINPHI*ESTRES(6+KEPZ)
C
      IF (LSYS78) GO TO 610
      KEPZ2 = KEPZ/2
      CLOCK( 8+KE,I) = CLOCK( 8+KE,I) + CONPHI*EFLUX (1+KEPZ2)
      CLOCK( 9+KE,I) = CLOCK( 9+KE,I) + CONPHI*EFLUX (2+KEPZ2)
      CLOCK(10+KE,I) = CLOCK(10+KE,I) + SINPHI*EFLUX (3+KEPZ2)
  610 CONTINUE
C
      DO 620 IR = 1,4
      KR   = 4*(IR-1)
      KRPZ = 3*(IR-1)
      CLOCK(47+KR,I) = CLOCK(47+KR,I) + CONPHI*EFORC(1+KRPZ)
      CLOCK(48+KR,I) = CLOCK(48+KR,I) + SINPHI*EFORC(2+KRPZ)
      CLOCK(49+KR,I) = CLOCK(49+KR,I) + CONPHI*EFORC(3+KRPZ)
      KR3 = 1 + KRPZ/3
      IF(.NOT.LSYS78) CLOCK(50+KR,I) = CLOCK(50+KR,I) +CONPHI*ECHRG(KR3)
  620 CONTINUE
      GO TO 690
C
  630 CONTINUE
      DO 640 IE = 1,5
      KE   = 9*(IE-1)
      KEPZ = 6*(IE-1)
      CLOCK(2+KE,I) = CLOCK(2+KE,I) + SINPHI*ESTRES(1+KEPZ)
      CLOCK(3+KE,I) = CLOCK(3+KE,I) + SINPHI*ESTRES(2+KEPZ)
      CLOCK(4+KE,I) = CLOCK(4+KE,I) + SINPHI*ESTRES(3+KEPZ)
      CLOCK(5+KE,I) = CLOCK(5+KE,I) + SINPHI*ESTRES(4+KEPZ)
      CLOCK(6+KE,I) = CLOCK(6+KE,I) - CONPHI*ESTRES(5+KEPZ)
      CLOCK(7+KE,I) = CLOCK(7+KE,I) - CONPHI*ESTRES(6+KEPZ)
C
      IF (LSYS78) GO TO 640
      KEPZ2 = KEPZ/2
      CLOCK( 8+KE,I) = CLOCK( 8+KE,I) + SINPHI*EFLUX(1+KEPZ2)
      CLOCK( 9+KE,I) = CLOCK( 9+KE,I) + SINPHI*EFLUX(2+KEPZ2)
      CLOCK(10+KE,I) = CLOCK(10+KE,I) - CONPHI*EFLUX(3+KEPZ2)
  640 CONTINUE
C
      DO 650 IR = 1,4
      KR   = 4*(IR-1)
      KRPZ = 3*(IR-1)
      CLOCK(47+KR,I) = CLOCK(47+KR,I) + SINPHI*EFORC(1+KRPZ)
      CLOCK(48+KR,I) = CLOCK(48+KR,I) - CONPHI*EFORC(2+KRPZ)
      CLOCK(49+KR,I) = CLOCK(49+KR,I) + SINPHI*EFORC(3+KRPZ)
      KR3 = 1 + KRPZ/3
      IF(.NOT.LSYS78) CLOCK(50+KR,I) = CLOCK(50+KR,I) +SINPHI*ECHRG(KR3)
  650 CONTINUE
      GO TO 690
C
  660 DO 670 IE = 1,5
      KE   = 9*(IE-1)
      KEPZ = 6*(IE-1)
      CLOCK(2+KE,I) = ESTRES(1+KEPZ)
      CLOCK(3+KE,I) = ESTRES(2+KEPZ)
      CLOCK(4+KE,I) = ESTRES(3+KEPZ)
      CLOCK(5+KE,I) = ESTRES(4+KEPZ)
      CLOCK(6+KE,I) = ESTRES(5+KEPZ)
      CLOCK(7+KE,I) = ESTRES(6+KEPZ)
C
      IF (LSYS78) GO TO 670
      KEPZ2 = KEPZ/2
      CLOCK( 8+KE,I) = EFLUX(1+KEPZ2)
      CLOCK( 9+KE,I) = EFLUX(2+KEPZ2)
      CLOCK(10+KE,I) = EFLUX(3+KEPZ2)
  670 CONTINUE
C
      DO 680 IR = 1,4
      KR   = 4*(IR-1)
      KRPZ = 3*(IR-1)
      CLOCK(47+KR,I) = EFORC(1+KRPZ)
      CLOCK(48+KR,I) = EFORC(2+KRPZ)
      CLOCK(49+KR,I) = EFORC(3+KRPZ)
      KR3 = 1 + KRPZ/3
      IF(.NOT.LSYS78) CLOCK(50+KR,I) = ECHRG(KR3)
  680 CONTINUE
C
  690 CONTINUE
C
C     COPY STRESSES AND FORCES INTO OUTPUT BLOCKS
C
  700 CONTINUE
      J = 2
      K = 1
      L = 0
      ISTRES (1) = ELEMID
      ISTRES (2) = NELHAR
      DO 720 I = 1,NS
      J = J + 1
      STRES(J) = ESTRES(I)
C
      IF (I/6 .NE. K) GO TO 720
      K = K + 1
      DO 710 II = 1,3
      J = J + 1
      L = L + 1
      STRES(J) = EFLUX(L)
  710 CONTINUE
  720 CONTINUE
C
      K = 0
      J = 2
      L = 1
      IFORCE(1) = ELEMID
      IFORCE(2) = NELHAR
      DO 800 I  = 1,NUMPT
      DO 800 KK = 1,NDOF
      J = J + 1
      K = K + 1
      FORCE(J) = EFORC(K)
C
      IF (K/3 .NE. L) GO TO 800
      J = J + 1
      FORCE(J) = ECHRG(L)
      L = L + 1
  800 CONTINUE
C
 1001 CONTINUE
C
      RETURN
      END


text:
module curl
  use iso_c_binding

  implicit none

  include "constants.f90"

  interface
     subroutine curl_easy_cleanup(curl) &
          bind(c, name="curl_easy_cleanup")
       use iso_c_binding, only: c_ptr
       type(c_ptr), value :: curl
     end subroutine curl_easy_cleanup

     function curl_easy_init() &
          bind(c, name="curl_easy_init")
       use iso_c_binding, only: c_ptr
       type(c_ptr) :: curl_easy_init
     end function curl_easy_init

     function curl_easy_perform(handle) &
          bind(c, name="curl_easy_perform")
       use iso_c_binding, only: c_int, c_ptr
       type(c_ptr), value :: handle
       integer(c_int) :: curl_easy_perform
     end function curl_easy_perform

     !! See: https://curl.haxx.se/docs/todo.html#Typesafe_curl_easy_setopt
     function curl_easy_set_ptr(handle, option, param) &
          bind(c, name="curl_easy_setopt")
       use iso_c_binding, only: c_int, c_ptr
       type(c_ptr), value :: handle
       integer(c_int), value :: option
       type(c_ptr), value :: param
       integer(c_int) :: curl_easy_set_ptr
     end function curl_easy_set_ptr
  end interface
end module curl

max_stars_repo_name: dram/fortran-curl

max_issues_repo_name: dram/fortran-curl

max_forks_repo_name: dram/fortran-curl


        !COMPILER-GENERATED INTERFACE MODULE: Fri Mar  6 15:36:23 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE GEMLITE_CYCLECLEAN__genmod
          INTERFACE
            SUBROUTINE GEMLITE_CYCLECLEAN(DUM_SFXSUMROK1_GEM)
              REAL(KIND=8), INTENT(INOUT) :: DUM_SFXSUMROK1_GEM(101,36, &
     &36)
            END SUBROUTINE GEMLITE_CYCLECLEAN
          END INTERFACE
        END MODULE GEMLITE_CYCLECLEAN__genmod


text:
*----------------------------------------------------------------------|
      subroutine DNCHBV( m, t, H,ldh, y, wsp )

      implicit none
      integer          m, ldh
      double precision t, H(ldh,m), y(m)
      complex*16       wsp(m*(m+2))

*-----Purpose----------------------------------------------------------|
*
*---  DNCHBV computes y = exp(t*H)*y using the partial fraction
*     expansion of the uniform rational Chebyshev approximation
*     to exp(-x) of type (14,14). H is assumed to be upper-Hessenberg.
*     About 14-digit accuracy is expected if the matrix H is negative
*     definite. The algorithm may behave poorly otherwise.
*
*-----Arguments--------------------------------------------------------|
*
*     m       : (input) order of the Hessenberg matrix H
*
*     t       : (input) time-scaling factor (can be < 0).
*
*     H(ldh,m): (input) upper Hessenberg matrix.
*
*     y(m)    : (input/output) on input the operand vector,
*               on output the resulting vector exp(t*H)*y.
*
*     wsp     : (workspace). Observe that a double precision vector of
*               length 2*m*(m+2) can be used as well when calling this
*               routine (thus avoiding an idle complex array elsewhere)
*
*----------------------------------------------------------------------|
*     Roger B. Sidje (rbs@maths.uq.edu.au)
*     EXPOKIT: Software Package for Computing Matrix Exponentials.
*     ACM - Transactions On Mathematical Software, 24(1):130-156, 1998
*----------------------------------------------------------------------|
*
      complex*16 ZERO
      integer ndeg, i, j, k, ip, ih, iy, iz
      parameter ( ndeg=7, ZERO=(0.0d0,0.0d0) )
      double precision alpha0
      complex*16 alpha(ndeg), theta(ndeg), tmpc

      intrinsic ABS,DBLE,MIN

*---  Pointers ...

      ih = 1
      iy = ih + m*m
      iz = iy + m

*---  Coefficients and poles of the partial fraction expansion...

      alpha0  =  0.183216998528140087D-11
      alpha(1)=( 0.557503973136501826D+02,-0.204295038779771857D+03)
      alpha(2)=(-0.938666838877006739D+02, 0.912874896775456363D+02)
      alpha(3)=( 0.469965415550370835D+02,-0.116167609985818103D+02)
      alpha(4)=(-0.961424200626061065D+01,-0.264195613880262669D+01)
      alpha(5)=( 0.752722063978321642D+00, 0.670367365566377770D+00)
      alpha(6)=(-0.188781253158648576D-01,-0.343696176445802414D-01)
      alpha(7)=( 0.143086431411801849D-03, 0.287221133228814096D-03)

      theta(1)=(-0.562314417475317895D+01, 0.119406921611247440D+01)
      theta(2)=(-0.508934679728216110D+01, 0.358882439228376881D+01)
      theta(3)=(-0.399337136365302569D+01, 0.600483209099604664D+01)
      theta(4)=(-0.226978543095856366D+01, 0.846173881758693369D+01)
      theta(5)=( 0.208756929753827868D+00, 0.109912615662209418D+02)
      theta(6)=( 0.370327340957595652D+01, 0.136563731924991884D+02)
      theta(7)=( 0.889777151877331107D+01, 0.166309842834712071D+02)
*
*---  Accumulation of the contribution of each pole ...
*
      do j = 1,m
         wsp(iz+j-1) = y(j)
         y(j) = y(j)*alpha0
      enddo
      do ip = 1,ndeg
*---     Solve each fraction using Gaussian elimination with pivoting...
         do j = 1,m
            wsp(iy+j-1) = wsp(iz+j-1)
            do i = 1,MIN( j+1,m )
               wsp(ih+(j-1)*m+i-1) = -t*H(i,j)
            enddo
            wsp(ih+(j-1)*m+j-1) = wsp(ih+(j-1)*m+j-1)-theta(ip)
            do k = i,m
               wsp(ih+(j-1)*m+k-1) = ZERO
            enddo
         enddo
         do i = 1,m-1
*---        Get pivot and exchange rows ...
            if (ABS(wsp(ih+(i-1)*m+i-1)).lt.ABS(wsp(ih+(i-1)*m+i))) then
               call ZSWAP( m-i+1, wsp(ih+(i-1)*m+i-1),m,
     .                     wsp(ih+(i-1)*m+i),m )
               call ZSWAP( 1, wsp(iy+i-1),1, wsp(iy+i),1 )
            endif
*---        Forward eliminiation ...
            tmpc = wsp(ih+(i-1)*m+i) / wsp(ih+(i-1)*m+i-1)
            call ZAXPY( m-i, -tmpc, wsp(ih+i*m+i-1),m, wsp(ih+i*m+i),m )
            wsp(iy+i) = wsp(iy+i) - tmpc*wsp(iy+i-1)
         enddo
*---     Backward substitution ...
         do i = m,1,-1
            tmpc = wsp(iy+i-1)
            do j = i+1,m
               tmpc = tmpc - wsp(ih+(j-1)*m+i-1)*wsp(iy+j-1)
            enddo
            wsp(iy+i-1) = tmpc / wsp(ih+(i-1)*m+i-1)
         enddo
*---     Accumulate the partial result in y ...
         do j = 1,m
            y(j) = y(j) + DBLE( alpha(ip)*wsp(iy+j-1) )
         enddo
      enddo
      END
*----------------------------------------------------------------------|

ext: f

max_stars_repo_name: Cirdans-Home/psfun

max_issues_repo_name: Cirdans-Home/psfun

max_forks_repo_name: Cirdans-Home/psfun


text:
      SUBROUTINE MATR2_SWAP_ROWS(IDIM, JDIM, MATRIX, IS, IT)
        REAL MATRIX, VMAX
        DIMENSION MATRIX(IDIM, JDIM)

        DO 10 J = 1, JDIM
          TMP = MATRIX(TS, J)
          MATRIX(IT, J) = MATRIX(IS, J)
          MATRIX(IS, J) = TMP
10      CONTINUE
      END

      FUNCTION VECTOR_MAX(VECTOR, SIZE, IDX)
        INTEGER SIZE
        DIMENSION VECTOR(SIZE)

        DO 20 I = 1, SIZE
          IF (I.EQ.1) THEN
            VECTOR_MAX = VECTOR(I)
            IDX = I
          ELSE
            IF (VECTOR(I).GT.VECTOR_MAX) THEN
              IDX = I
              VECTOR_MAX = VECTOR(I)
            END IF
          END IF
20      CONTINUE
      END

max_stars_repo_name: unixs/numerical-la-UL-decomposition

max_issues_repo_name: unixs/numerical-la-UL-decomposition

max_forks_repo_name: unixs/numerical-la-UL-decomposition


text:
      SUBROUTINE PDQRT16( TRANS, M, N, NRHS, A, IA, JA, DESCA, X, IX,
     $                    JX, DESCX, B, IB, JB, DESCB, RWORK, RESID )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            IA, IB, IX, JA, JB, JX, M, N, NRHS
      DOUBLE PRECISION   RESID
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), DESCB( * ), DESCX( * )
      DOUBLE PRECISION   A( * ), B( * ), RWORK( * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  PDQRT16 computes the residual for a solution of a system of linear
*  equations  sub( A )*sub( X ) = B  or  sub( A' )*sub( X ) = B:
*     RESID = norm(B - sub( A )*sub( X ) ) /
*             ( max(m,n) * norm(sub( A ) ) * norm(sub( X ) ) * EPS ),
*  where EPS is the machine epsilon, sub( A ) denotes
*  A(IA:IA+N-1,JA,JA+N-1), and sub( X ) denotes
*  X(IX:IX+N-1, JX:JX+NRHS-1).
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  TRANS   (global input) CHARACTER*1
*          Specifies the form of the system of equations:
*          = 'N':  sub( A )*sub( X ) = sub( B )
*          = 'T':  sub( A' )*sub( X )= sub( B ), where A' is the
*                  transpose of sub( A ).
*          = 'C':  sub( A' )*sub( X )= B, where A' is the transpose
*                  of sub( A ).
*
*  M       (global input) INTEGER
*          The number of rows to be operated on, i.e. the number of rows
*          of the distributed submatrix sub( A ). M >= 0.
*
*  N       (global input) INTEGER
*          The number of columns to be operated on, i.e. the number of
*          columns of the distributed submatrix sub( A ). N >= 0.
*
*  NRHS    (global input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the distributed submatrix sub( B ). NRHS >= 0.
*
*  A       (local input) DOUBLE PRECISION pointer into the local
*          memory to an array of dimension (LLD_A,LOCc(JA+N-1)).
*          The original M x N matrix A.
*
*  IA      (global input) INTEGER
*          The row index in the global array A indicating the first
*          row of sub( A ).
*
*  JA      (global input) INTEGER
*          The column index in the global array A indicating the
*          first column of sub( A ).
*
*  DESCA   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix A.
*
*  X       (local input) DOUBLE PRECISION pointer into the local
*          memory to an array of dimension (LLD_X,LOCc(JX+NRHS-1)). This
*          array contains the local pieces of the computed solution
*          distributed vectors for the system of linear equations.
*
*  IX      (global input) INTEGER
*          The row index in the global array X indicating the first
*          row of sub( X ).
*
*  JX      (global input) INTEGER
*          The column index in the global array X indicating the
*          first column of sub( X ).
*
*  DESCX   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix X.
*
*  B       (local input/local output) DOUBLE PRECISION pointer into
*          the local memory to an array of dimension
*          (LLD_B,LOCc(JB+NRHS-1)).  On entry, this array contains the
*          local pieces of the distributes right hand side vectors for
*          the system of linear equations. On exit, sub( B ) is over-
*          written with the difference sub( B ) - sub( A )*sub( X ) or
*          sub( B ) - sub( A )'*sub( X ).
*
*  IB      (global input) INTEGER
*          The row index in the global array B indicating the first
*          row of sub( B ).
*
*  JB      (global input) INTEGER
*          The column index in the global array B indicating the
*          first column of sub( B ).
*
*  DESCB   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix B.
*
*  RWORK   (local workspace) DOUBLE PRECISION array, dimension (LRWORK)
*          LWORK >= Nq0 if TRANS = 'N', and LRWORK >= Mp0 otherwise.
*
*          where
*
*          IROFFA = MOD( IA-1, MB_A ), ICOFFA = MOD( JA-1, NB_A ),
*          IAROW = INDXG2P( IA, MB_A, MYROW, RSRC_A, NPROW ),
*          IACOL = INDXG2P( JA, NB_A, MYCOL, CSRC_A, NPCOL ),
*          Mp0 = NUMROC( M+IROFFA, MB_A, MYROW, IAROW, NPROW ),
*          Nq0 = NUMROC( N+ICOFFA, NB_A, MYCOL, IACOL, NPCOL ),
*
*          INDXG2P and NUMROC are ScaLAPACK tool functions; MYROW,
*          MYCOL, NPROW and NPCOL can be determined by calling the
*          subroutine BLACS_GRIDINFO.
*
*  RESID   (global output) DOUBLE PRECISION
*          The maximum over the number of right hand sides of
*          norm( sub( B )- sub( A )*sub( X ) ) /
*          ( max(m,n) * norm( sub( A ) ) * norm( sub( X ) ) * EPS ).
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            ICTXT, IDUMM, J, MYCOL, MYROW, N1, N2, NPCOL,
     $                   NPROW
      DOUBLE PRECISION   ANORM, BNORM, EPS, XNORM
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   TEMP( 2 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   PDLAMCH, PDLANGE
      EXTERNAL           LSAME, PDLAMCH, PDLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, DGAMX2D, PDASUM, PDGEMM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Get grid parameters
*
      ICTXT = DESCA( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
*     Quick exit if M = 0 or N = 0 or NRHS = 0
*
      IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.EQ.0 ) THEN
         RESID = ZERO
         RETURN
      END IF
*
      IF( LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) ) THEN
         ANORM = PDLANGE( 'I', M, N, A, IA, JA, DESCA, RWORK )
         N1 = N
         N2 = M
      ELSE
         ANORM = PDLANGE( '1', M, N, A, IA, JA, DESCA, RWORK )
         N1 = M
         N2 = N
      END IF
*
      EPS = PDLAMCH( ICTXT, 'Epsilon' )
*
*     Compute  B - sub( A )*sub( X )  (or  B - sub( A' )*sub( X ) ) and
*     store in B.
*
      CALL PDGEMM( TRANS, 'No transpose', N1, NRHS, N2, -ONE, A, IA,
     $            JA, DESCA, X, IX, JX, DESCX, ONE, B, IB, JB, DESCB )
*
*     Compute the maximum over the number of right hand sides of
*        norm( sub( B ) - sub( A )*sub( X ) ) /
*        ( max(m,n) * norm( sub( A ) ) * norm( sub( X ) ) * EPS ).
*
      RESID = ZERO
      DO 10 J = 1, NRHS
*
         CALL PDASUM( N1, BNORM, B, IB, JB+J-1, DESCB, 1 )
         CALL PDASUM( N2, XNORM, X, IX, JX+J-1, DESCX, 1 )
*
*        Only the process columns owning the vector operands will have
*        the correct result, the other will have zero.
*
         TEMP( 1 ) = BNORM
         TEMP( 2 ) = XNORM
         IDUMM = 0
         CALL DGAMX2D( ICTXT, 'All', ' ', 2, 1, TEMP, 2, IDUMM, IDUMM,
     $                 -1, -1, IDUMM )
         BNORM = TEMP( 1 )
         XNORM = TEMP( 2 )
*
*        Every processes have ANORM, BNORM and XNORM now.
*
         IF( ANORM.EQ.ZERO .AND. BNORM.EQ.ZERO ) THEN
            RESID = ZERO
         ELSE IF( ANORM.LE.ZERO .OR. XNORM.LE.ZERO ) THEN
            RESID = ONE / EPS
         ELSE
            RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) /
     $              ( MAX( M, N )*EPS ) )
         END IF
*
   10 CONTINUE
*
      RETURN
*
*     End of PDQRT16
*
      END

max_stars_repo_name: jschueller/scalapack

max_issues_repo_name: jschueller/scalapack

max_forks_repo_name: jschueller/scalapack


text:
      SUBROUTINE CELLMASK
C
C CHANGE RECORD
C **  SUBROUTINE CELLMASK CONVERTS LAND CELLS TO WATER CELLS BY
C **  MASKING VARIABLES.  DEPTHS IN THE MASKED CELLS SHOULD BE INPUT AT
C **  THE END OF THE DXDY.INP FILE.
C
      USE GLOBAL
            LOGICAL    CELL_INSIDE_DOMAIN
      OPEN(1,FILE='MASK.INP',STATUS='UNKNOWN')
      DO NS=1,6
        READ(1,1)
      ENDDO
    1 FORMAT(80X)
      READ(1,*,ERR=1000) MMASK
      DO M=1,MMASK
        READ(1,*,ERR=1000) II,JJ,MTYPE
        I = XLOC(II)
        J = YLOC(JJ)
        L=LIJ(I,J)
        IF (CELL_INSIDE_DOMAIN(L)) THEN
            IF(MTYPE.EQ.1)THEN
              SUB(L)=0.
              SUBO(L)=0.
              UHDYE(L)=0.
              UHDY1E(L)=0.
              UHDY2E(L)=0.
              DO K=1,KC
                U(L,K)=0.
                U1(L,K)=0.
                U2(L,K)=0.
                UHDY(L,K)=0.
                UHDY1(L,K)=0.
                UHDY2(L,K)=0.
              ENDDO
            ENDIF
            IF(MTYPE.EQ.2)THEN
              SVB(L)=0.
              SVBO(L)=0.
              VHDXE(L)=0.
              VHDX1E(L)=0.
              VHDX2E(L)=0.
              DO K=1,KC
                V(L,K)=0.
                V1(L,K)=0.
                V2(L,K)=0.
                VHDX(L,K)=0.
                VHDX1(L,K)=0.
                VHDX2(L,K)=0.
              ENDDO
            ENDIF
            IF(MTYPE.EQ.3)THEN   ! *** PMC
              ! *** U Face
              SUB(L)=0.
              SUBO(L)=0.
              UHDYE(L)=0.
              UHDY1E(L)=0.
              UHDY2E(L)=0.
              DO K=1,KC
                U(L,K)=0.
                U1(L,K)=0.
                U2(L,K)=0.
                UHDY(L,K)=0.
                UHDY1(L,K)=0.
                UHDY2(L,K)=0.
              ENDDO
              ! *** V Face
              SVB(L)=0.
              SVBO(L)=0.
              VHDXE(L)=0.
              VHDX1E(L)=0.
              VHDX2E(L)=0.
              DO K=1,KC
                V(L,K)=0.
                V1(L,K)=0.
                V2(L,K)=0.
                VHDX(L,K)=0.
                VHDX1(L,K)=0.
                VHDX2(L,K)=0.
              ENDDO
            ENDIF
            IF(MTYPE.EQ.4)THEN   ! *** PMC - Change to MTYPE 4 for isolated waters
              LN=LNC(L)
              SUB(L)=0.
              SUBO(L)=0.
              UHDYE(L)=0.
              UHDY1E(L)=0.
              UHDY2E(L)=0.
              SUB(LEAST(L))=0.
              SUBO(LEAST(L))=0.
              UHDYE(LEAST(L))=0.
              UHDY1E(LEAST(L))=0.
              UHDY2E(LEAST(L))=0.
              SVB(L)=0.
              SVBO(L)=0.
              VHDXE(L)=0.
              VHDX1E(L)=0.
              VHDX2E(L)=0.
              SVB(LN)=0.
              SVBO(LN)=0.
              VHDXE(LN)=0.
              VHDX1E(LN)=0.
              VHDX2E(LN)=0.
              P(L)=0.
              P1(L)=0.
              DO K=1,KC
                B(L,K)=0.
                B1(L,K)=0.
                SAL(L,K)=0.
                SAL1(L,K)=0.
                TEM(L,K)=TEMO
                TEM1(L,K)=TEMO
                DYE(L,K)=0.
                DYE1(L,K)=0.
                SED(L,K,1)=0.
                SED1(L,K,1)=0.
                QQ(L,K)=0.
                QQ1(L,K)=0.
                QQL(L,K)=0.
                QQL1(L,K)=0.
                U(L,K)=0.
                U1(L,K)=0.
                U2(L,K)=0.
                UHDY(L,K)=0.
                UHDY1(L,K)=0.
                UHDY2(L,K)=0.
                U(LEAST(L),K)=0.
                U1(LEAST(L),K)=0.
                U2(LEAST(L),K)=0.
                UHDY(LEAST(L),K)=0.
                UHDY1(LEAST(L),K)=0.
                UHDY2(LEAST(L),K)=0.
                V(L,K)=0.
                V1(L,K)=0.
                V2(L,K)=0.
                VHDX(L,K)=0.
                VHDX1(L,K)=0.
                VHDX2(L,K)=0.
                V(LN,K)=0.
                V1(LN,K)=0.
                V2(LN,K)=0.
                VHDX(LN,K)=0.
                VHDX1(LN,K)=0.
                VHDX2(LN,K)=0.
              ENDDO
            ENDIF
      END IF
      ENDDO
      CLOSE(1)
C
C **  WRITE READ ERRORS ON CELLMASK
C
      GOTO 1002
 1000 WRITE(6,1001)
 1001 FORMAT('  READ ERROR ON FILE MASK.INP ')
      STOP
 1002 CONTINUE
      RETURN
      END


text:
program test
      logical :: flag1, flag2
      integer :: a = (2*3) * 2
      integer :: b = 2 * 3 * 2
      flag1 = a == b .and. b == 12
      if (flag1) a = 10
      PRINT *,a
end program test

max_stars_repo_name: clementval/fc

max_issues_repo_name: clementval/fc

max_forks_repo_name: clementval/fc


text:
subroutine nsc_CalculatePrimitivesLogic(a)
   use typre
   use Mod_NSCompressible

   implicit none

   class(NSCompressibleProblem) :: a

   logical :: isALE
   integer(ip)             :: calculate_primitives

   calculate_primitives=0

   call a%Mesh%GetALE(isALE)
   if (isALE) calculate_primitives=1

   if(a%nptra > 0) calculate_primitives=1

   if (a%npp_stepi(1)>0) then
      if (mod(a%istep,a%npp_stepi(1))==0) calculate_primitives=1
   endif
   if (a%npp_stepi(2)>0) then
      if (mod(a%istep,a%npp_stepi(2))==0) calculate_primitives=1
   endif
   if (a%npp_stepi(3)>0) then
      if (mod(a%istep,a%npp_stepi(3))==0) calculate_primitives=1
   endif
   if (a%npp_stepi(7)>0) then
      if (mod(a%istep,a%npp_stepi(7))==0) calculate_primitives=1
   endif
   if (a%npp_stepi(15)>0) then
          calculate_primitives=1
   endif

   if (calculate_primitives == 1) call a%CalculatePrimitives(1)

end subroutine nsc_CalculatePrimitivesLogic

subroutine nsc_CalculatePrimitives(a,ncomp)
   use typre
   use Mod_NSCompressible

   implicit none

   class(NSCompressibleProblem) :: a
   integer(ip),intent(in)   :: ncomp

   integer(ip)             :: iffix_vel,iffix_tem
   integer(ip)             :: idime,ipoin,ndime,npoin,icomp
   real(rp)                :: acvis,actco,accph,accvh
   real(rp)                :: invden, auxiliar

   call a%Mesh%GetNpoin(npoin)
   call a%Mesh%GetNdime(ndime)
   !Physical Parameters
   call a%GetPhysicalParameters(acvis,actco,accph,accvh)

   do icomp = 1,ncomp

      do ipoin = 1,npoin

         do idime = 1,ndime
            a%veloc(idime,ipoin,icomp) = a%momen(idime,ipoin,icomp) / a%densf(ipoin,icomp)
            iffix_vel = a%kfl_fixno(idime+1,ipoin)
            if(iffix_vel==1) then
               a%veloc(idime,ipoin,icomp) = a%bvess(idime+1,ipoin,1)
            end if
         end do

         ! Ideal Gas State Law (could expand into a module)
         invden = 1.0_rp / a%densf(ipoin,icomp)

         auxiliar = (a%energ(ipoin,icomp) - dot_product(a%momen(:,ipoin,icomp),a%momen(:,ipoin,icomp)) * invden / 2.0_rp )/ accvh

         a%tempe(ipoin,icomp) = (invden * auxiliar) - a%reltem
         a%press(ipoin,icomp) = ((accph - accvh) * auxiliar) - a%relpre

         iffix_tem = a%kfl_fixno(a%ndofbc,ipoin)
         if(iffix_tem==1) then
             a%tempe(ipoin,icomp)= a%bvess(a%ndofbc,ipoin,1)
         end if

      enddo
   enddo

end subroutine nsc_CalculatePrimitives

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text:
!
! Downloads a dictionary entry, using libcurl via fortran-curl.
!
module callback
use curl,    only : c_f_str_ptr
implicit none
private
public :: response_callback
contains
   ! static size_t callback(char *ptr, size_t size, size_t nmemb, void *data)
function response_callback(ptr, size, nmemb, data) bind(c)
!! Callback function for `CURLOPT_WRITEFUNCTION` that appends the
!! response chunk in `ptr` to the given file with file name in pointer
!! `data`.
!!
!! This callback function might be called several times by libcurl,
!! passing in more chunks of the response.
use, intrinsic :: iso_c_binding, only: c_associated, c_f_pointer, c_ptr, c_size_t
type(c_ptr),            intent(in), value :: ptr               !! C pointer to a chunk of the response.
integer(kind=c_size_t), intent(in), value :: size              !! Always 1.
integer(kind=c_size_t), intent(in), value :: nmemb             !! Size of the response chunk.
type(c_ptr),            intent(in), value :: data              !! C pointer to argument passed by caller.
integer(kind=c_size_t)                    :: response_callback !! Function return value.
character(len=32), pointer                :: file_name         !! File to store response to.
character(len=:), allocatable             :: chunk             !! Response chunk.
integer(kind=8)                           :: fu, rc

   response_callback = int(0, kind=c_size_t)

   if (.not. c_associated(ptr)) return
   if (.not. c_associated(data)) return

   call c_f_pointer(data, file_name)
   if (len_trim(file_name) == 0) return

   allocate (character(len=nmemb) :: chunk)
   call c_f_str_ptr(ptr, chunk)

   if(file_name.ne.' ')then
      open (access   = 'stream', &
            action   = 'write', &
            file     = trim(file_name), &
            form     = 'unformatted', &
            iostat   = rc, &
            newunit  = fu, &
            position = 'append', &
            status   = 'unknown')
   endif
   if (rc /= 0) return
   !!write (fu) chunk
   write (*,'(*(a))') chunk
   close (fu)
   ! get rid of trash file. KLUDGE
   open(file='null.garbage',newunit=fu,iostat=rc)
   if(rc.eq.0) close(unit=fu,iostat=rc,status='delete')
   deallocate (chunk)
   response_callback = nmemb
end function response_callback
end module callback

program main
use, intrinsic :: iso_c_binding
use  M_CLI2, only  : set_args, sget, lget, specified, words=>unnamed
use :: curl
use :: callback
implicit none
character(len=*), parameter  :: DEFAULT_PROTOCOL = 'dict'
character(len=32),target     :: file_name
type(c_ptr)                  :: curl_ptr
integer                      :: rc
integer                      :: i
character(len=:),allocatable :: URL, SERVER, LIKE
logical                      :: VERBOSE
character(len=:),allocatable :: help_text(:)
character(len=:),allocatable :: version_text(:)

    call setup()
    call set_args(' --server www.dict.org --filename:o " " --url:U " " --like:l " "',help_text,version_text)
    SERVER=sget('server')
    file_name=sget('filename')
    url=sget('url')
    verbose=lget('verbose')
    like=sget('like')
    if (SERVER=='')SERVER='www.dict.org'

    curl_ptr = curl_easy_init()

    if (.not. c_associated(curl_ptr)) then
        stop 'Error: curl_easy_init() failed'
    endif

    ! Set curl options.
    rc = curl_easy_setopt(curl_ptr, CURLOPT_DEFAULT_PROTOCOL, DEFAULT_PROTOCOL // c_null_char)
    rc = curl_easy_setopt(curl_ptr, CURLOPT_FOLLOWLOCATION,   int( 1, kind=8))
    rc = curl_easy_setopt(curl_ptr, CURLOPT_TIMEOUT,          int(10, kind=8))
    rc = curl_easy_setopt(curl_ptr, CURLOPT_NOSIGNAL,         int( 1, kind=8))
    rc = curl_easy_setopt(curl_ptr, CURLOPT_CONNECTTIMEOUT,   int(10, kind=8))
    rc = curl_easy_setopt(curl_ptr, CURLOPT_WRITEFUNCTION,    c_funloc(response_callback))
    ! for some reason have to set this or get file created with garbage name
    if(file_name.eq.' ') file_name='null.garbage'
    rc = curl_easy_setopt(curl_ptr, CURLOPT_WRITEDATA,        c_loc(file_name))

    if(url.ne.' ')then
          rc = curl_easy_setopt(curl_ptr, CURLOPT_URL,URL// c_null_char)
          ! Send request.
          call showstat()
    else
       if(size(words).eq.0)words=[' ']
       do i=1,size(words)
          if(specified('like'))then
             if(words(i).eq.' ')then
                URL='dict://'//SERVER//'/show strat' ! if no words and blank --like show strategies
             elseif(like.eq.' ')then  ! if words and --like without a specific strategy use soundex and lev
                URL='dict://'//SERVER//'/m:'//trim(words(i))//'::soundex'
                call showstat()
                URL='dict://'//SERVER//'/m:'//trim(words(i))//'::lev'
             else  ! if strategy specified use it
                URL='dict://'//SERVER//'/m:'//trim(words(i))//'::'//like
             endif
          elseif(words(i).eq.'')then  ! if no strategy and no words list dictionaries
             URL='dict://'//SERVER//'/show:db' ! list all the dictionaries
          elseif(index(words(i),':').ne.0)then  ! assume if colon present a dictionary was specified
             URL='dict://'//SERVER//'/d:'//trim(words(i))
          else
             URL='dict://'//SERVER//'/d:'//trim(words(i))//':all' ! default to all dictionaries
          endif
          call showstat()
       enddo
    endif

    call curl_easy_cleanup(curl_ptr)
contains

subroutine showstat()
integer  :: istat
   if(verbose) write(*,'(*(g0))')'URL=',url
   rc = curl_easy_setopt(curl_ptr, CURLOPT_URL,              URL// c_null_char)
   !print '(5a)', 'Saving "', URL, '" to file "', trim(file_name), '" ...'
   ! Send request.
   istat=curl_easy_perform(curl_ptr)
   if (istat /= CURLE_OK) then
      print '(a)', 'Error: curl_easy_perform() failed'
   endif
end subroutine showstat

subroutine setup()
help_text=[ CHARACTER(LEN=128) :: &
'NAME                                                                            ',&
'   dict(1sh) - Get definition of a word using DICT Protocol and libcurl(3c)     ',&
'   (LICENSE:PD)                                                                 ',&
'                                                                                ',&
'SYNOPSIS                                                                        ',&
'   fpm-dict(1) - [word(s) [--like [strategy]] [--server SERVER]]|               ',&
'             -url FULL_URL|                                                     ',&
'             [--help|--version]                                                 ',&
'                                                                                ',&
'DESCRIPTION                                                                     ',&
'   By default fpm-dict(1) looks up the definitions of the given words in        ',&
'   the dictionaries at dict://dict.org/ on port 2628.                           ',&
'                                                                                ',&
'   You can also search for similar words, words by substring or regular         ',&
'   expression, as substrings ...                                                ',&
'                                                                                ',&
'   With no options a table of the available dictionaries is produced.           ',&
'                                                                                ',&
'   Note there are many dictionaries hosted on servers around the WWW.           ',&
'                                                                                ',&
'   fpm-dict(1) uses the DICT Protocol as described in RFC2229 and the           ',&
'   libcurl(3c) library via a clone of the fortran-curl(3f) interface.           ',&
'                                                                                ',&
'OPTIONS                                                                         ',&
'    word(s)       word to find and display the definition of. Can be of         ',&
'                  form word:dictionary. The default dictionary is "all".        ',&
'    --like strategy   look for words like the word specified instead of         ',&
'                      showing definitions, using an optional search             ',&
'                      strategy. defaults to trying to guess the spelling        ',&
'                      of the word(s) assuming it is misspelled. If no           ',&
'                      words are present defaults to showing available           ',&
'                      strategies.                                               ',&
'    --server      DICT server name. Default is "www.dict.org".                  ',&
'    --url         directly specify url:                                         ',&
'                                                                                ',&
'                     dict://HOST:PORT/m:MATCH_STRING:DATABASE_NAME:STRATEGY     ',&
'                     dict://HOST:PORT/d:WORD:DATABASE_NAME                      ',&
'    --help,-h     display this help and exit                                    ',&
'    --version,-v  output version information and exit                           ',&
'                                                                                ',&
'EXAMPLE                                                                         ',&
'  Sample usage:                                                                 ',&
'                                                                                ',&
'                                                                                ',&
'      > fpm-dict              # list dictionary names and descriptions          ',&
'      > fpm-dict bash         # search all the dictionaries for specified word  ',&
'      > fpm-dict bash:        # use just the default dictionary                 ',&
'      > # Find the meaning of "bash" in the "computer terms" dictionary:        ',&
'      > fpm-dict bash:foldoc                                                    ',&
'      > fpm-dict gold:elements     # just use the "elements" dictionary         ',&
'      > fpm-dict slovakia:world02                                               ',&
'      >                                                                         ',&
'      > fpm-dict bash --like  # look for words like the one specified           ',&
'      > fpm-dict ''q[aeiou]'' --like RE # use RE (Regular Expression)           ',&
'      > fpm-dict urban --like substring                                         ',&
'      >                                                                         ',&
'      > # direct use of RFC 2229 syntax                                         ',&
'      > fpm-dict --url dict://www.dict.org/help                                 ',&
'      > fpm-dict --url ''dict://www.dict.org/show strat''                       ',&
'      > fpm-dict --url dict://www.dict.org/m:urban:english:regexp               ',&
'                                                                                ',&
'SEE ALSO                                                                        ',&
'   look(1), spell(1), aspell(1), ispell(1), wnb(1WordNet)                       ',&
'']
!>
!!##NAME
!!    dict(1sh) - Get definition of a word using DICT Protocol and libcurl(3c)
!!    (LICENSE:PD)
!!
!!##SYNOPSIS
!!
!!    fpm-dict(1) - [word(s) [--like [strategy]] [--server SERVER]]|
!!              -url FULL_URL|
!!              [--help|--version]
!!
!!##DESCRIPTION
!!    By default fpm-dict(1) looks up the definitions of the given words in
!!    the dictionaries at dict://dict.org/ on port 2628.
!!
!!    You can also search for similar words, words by substring or regular
!!    expression, as substrings ...
!!
!!    With no options a table of the available dictionaries is produced.
!!
!!    Note there are many dictionaries hosted on servers around the WWW.
!!
!!    fpm-dict(1) uses the DICT Protocol as described in RFC2229 and the
!!    libcurl(3c) library via a clone of the fortran-curl(3f) interface.
!!
!!##OPTIONS
!!     word(s)       word to find and display the definition of. Can be of
!!                   form word:dictionary. The default dictionary is "all".
!!     --like strategy   look for words like the word specified instead of
!!                       showing definitions, using an optional search
!!                       strategy. defaults to trying to guess the spelling
!!                       of the word(s) assuming it is misspelled. If no
!!                       words are present defaults to showing available
!!                       strategies.
!!     --server      DICT server name. Default is "www.dict.org".
!!     --url         directly specify url:
!!
!!                      dict://HOST:PORT/m:MATCH_STRING:DATABASE_NAME:STRATEGY
!!                      dict://HOST:PORT/d:WORD:DATABASE_NAME
!!     --help,-h     display this help and exit
!!     --version,-v  output version information and exit
!!
!!##EXAMPLE
!!
!!   Sample usage:
!!
!!
!!       > fpm-dict              # list dictionary names and descriptions
!!       > fpm-dict bash         # search all the dictionaries for specified word
!!       > fpm-dict bash:        # use just the default dictionary
!!       > # Find the meaning of "bash" in the "computer terms" dictionary:
!!       > fpm-dict bash:foldoc
!!       > fpm-dict gold:elements     # just use the "elements" dictionary
!!       > fpm-dict slovakia:world02
!!       >
!!       > fpm-dict bash --like  # look for words like the one specified
!!       > fpm-dict 'q[aeiou]' --like RE # use RE (Regular Expression)
!!       > fpm-dict urban --like substring
!!       >
!!       > # direct use of RFC 2229 syntax
!!       > fpm-dict --url dict://www.dict.org/help
!!       > fpm-dict --url 'dict://www.dict.org/show strat'
!!       > fpm-dict --url dict://www.dict.org/m:urban:english:regexp
!!
!!##SEE ALSO
!!    look(1), spell(1), aspell(1), ispell(1), wnb(1WordNet)

version_text=[ CHARACTER(LEN=128) :: &
'@(#)PRODUCT:         GPF (General Purpose Fortran) utilities and examples>      ',&
'@(#)PROGRAM:         fpm-dict(1)>                                               ',&
'@(#)DESCRIPTION:     Get definition of a word using DICT Protocol and libcurl(3c)>',&
'@(#)VERSION:         3.0, 20210127>                                             ',&
'@(#)AUTHOR:          John S. Urban>                                             ',&
'@(#)REPORTING BUGS:  urbanjost@comcast.net>                                     ',&
'@(#)HOME PAGE:       http://www.urbanjost.altervista.org/index.html>            ',&
'@(#)LICENSE:         Public Domain. This is free software: you are free to change and redistribute it.>',&
'@(#)                 There is NO WARRANTY, to the extent permitted by law.>     ',&
'']
end subroutine setup
end program main

max_stars_repo_name: urbanjost/plugins

max_issues_repo_name: urbanjost/plugins

max_forks_repo_name: urbanjost/plugins


text:
C$Procedure PAGMAN (Page Manager)

      SUBROUTINE PAGMAN ( WHICH, LINE, VALUE )
      IMPLICIT NONE

C$ Abstract
C
C     This routine serves as an umbrella for a collection of entry
C     points that manage the layout and printing of a series of
C     pages of text that may include fixed titles, headers, and
C     footers.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     REPORTS
C
C$ Keywords
C
C     OUTPUT
C     TEXT
C     FORMATTING
C
C$ Declarations

      EXTERNAL              PROMPT

      CHARACTER*(*)         WHICH
      CHARACTER*(*)         LINE
      INTEGER               VALUE

      INTEGER               MXWDTH
      PARAMETER           ( MXWDTH = 255 )

      INTEGER               ROOMH
      PARAMETER           ( ROOMH =  15 )

      INTEGER               ROOMT
      PARAMETER           ( ROOMT =  10 )

      INTEGER               ROOMF
      PARAMETER           ( ROOMF =  10 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     WHICH      I   indicates which section to send lines of text to
C     LINE       I   a line of text
C     ATTR       I   the name of a global page attribute to be set
C     VALUE      I   the value of some global page attribute
C
C$ Detailed_Input
C
C     See the individual entry points for details
C
C$ Detailed_Output
C
C     None.
C
C$ Parameters
C
C     MXWDTH     is the width of the page in characters.
C
C     ROOMH      is the number of lines allowed for use in the
C                header section of the page.
C
C     ROOMT      is the amount of room allowed for the title section
C                of each page.
C
C     ROOMF      is the amount of room allowed for the footer of each
C                page.
C
C$ Exceptions
C
C     None.
C
C$ Files
C
C     This routine sends lines of output to the routine NSPWLN.
C
C$ Particulars
C
C     By combining the function of the entry points in this routine you
C     may create a page having fixed titles, headers, and footers.
C     together with a variable body for each page.  In addition you may
C     insert the current page number in either the title or footer
C     portion of each page.  In addition you may adjust the size of
C     each page and the width of the page.
C
C     In addition since the IO path has not been selected (you supply
C     your own routine for receiving lines for output.  You may be able
C     to use this routine to build up pages that you may then process
C     further adding touches to the output that have not been provided
C     here.
C
C     The capabilities provided are:
C
C     PAGRST   ---  sets the page number to zero, and empties all
C                   sections of the page format. It does not affect the
C                   global page properties such as the frequency of
C                   titles, headers and footers, page width and height.
C
C     PAGSCN   ---  allows you to set the section to which the next
C                   lines should be written.
C
C     PAGSET   ---  allows you to set page geometry and frequency
C                   parameters.
C
C     PAGSMK   ---  allows you to set the marker that indicates "put the
C                   current page number here."
C
C     PAGPUT   ---  allows you put a line of text on the page.  Note
C                   that the "printing" of title, header and footer
C                   text is deferred until the first line of text in
C                   the body is sent to PAGPUT.
C
C     PAGSFT   ---  is a soft page reset,  the page number is not
C                   altered but the current page is ended (causing a
C                   footer to be written if one is to be printed on the
C                   current page) and then empties the sections
C                   indicated so that they can be updated with new
C                   text.
C
C     PAGPMT   ---  allows you to determine if the last call to PAGPUT
C                   caused a prompt to be issued and if so to see what
C                   the user's response to that prompt was.
C
C                   Note that for a prompt to be issued you must take
C                   several steps.
C
C                   1) You must enable prompts through the PAGSET entry
C                      point.
C
C                      CALL PAGSET ( 'PROMPT', 0 )
C
C                   2) You next need to set the prompt that will be used
C                      This is done with two calls.
C
C                      CALL PAGSCN ( 'PROMPT' )
C                      CALL PAGPUT ( 'your prompt value:' )
C
C                   Having made these preparations, the page manager is
C                   now ready to issue your prompt and retain the user's
C                   response when a page is finished.
C
C                   Note that prompts are not issued as a result of
C                   calling a page reset for (either soft or hard)
C
C                   Also note that once a reset is issued, the prompt
C                   status is set back to the default value --- No
C                   Prompts.
C
C     You might use this routine in conjunction with NICEPR, or TABRPT.
C
C     A typical useage might go as shown here.
C
C     First set the basic global attributes of the page and report.
C
C     CALL PAGSET ( 'PAGEHEIGHT',        60 )
C     CALL PAGSET ( 'PAGEWIDTH',         80 )
C     CALL PAGSET ( 'HEADERFREQUENCY',   -1 )
C     CALL PAGSET ( 'TITLEFREQUENCY',     1 )
C     CALL PAGSET ( 'NOSPACEHEADER',      0 )
C     CALL PAGSET ( 'SPACETITLE',         0 )
C     CALL PAGSET ( 'FOOTERFREQUENCY',    1 )
C     CALL PAGSMK ( '#'                     )
C     CALL PAGRST
C
C     Create the title that will appear on every page.
C
C     CALL PAGSCN ( 'TITLE'                 )
C     CALL PAGPUT ( ' '                     )
C     CALL PAGPUT ( 'Results of Test'       )
C     CALL PAGPUT ( ' '                     )
C     CALL PAGPUT ( ' '                     )
C
C     Create the footer that will appear on every page.
C
C     CALL PAGSCN ( 'FOOTER'              )
C     CALL PAGPUT ( ' '                   )
C     CALL PAGPUT ( ' '                   )
C     CALL PAGPUT ( '           Page # '  )
C     CALL PAGPUT ( ' '                   )
C     CALL PAGPUT ( ' '                   )
C
C     CALL PAGSCN ( 'BODY'                )
C
C     DO I = 1, NLINES
C        CALL PAGPUT ( TEXT(I) )
C     END DO
C
C     CALL PAGSFT
C
C$ Examples
C
C     See above.
C
C$ Restrictions
C
C    Since these routines interact by side effect, you should
C    read carefully the required reading documentation.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 14-DEC-2010 (EDW)
C
C         Declared PROMPT as EXTERNAL.
C
C-    Beta Version 1.0.0, 9-JAN-1992 (WLT)
C
C-&

C$ Index_Entries
C
C     Control the format of output pages
C
C-&

C
C     SPICELIB functions
C
      INTEGER               RTRIM

C
C     Local variables
C
C     The arrays TITLE, HEADER and FOOTER are used to store the
C     text that will be written to the TITLE, HEADER and FOOTER
C     sections of a page.
C
      CHARACTER*(MXWDTH)    TITLE  ( ROOMT )
      CHARACTER*(MXWDTH)    HEADER ( ROOMH )
      CHARACTER*(MXWDTH)    FOOTER ( ROOMF )
      CHARACTER*(MXWDTH)    MYLINE
C
C     The variable RESPNS is used to keep track of any response
C     that the user may supply to a prompt that can be triggered
C     at the completion of a page.
C
      CHARACTER*(MXWDTH)    RESPNS
      CHARACTER*(MXWDTH)    QUESTN

C
C     The variable SECTN contains the name of the section to which
C     lines of text should be sent.
C
      INTEGER               WDSIZE
      PARAMETER           ( WDSIZE = 32 )
      CHARACTER*(WDSIZE)    SECTN
C
C     The array FREQ is used to store the
C     frequency with which footers, headers and titles should
C     be displayed PAGESZ and PAGEWD give the size of the page
C     in height and width.
C
C     The array SIZE is  used to maintain the
C     size of the TITLE, HEADER, BODY, and FOOTER sections.
C
C     The array NEED is used to determine how many lines
C     need to be devoted to the TITLE, HEADER and FOOTER section
C     on a page (the value will be a function of FREQ, the page
C     number and the array KEEPSP)
C
C     The array KEEPSP is used to store whether or not sections
C     should be kept but presented as white space when the
C     page number and frequency imply that the section should
C     not be printed on a given page.
C
C     The array INVIS is used to keep track of whether or not
C     a section should be visible on the current page.
C
      CHARACTER*(WDSIZE)    PAGMRK
      LOGICAL               DOMARK

      INTEGER               T
      PARAMETER           ( T = 1 )

      INTEGER               H
      PARAMETER           ( H = 2 )

      INTEGER               F
      PARAMETER           ( F = 3 )

      INTEGER               B
      PARAMETER           ( B = 4 )

      INTEGER               P
      PARAMETER           ( P = 5 )

      INTEGER               NSECN
      PARAMETER           ( NSECN = P )

      INTEGER               PAGESZ
      INTEGER               PAGEWD
      INTEGER               PAGMLN
      INTEGER               QLENTH
      INTEGER               WFACTR

      INTEGER               FREQ  (NSECN)
      INTEGER               NEED  (NSECN)
      INTEGER               SIZE  (NSECN)

      LOGICAL               VISIBL(NSECN)
      LOGICAL               KEEPSP(NSECN)

C
C     The variable ROW points to the position of the last
C     row in the body portion of the page where text was last
C     written.  PAGENO is the page number of the page that is
C     currently being filled.
C
      INTEGER               ROW
      INTEGER               PAGENO
C
C     The logical BODY is used to indicate whether the section
C     has been set to BODY since the last call to PAGRST to reset
C     the dynamic page attributes.
C
      LOGICAL               BODY

C
C     The logical DOPRMT is used to indicate whether or not a prompt
C     should be issued when the production of a page is finished.
C
      LOGICAL               DOPRMT
      LOGICAL               DIDPMT

C
C     Loop counter
C
      INTEGER               I

C
C     Saved variables
C
      SAVE

C
C     Initial values
C
      DATA                PAGESZ /  24 /
      DATA                PAGEWD /  80 /
      DATA                FREQ   /  -1,  -1, -1, -1, -1 /
      DATA                NEED   /   0,   0,  0,  0,  0 /
      DATA                SIZE   /   0,   0,  0,  0,  0 /
      DATA                ROW    /   0              /
      DATA                PAGENO /   0              /
      DATA                BODY   /  .TRUE.          /
      DATA                DOMARK /  .FALSE.         /
      DATA                DOPRMT /  .FALSE.         /
      DATA                DIDPMT /  .FALSE.         /
      DATA                WFACTR /   0              /
      DATA                SECTN  /  'BODY'          /
      DATA                RESPNS /  ' '             /

      RETURN

C$Procedure PAGRST (Page Reset)

      ENTRY PAGRST

C$ Abstract
C
C     Reset the page to page zero and empty all sections of
C     the page.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     REPORTS
C
C$ Keywords
C
C     OUTPUT
C     TEXT
C     FORMATTING
C
C$ Declarations
C
C     None.
C
C$ Brief_I/O
C
C     None.
C
C$ Detailed_Input
C
C     None
C
C$ Detailed_Output
C
C     None.
C
C$ Parameters
C
C     See the subroutine header
C
C$ Exceptions
C
C     None
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This entry point is used to reset the page manager
C     so that it may receive new section information and
C     so that the lines of text when output will start on the
C     first page of the sequence of pages.
C
C     This entry point should be called only prior to the beginning
C     of a sequence of page productions.
C
C     A call to this routine always halts production of the current
C     page.  No cleanup is performed.  In particular any footer
C     that was waiting to be output, will be elliminated and
C     not produced.  For this reason it is better to call the
C     soft reset PAGSFT (which will output any footers) prior to
C     calling this entry point if you have already begun production
C     of a document and want the last page of the document
C     to be finished prior to beginning a new document.
C
C$ Examples
C
C     See above.
C
C$ Restrictions
C
C     See particulars.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    Beta Version 1.0.0, 9-JAN-1992 (WLT)
C
C-&

      ROW      =  0
      PAGENO   =  1
      SIZE(H)  =  0
      SIZE(F)  =  0
      SIZE(T)  =  0
      SIZE(P)  =  0
      DOPRMT   = .FALSE.
      DIDPMT   = .FALSE.
      RESPNS   = ' '
      WFACTR   =  0
      BODY     = .FALSE.

      RETURN

C$Procedure PAGSFT (Page Soft Reset)

      ENTRY PAGSFT

C$ Abstract
C
C     Finish production of the current page, and empty all section
C     of the page.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     REPORTS
C
C$ Keywords
C
C     OUTPUT
C     TEXT
C     FORMATTING
C
C$ Declarations
C
C     None.
C
C$ Brief_I/O
C
C     None.
C
C$ Detailed_Input
C
C     None.
C
C$ Detailed_Output
C
C     None.
C
C$ Parameters
C
C     See the subroutine header
C
C$ Exceptions
C
C     None
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This entry point is used to reset the page manager
C     so that a new style (header, title and footer, etc).
C
C     The page number is not altered.
C
C     This entry point differs from PAGRST in that it cleanly
C     finished the current page.  This routine should typically
C     be called after the last body text line has been sent to
C     the PAGE MANAGER.
C
C     To perform a complet reset, call the entry point PAGRST.
C
C$ Examples
C
C     See above.
C
C$ Restrictions
C
C     See particulars.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    Beta Version 1.0.0, 9-JAN-1992 (WLT)
C
C-&

      IF ( ROW .GT. 0 ) THEN

         MYLINE = ' '

         DO WHILE ( ROW .LT. SIZE(B) )
            CALL NSPWLN ( MYLINE(1:PAGEWD) )
            ROW = ROW + 1
         END DO

C
C        The user may want to have the page number appear
C        in the footer.  So we replace the PAGMRK by the
C        number if this is the case.
C
         DO I = 1, NEED(F)

            IF ( VISIBL(F) ) THEN
               CALL REPMI  ( FOOTER(I), PAGMRK, PAGENO, MYLINE )
               CALL NSPWLN ( MYLINE(1:PAGEWD) )
            ELSE
            CALL NSPWLN ( MYLINE(1:PAGEWD) )
            END IF

         END DO

         PAGENO = PAGENO + 1

      END IF

      ROW      =  0
      SIZE(H)  =  0
      SIZE(F)  =  0
      SIZE(T)  =  0
      SIZE(P)  =  0
      DOPRMT   = .FALSE.
      DIDPMT   = .FALSE.
      RESPNS   = ' '
      WFACTR   =  0
      BODY     = .FALSE.

      RETURN

C$Procedure      PAGSET (Page Set attributes )

      ENTRY PAGSET ( WHICH, VALUE )

C$ Abstract
C
C     Set one of the global page attributes
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     REPORTS
C
C$ Keywords
C
C     OUTPUT
C     TEXT
C     FORMATTING
C
C$ Declarations
C
C     CHARACTER*(*)         WHICH
C     INTEGER               VALUE
C
C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     WHICH      I   indicates which attribute to set
C     VALUE      I   the value of the attribute
C
C$ Detailed_Input
C
C     WHICH      is the name of some attribute to set.  The acceptable
C                values are:  PAGEWIDTH, PAGEHEIGHT, HEADERFREQUENCY,
C                TITLEFREQUENCY,  SPACETITLE, NOSPACETITLE, SPACEHEADER
C                NOSPACEHEADER, SPACEFOOTER, NOSPACEFOOTER.
C
C     VALUE      is the value to assign to one of the page attributes.
C                In the case of any of the frequency attributes the
C                values carry the following implication: If the
C                frequency is less than zero, that section never
C                appears in the page. If the frequency is 0, that
C                section appears on the first page.  However it does
C                not appear on any other pages.  If the frequency is N
C                > 0 then the section appears on the first page and
C                every page of the form  1 + K*N where K is a positive
C                integer.
C
C                The values supplied for the SPACE/NOSPACE WAIT/NOWAIT
C                attributes are ignored.  The text of WHICH is used to
C                determine if blank lines should be used in place of
C                the text of the section it is not supposed to appear
C                in output.
C
C$ Detailed_Output
C
C     None.
C
C$ Parameters
C
C     See the subroutine header
C
C$ Exceptions
C
C     If one of the recognized values for WHICH is not entered the state
C     of the page manager will not change.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     None.
C
C$ Examples
C
C     See above.
C
C$ Restrictions
C
C    It is intended that this routine be called to set up the page
C    manager prior to the productio of pages.  However, user's may
C    call this routine to change page attributes at any time.
C    Nevertheless, due to the method by which pages are produced, the
C    affects of a call to this routine may be delayed. Once the body
C    of a new page has begun, all attributes but PAGEWIDTH are ignored
C    until the page has been completed according to the attributes
C    that were in effect when the body section of the page was begun.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    Beta Version 1.0.0, 9-JAN-1992 (WLT)
C
C-&

      IF ( WHICH .EQ. 'PAGEHEIGHT' ) THEN
         PAGESZ = VALUE
      ELSE IF ( WHICH .EQ. 'PAGEWIDTH' ) THEN
         PAGEWD = VALUE

      ELSE IF ( WHICH .EQ. 'HEADERFREQUENCY' ) THEN
         FREQ(H) = VALUE
      ELSE IF ( WHICH .EQ. 'TITLEFREQUENCY' ) THEN
         FREQ(T) = VALUE
      ELSE IF ( WHICH .EQ. 'FOOTERFREQUENCY' ) THEN
         FREQ(F) = VALUE

      ELSE IF ( WHICH .EQ.   'SPACETITLE'  ) THEN
         KEEPSP(T) = .TRUE.
      ELSE IF ( WHICH .EQ. 'NOSPACETITLE'  ) THEN
         KEEPSP(T) = .FALSE.

      ELSE IF ( WHICH .EQ.   'SPACEHEADER' ) THEN
         KEEPSP(H) = .TRUE.
      ELSE IF ( WHICH .EQ. 'NOSPACEHEADER' ) THEN
         KEEPSP(H) = .FALSE.

      ELSE IF ( WHICH .EQ.   'SPACEFOOTER' ) THEN
         KEEPSP(F) = .TRUE.
      ELSE IF ( WHICH .EQ. 'NOSPACEFOOTER' ) THEN
         KEEPSP(F) = .FALSE.

      ELSE IF ( WHICH .EQ.   'NOPAGEMARK'  ) THEN
         DOMARK    =.FALSE.
      ELSE IF ( WHICH .EQ.   'DOPAGEMARK'  ) THEN
         DOMARK    =.TRUE.

      ELSE IF ( WHICH .EQ. 'PROMPT' ) THEN
         DOPRMT    = .TRUE.
         WFACTR    =  1
         SIZE(P)   =  1
      ELSE IF ( WHICH .EQ. 'NOPROMPT' ) THEN
         DOPRMT    = .FALSE.
         DIDPMT    = .FALSE.
         RESPNS    = ' '
         WFACTR    =  0
         SIZE(P)   =  0
      END IF

      RETURN

C$Procedure      PAGSMK (Page set page number marker )

      ENTRY PAGSMK ( WHICH )

C$ Abstract
C
C     Set the mark that will be replaced by the current page number
C     within the title and footer sections of a page.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     REPORTS
C
C$ Keywords
C
C     OUTPUT
C     TEXT
C     FORMATTING
C
C$ Declarations
C
C     None.
C
C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     WHICH      I   mark to be replaced by current page number
C
C$ Detailed_Input
C
C     WHICH      is a string which when encountered as a substring
C                of a line of text in either the title or footer
C                section will be replaced by the current page number.
C
C
C$ Detailed_Output
C
C     None.
C
C$ Parameters
C
C     See the subroutine header
C
C$ Exceptions
C
C     None
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This entry point is used to set the "mark" that
C     the page manager will recognize as the position to
C     fill in the current page number in either the title
C     or footer section of a page.   It has no effect in the
C     HEADER or BODY section of the document.
C
C     Usually you will want to set the page number mark at the
C     beginning of a document and leave this unchanged throughout
C     the production of the document.
C
C     The effect of a call to PAGSMK will begin on the next call
C     to PAGPUT.
C
C
C$ Examples
C
C     See above.
C
C$ Restrictions
C
C     See particulars.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    Beta Version 1.0.0, 9-JAN-1992 (WLT)
C
C-&

      PAGMRK = WHICH
      PAGMLN = RTRIM(PAGMRK)
      DOMARK = .TRUE.
      RETURN

C$Procedure      PAGSCN (Page Section)

      ENTRY PAGSCN ( WHICH )

C$ Abstract
C
C     Set the section to which lines should be sent.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     REPORTS
C
C$ Keywords
C
C     OUTPUT
C     TEXT
C     FORMATTING
C
C$ Declarations
C
C     CHARACTER*(*)         WHICH
C     CHARACTER*(*)         LINE
C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     WHICH      I   indicates which section to send lines of text to
C
C$ Detailed_Input
C
C     WHICH      the section to which lines will be sent by
C                the entry point PAGPUT.  Valid choices for
C                WHICH are 'TITLE', 'HEADER', 'FOOTER' and 'BODY'.
C                The routine is case sensitive.
C
C$ Detailed_Output
C
C     None.
C
C$ Parameters
C
C     See the subroutine header
C
C$ Exceptions
C
C     If one of the recognized values is not entered, calls
C     to PAGPUT will have no effect.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     None.
C
C$ Examples
C
C     See above.
C
C$ Restrictions
C
C    None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    Beta Version 1.0.0, 9-JAN-1992 (WLT)
C
C-&
      SECTN = WHICH
      BODY  = SECTN .EQ. 'BODY'

      RETURN

C$Procedure PAGPUT (Page put a line of text )

      ENTRY PAGPUT ( LINE )

C$ Abstract
C
C     Put a line of text in the current section of the current
C     page.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     REPORTS
C
C$ Keywords
C
C     OUTPUT
C     TEXT
C     FORMATTING
C
C$ Declarations
C
C     CHARACTER*(*)         LINE
C
C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     LINE       I   a line of text to put on the current page
C
C$ Detailed_Input
C
C     LINE       is a line of text that should be output (eventually)
C                via the routine NSPWLN.
C
C
C$ Detailed_Output
C
C     None.
C
C$ Parameters
C
C     See the subroutine header
C
C$ Exceptions
C
C     None
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This entry point is used prepare a line of text for output.
C     Whether the text is sent immediately to NSPWLN or is defered
C     depends upon which section is currently active.
C
C     If the current section is the TITLE, HEADER or FOOTER section
C     the line of text is simply buffered and output is defered
C     until the appropriate line of the body of the page is
C     output.
C
C     If the  current section if BODY, the line will be output
C     in the appropriate order along with any of the TITLE,
C     HEADER and FOOTER sections that should be output along with
C     it.
C
C     The calling program should ensure that if sections other than
C     the BODY section are to be written, that their text be
C     established prior to calling this entry point when the body
C     section is active.
C
C$ Examples
C
C     See above.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    Beta Version 1.0.0, 9-JAN-1992 (WLT)
C
C-&
C
C     We handle the TITLE, HEADER and FOOTER sections first.
C
      DIDPMT = .FALSE.

      IF ( .NOT. BODY ) THEN

         IF      ( SECTN .EQ. 'TITLE'  )    THEN

            SIZE (T)       = MIN( ROOMT, SIZE(T) + 1 )
            TITLE(SIZE(T)) = LINE

         ELSE IF ( SECTN .EQ. 'HEADER' )    THEN

            SIZE  (H)       = MIN( ROOMH, SIZE(H) + 1 )
            HEADER(SIZE(H)) = LINE

         ELSE IF ( SECTN .EQ. 'FOOTER' )  THEN

            SIZE  (F)       = MIN( ROOMF,SIZE(F) + 1 )
            FOOTER(SIZE(F)) = LINE

         ELSE IF ( SECTN .EQ. 'PROMPT' ) THEN

            SIZE (P) = 1
            QUESTN   = LINE
            QLENTH   = RTRIM(LINE) + 1

         END IF

         RETURN

      END IF
C
C     The only way to get to this point is if we are working on
C     the body section of a page.  If the row number is zero, then
C     we need to see how much room is available on this page for
C     the body.  And, if appropriate output the TITLE and
C     HEADER sections of this page.
C
      IF ( ROW .EQ. 0 ) THEN
C
C        We need to compute how much room is available
C        for the body of this page.
C
         DO I = T, F
C
C           First determine how much room is needed for
C           this section and whether or not it will be
C           visible on this page if we simply fill it with
C           blanks.
C
            IF ( FREQ(I) .LT. 0 ) THEN
               NEED(I)   =  0
               VISIBL(I) = .FALSE.
            ELSE IF ( PAGENO  .EQ. 1 ) THEN
               NEED(I)   =  SIZE(I)
               VISIBL(I) = .TRUE.
            ELSE IF ( FREQ(I) .EQ. 0 ) THEN
               NEED(I)   =  0
               VISIBL(I) = .TRUE.
            ELSE IF ( FREQ(I) .EQ. 1 ) THEN
               NEED(I)   =  SIZE(I)
               VISIBL(I) = .TRUE.
            ELSE IF ( MOD(PAGENO,FREQ(I)) .EQ. 1 ) THEN
               NEED(I)   =  SIZE(I)
               VISIBL(I) = .TRUE.
            ELSE
               NEED(I)   =  0
               VISIBL(I) = .TRUE.
            END IF

            IF ( KEEPSP(I) ) THEN
               NEED(I) = SIZE(I)
            END IF

         END DO

         SIZE(B) = PAGESZ - NEED(T) - NEED(H) - NEED(F) - WFACTR*SIZE(P)
C
C        We haven't yet written a line in the body of the
C        page, we will write out the title and header sections
C        (provided we are on the right page number)
C
C        We allow for the possibility that the user might
C        place the page number in the title section.
C
         MYLINE = ' '

         DO I = 1, NEED(T)

            IF ( VISIBL(T) ) THEN
               IF ( DOMARK ) THEN
                  CALL REPMI  ( TITLE(I), PAGMRK(1:PAGMLN), PAGENO,
     .                          MYLINE                           )
                  CALL NSPWLN ( MYLINE(1:PAGEWD)                 )
               ELSE
                  CALL NSPWLN ( TITLE(I)(1:PAGEWD)               )
               END IF
            ELSE
               CALL NSPWLN (    MYLINE(1:PAGEWD)                 )
            END IF

         END DO
C
C        Next output whatever portion of the header section is
C        appropriate.
C
         MYLINE = ' '

         DO I = 1, NEED(H)
            IF ( VISIBL(H) ) THEN
               CALL NSPWLN ( HEADER(I)(1:PAGEWD) )
            ELSE
               CALL NSPWLN ( MYLINE   (1:PAGEWD) )
            END IF
         END DO

      END IF
C
C     Write the line and update the number of lines we
C     have written so far.
C
      ROW     =   ROW  + 1
      MYLINE  =   LINE
      CALL NSPWLN ( MYLINE(1:PAGEWD) )

C
C     If we reached the end of the body section, write out
C     the footer (provided we are on the right page). And
C     update the page number.
C
      IF ( ROW .EQ. SIZE(B) ) THEN
C
C        The user may want to have the page number appear
C        in the footer.  So we replace the PAGMRK by the
C        number if this is the case.
C
         MYLINE = ' '

         DO I = 1, NEED(F)

            IF ( VISIBL(F) ) THEN
               IF ( DOMARK ) THEN
                  CALL REPMI  ( FOOTER(I), PAGMRK(1:PAGMLN), PAGENO,
     .                          MYLINE                    )
                  CALL NSPWLN ( MYLINE   (1:PAGEWD)       )
               ELSE
                  CALL NSPWLN ( FOOTER(I)(1:PAGEWD)       )
               END IF
            ELSE
               CALL NSPWLN    ( MYLINE   (1:PAGEWD)       )
            END IF

         END DO
C
C        Advance the page number and reset the row to zero.
C        (we won't have written anything in the body of the
C        next page until later.)
C
         PAGENO = PAGENO + 1
         ROW    = 0

         IF ( DOPRMT ) THEN
            CALL PROMPT ( QUESTN(1:QLENTH), RESPNS )
            DIDPMT = .TRUE.
         END IF

      END IF

      RETURN

C$Procedure PAGPMT ( Page prompt returned )

      ENTRY PAGPMT ( VALUE, LINE )

C$ Abstract
C
C    Determine if a prompt issued and a value returned on the last
C    call to PAGPUT.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     PAGE MANAGER
C
C$ Declarations
C
C     INTEGER               VALUE
C     CHARACTER*(*)         LINE
C
C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     VALUE      O   1 if a prompt was entered, 0 otherwise.
C     LINE       O   The value of the prompt supplied
C
C$ Detailed_Input
C
C     None.
C
C$ Detailed_Output
C
C     VALUE      is an integer indicating whether or not a prompt was
C                displayed and a value returned.  If no prompt was
C                issued on the last call to PAGPUT, VALUE will have the
C                value zero.  Otherwise VALUE will have some non-zero
C                value.
C
C     LINE       is the value of the prompt returned if there was one.
C                Otherwise a blank is returned.
C
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This entry point returns information about what happened in the
C     last call to PAGPUT.  If a page was finished and a prompt was
C     displayed and the user responded, this routine will return two
C     a non-zero integer for VALUE and will place the results of the
C     prompt in the string LINE.
C
C     Note that this routine will return the same results until some
C     call to PAGPUT is made again.
C
C$ Examples
C
C     Suppose that you are using the page manager to send output
C     to some device.  But that you want to allow the user to
C     pause in the course of sending the output. The following
C     illustrates how you would do this.
C
C     CALL getnext  ( LINE, MORE )
C
C     DO WHILE ( MORE )
C
C        CALL PAGPUT ( LINE )
C        CALL PAGPMT ( VALUE, RESPNS )
C
C        IF ( VALUE .NE. 0 )
C
C           take some action concerning RESPNS
C
C        END IF
C
C        CALL getnext  ( LINE, MORE )
C
C     END DO
C
C
C
C     Alternatively you might like to just have the page manager
C     wait for the user after a page has been finished.  To do this
C     you could set things up as follows.
C
C     CALL PAGSET ( 'PROMPT', 0 )
C     CALL PAGSCN ( 'PROMPT'    )
C     CALL PAGPUT ( '(Hit Return to Continue) >'
C
C     CALL getnext  ( LINE, MORE )
C
C     DO WHILE ( MORE )
C
C        CALL PAGPUT  ( LINE )
C        CALL getnext ( LINE, MORE )
C
C     END DO
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C       None.
C
C$ Author_and_Institution
C
C       W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 16-AUG-1995 (WLT)
C
C
C-&

C$ Index_Entries
C
C     See if the last line sent resulted in a prompt
C
C-&

      IF ( DIDPMT ) THEN
         VALUE = 1
         LINE  = RESPNS
      ELSE
         VALUE = 0
         LINE  = ' '
      END IF

      RETURN
      END

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework