text:
FILE  5 = CARD, UNIT = READER, RECORD = 10, BUFFER = 2                  00000100
FILE  6 = LPA, UNIT = PRINTER, RECORD = 15, BUFFER = 2                  00000200
CTPWD    SUBROUTINE TPWD FOR BMD05R         VERSION OF SEPT. 26, 1963   00000300
      SUBROUTINE TPWD(NT1,NT2)                                          00000400
      IF(NT1)40,10,12                                                   00000500
 10   NT1=5                                                             00000600
 12   IF(NT1-NT2)14,19,14                                               00000700
 14   IF(NT2-5)15,19,17                                                 00000800
   15 REWIND NT2                                                        00000900
      GO TO 19                                                          00001000
  17                                                                    00001100
   17 CONTINUE                                                          00001110
C  17 CALL REMOVE(NT2)                                                  00001200
   19 IF(NT1-5)18,24,18                                                 00001300
 18   IF(NT1-6)22,40,22                                                 00001400
 22   REWIND NT1                                                        00001500
 24   NT2=NT1                                                           00001600
 28   RETURN                                                            00001700
 40   WRITE            (6,49)                                           00001800
      CALL EXIT                                                         00001900
 49   FORMAT(25H ERROR ON TAPE ASSIGNMENT)                              00002000
      END                                                               00002100
CVFCHCK    SUBROUTINE TO CHECK FOR PROPER NUMBER OF VARIABLE FORMAT CRDS00002200
      SUBROUTINE VFCHCK(NVF)                                            00002300
      IF(NVF)10,10,20                                                   00002400
 10   WRITE            (6,4000)                                         00002500
      NVF=1                                                             00002600
 50   RETURN                                                            00002700
C                                                                       00002800
 20   IF(NVF-5)50,50,10                                                 00002900
C                                                                       00003000
 4000 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF00003100
     XIED, ASSUMED TO BE 1.)                                            00003200
      END                                                               00003300
CMATINV SUBROUTINE FOR BMD05R                             10/3/63       00003400
      SUBROUTINE MATINV(A,N,B,D,T)                                      00003500
      DIMENSION A(11,11),B(10),U(10)                                    00003600
      DIMENSION IND(10),C(10)                                           00003700
      T=1.0                                                             00003800
      DO 50 I=1,N                                                       00003900
      IND(I)=0                                                          00004000
 50   C(I)=A(I,I)                                                       00004100
      D=1.                                                              00004200
      DO 8 L=1,N                                                        00004300
      X=0.                                                              00004400
      DO 4 I=1,N                                                        00004500
      IF(IND(I))4,2,4                                                   00004600
 2    IF(X-A(I,I)/C(I))3,4,4                                            00004700
    3 K=I                                                               00004800
      X=A(I,I)/C(I)                                                     00004900
    4 CONTINUE                                                          00005000
      T=AMIN1(T,X)                                                      00005100
   11 IND(K)=1                                                          00005200
      DO 5 I=K,N                                                        00005300
      U(I)=A(I,K)                                                       00005400
    5 A(I,K)=0.                                                         00005500
      Y=U(K)                                                            00005600
      D=D*Y                                                             00005700
      DO 6 I=1,K                                                        00005800
      U(I)=A(K,I)                                                       00005900
    6 A(K,I)=0.                                                         00006000
      V=B(K)                                                            00006100
      B(K)=0.                                                           00006200
      U(K)=1.                                                           00006300
      DO 8 I=1,N                                                        00006400
      DO 7 J=1,I                                                        00006500
    7 A(I,J)=A(I,J)-U(I)*U(J)/Y                                         00006600
    8 B(I)=B(I)-U(I)*V/Y                                                00006700
      RETURN                                                            00006800
      END                                                               00006900
CTRNGEN       SUBROUTINE TRNGEN FOR BMD05R             MAY 12, 1964     00007000
      SUBROUTINE TRNGEN(N,NT,M,X,LCODE,CONST)                           00007100
      ASNF(X)=ATAN (X/SQRT (1.0-X**2))                                  00007200
      DIMENSION X(500,11),LCODE(8),CONST(8)                             00007300
 4    DO 210 I=1,M                                                      00007400
      FM=CONST(I)                                                       00007500
      JUMP=LCODE(I)                                                     00007600
      DO 8 J=1,N                                                        00007700
      D=X(J,NT)                                                         00007800
      GO TO(10,20,30,40,50,60,70,80,90,110),JUMP                        00007900
   10 IF(D)99,11,12                                                     00008000
   11 X(J,NT)=0.0                                                       00008100
      GO TO 8                                                           00008200
   12 X(J,NT)=SQRT (D)                                                  00008300
      GO TO 8                                                           00008400
   20 IF(D)99,21,22                                                     00008500
   21 X(J,NT)=1.0                                                       00008600
      GO TO 8                                                           00008700
   22 X(J,NT)=SQRT (D)+SQRT (D+1.0)                                     00008800
      GO TO 8                                                           00008900
   30 IF(D)99,99,31                                                     00009000
   31 X(J,NT)=ALOG10(D)                                                 00009100
      GO TO 8                                                           00009200
   40 X(J,NT)=EXP (D)                                                   00009300
      GO TO 8                                                           00009400
   50 IF(D)99,51,52                                                     00009500
   51 X(J,NT)=0.0                                                       00009600
      GO TO 8                                                           00009700
   52 IF(D-1.0)53,54,99                                                 00009800
   54 X(J,NT)=3.14159265/2.0                                            00009900
      GO TO 8                                                           00010000
   53 A=SQRT (D)                                                        00010100
      X(J,NT)=ASNF(A)                                                   00010200
      GO TO 8                                                           00010300
   60 SAMP=N                                                            00010400
      A=D/(SAMP+1.0)                                                    00010500
      B=A+1.0/(SAMP+1.0)                                                00010600
      IF(A)99,61,62                                                     00010700
   61 IF(B)99,63,64                                                     00010800
   63 X(J,NT)=0.0                                                       00010900
      GO TO 8                                                           00011000
   64 X(J,NT)=ASNF(SQRT (B))                                            00011100
      GO TO 8                                                           00011200
   62 IF(B)99,65,66                                                     00011300
   65 X(J,NT)=ASNF(SQRT (A))                                            00011400
      GO TO 8                                                           00011500
   66 X(J,NT)=ASNF(SQRT (A))+ASNF(SQRT (B))                             00011600
      GO TO 8                                                           00011700
   70 IF(D)71,99,71                                                     00011800
   71 X(J,NT)=1.0/D                                                     00011900
      GO TO 8                                                           00012000
   80 X(J,NT)=D+FM                                                      00012100
      GO TO 8                                                           00012200
   90 X(J,NT)=D*FM                                                      00012300
      GO TO 8                                                           00012400
  110 IF(D)111,112,111                                                  00012500
  112 X(J,NT)=0.0                                                       00012600
      GO TO 8                                                           00012700
  111 X(J,NT)=D**FM                                                     00012800
    8 CONTINUE                                                          00012900
  210 CONTINUE                                                          00013000
 1000 RETURN                                                            00013100
 99   WRITE            (6,105)J,JUMP                                    00013200
      GO TO 8                                                           00013300
 105  FORMAT(18H0THE VALUE OF CASEI4,83H OF THE DEPENDENT VARIABLE VIOLA00013400
     1TED THE RESTRICTION FOR TRANSGENERATION OF THE TYPE, I3,1H./52H TH00013500
     2E PROGRAM CONTINUED LEAVING THIS VALUE UNCHANGED.)                00013600
      END                                                               00013700
CREPORT SUBROUTINE FOR BMD05R                           10/3/63         00013800
      SUBROUTINE REPORT (SSAR,SSDR,N1,N,NPP)                            00013900
      DIMENSION  XY(51,101),SS(10)                                      00014000
      COMMON XR,YR,XMAX,YMAX,XY,NCC,JX,XIJ,TC,TP,JY,YIJ,YMIN,IC,        00014100
     1 N2,NN,     SSDRM,TOTAL,SS                                        00014200
      IF(N1-100) 10, 30, 30                                             00014300
 10   NN=N-1                                                            00014400
      N2=NN-N1                                                          00014500
      D1=N1                                                             00014600
      D2=N2                                                             00014700
      SSARM=SSAR/D1                                                     00014800
      SSDRM=SSDR/D2                                                     00014900
      F=SSARM/SSDRM                                                     00015000
      TOTAL=SSAR+SSDR                                                   00015100
      IF(N1-1) 15, 15, 20                                               00015200
 15   WRITE            (6, 900)                                         00015300
      GO TO 21                                                          00015400
 20   WRITE            (6, 901) N1                                      00015500
 21   WRITE            (6, 902)                                         00015600
      WRITE            (6, 903)                                         00015700
      WRITE            (6, 904) N1,SSAR,SSARM,F                         00015800
      WRITE            (6, 905) N2,SSDR,SSDRM                           00015900
      WRITE            (6, 906) NN, TOTAL                               00016000
      NPP=NPP+1                                                         00016100
      SS(NPP)=SSAR                                                      00016200
      GO TO 70                                                          00016300
 30   N1=1                                                              00016400
      WRITE            (6, 907) NPP                                     00016500
      WRITE            (6, 921)                                         00016600
      WRITE            (6, 922)                                         00016700
      DO 60 I=1,NPP                                                     00016800
      GO TO (31,32,33,34,35,36,37,38,39,40), I                          00016900
 31   WRITE            (6, 911) N1,SS(1),SS(1)                          00017000
      GO TO 60                                                          00017100
 32   SSAR=SS(2)-SS(1)                                                  00017200
      IF(SSAR) 41, 42, 42                                               00017300
 41   SSAR=0.0                                                          00017400
 42   WRITE            (6, 912) N1,SSAR,SSAR                            00017500
      GO TO 60                                                          00017600
 33   SSAR=SS(3)-SS(2)                                                  00017700
      IF(SSAR) 43, 44, 44                                               00017800
 43   SSAR=0.0                                                          00017900
 44   WRITE            (6, 913) N1,SSAR,SSAR                            00018000
      GO TO 60                                                          00018100
 34   SSAR=SS(4)-SS(3)                                                  00018200
      IF(SSAR) 45, 46, 46                                               00018300
 45   SSAR=0.0                                                          00018400
 46   WRITE            (6, 914) N1,SSAR,SSAR                            00018500
      GO TO 60                                                          00018600
 35   SSAR=SS(5)-SS(4)                                                  00018700
      IF(SSAR) 47, 48, 48                                               00018800
 47   SSAR=0.0                                                          00018900
 48   WRITE            (6, 915) N1,SSAR,SSAR                            00019000
      GO TO 60                                                          00019100
 36   SSAR=SS(6)-SS(5)                                                  00019200
      IF(SSAR) 49, 50, 50                                               00019300
 49   SSAR=0.0                                                          00019400
 50   WRITE            (6, 916) N1,SSAR,SSAR                            00019500
      GO TO 60                                                          00019600
 37   SSAR=SS(7)-SS(6)                                                  00019700
      IF(SSAR) 52, 53, 53                                               00019800
 52   SSAR=0.0                                                          00019900
 53   WRITE            (6, 917) N1,SSAR,SSAR                            00020000
      GO TO 60                                                          00020100
 38   SSAR=SS(8)-SS(7)                                                  00020200
      IF(SSAR) 54, 55, 55                                               00020300
 54   SSAR=0.0                                                          00020400
 55   WRITE            (6, 918) N1,SSAR,SSAR                            00020500
      GO TO 60                                                          00020600
 39   SSAR=SS(9)-SS(8)                                                  00020700
      IF(SSAR) 56, 57, 57                                               00020800
 56   SSAR=0.0                                                          00020900
 57   WRITE            (6, 919) N1,SSAR,SSAR                            00021000
      GO TO 60                                                          00021100
 40   SSAR=SS(10)-SS(9)                                                 00021200
      IF(SSAR) 58, 59, 59                                               00021300
 58   SSAR=0.0                                                          00021400
 59   WRITE            (6, 920) N1,SSAR,SSAR                            00021500
 60   CONTINUE                                                          00021600
      WRITE            (6, 905) N2,SSDR,SSDRM                           00021700
      WRITE            (6, 906) NN,TOTAL                                00021800
 900  FORMAT(65H0               ANALYSIS OF VARIANCE FOR SIMPLE LINEAR R00021900
     1EGRESSION)                                                        00022000
 901  FORMAT(41H0                ANALYSIS OF VARIANCE FOR I4, 19H  DEGRE00022100
     1E POLYNOMIAL)                                                     00022200
 902  FORMAT(85H0   SOURCE OF VARIATION              DEGREE OF         S00022300
     1UM OF         MEAN          F)                                    00022400
 903  FORMAT(87H                                      FREEDOM          S00022500
     1QUARES       SQUARE       VALUE)                                  00022600
 904  FORMAT(37H0DUE TO REGRESSION.............      I6,F19.5,2F14.5)   00022700
 905  FORMAT(37H DEVIATION ABOUT REGRESSION....      I6,F19.5,F14.5)    00022800
 906  FORMAT(37H                      TOTAL....      I6,F19.5///)       00022900
 907  FORMAT(45H0              FINAL ANALYSIS OF VARIANCE FOR I4, 19H  D00023000
     1EGREE POLYNOMIAL)                                                 00023100
 911  FORMAT(37H0LINEAR TERM...................      I6,F19.5,F14.5)    00023200
 912  FORMAT(37H QUADRATIC TERM................      I6,F19.5,F14.5)    00023300
 913  FORMAT(37H CUBIC TERM....................      I6,F19.5,F14.5)    00023400
 914  FORMAT(37H QUARTIC TERM..................      I6,F19.5,F14.5)    00023500
 915  FORMAT(37H QUINTIC TERM..................      I6,F19.5,F14.5)    00023600
 916  FORMAT(37H SEXTIC TERM...................      I6,F19.5,F14.5)    00023700
 917  FORMAT(37H 7TH DEGREE TERM...............      I6,F19.5,F14.5)    00023800
 918  FORMAT(37H 8TH DEGREE TERM...............      I6,F19.5,F14.5)    00023900
 919  FORMAT(37H 9TH DEGREE TERM...............      I6,F19.5,F14.5)    00024000
 920  FORMAT(37H 10TH DEGREE TERM..............      I6,F19.5,F14.5)    00024100
 921  FORMAT(74H0   SOURCE OF VARIATION              DEGREE OF         S00024200
     1UM OF         MEAN)                                               00024300
 922  FORMAT(75H                                      FREEDOM          S00024400
     1QUARES       SQUARE)                                              00024500
 70   RETURN                                                            00024600
      END                                                               00024700
CSCALE        SUBROUTINE SCALE FOR SUB PLOTR          JULY 20, 1964     00024800
      SUBROUTINE SCALE(YMIN,YMAX,YINT,JY,TYMIN,TYMAX,YIJ,YRMA)          00024900
      DIMENSION C(10)                                                   00025000
       C(1)=  1.0                                                       00025100
       C(2)=1.5                                                         00025200
       C(3)=2.0                                                         00025300
       C(4)=3.0                                                         00025400
       C(5)=4.0                                                         00025500
      C(6)=5.0                                                          00025600
       C(7)=7.5                                                         00025700
       C(8)=10.0                                                        00025800
C     TEST=154400000000                                                 00025900
   50 YR=YMAX-YMIN                                                      00026000
      TT=YR/YINT                                                        00026100
      J=ALOG10(TT)                                                      00026200
      E=10.0**J                                                         00026300
      TT=TT/E                                                           00026400
      I=0                                                               00026500
      IF(TT-1.0)205,201,201                                             00026600
  205 TT=TT*10.0                                                        00026700
      E=E/10.0                                                          00026800
 201  I=I+1                                                             00026900
      IF(8-I)1,2,2                                                      00027000
    1 E=E*10.0                                                          00027100
      I=1                                                               00027200
    2 T3=TT-C(I)                                                        00027300
      IF (T3.GT. .000001 .OR. T3.LT.-.000001)  GO TO 252                00027400
      TT=INT(TT*1000000)/1000000                                        00027500
  252 IF(TT-C(I))233,202,201                                            00027600
  233 YIJ=C(I)*E                                                        00027700
      GO TO 203                                                         00027800
  202 Y=YMIN/C(I)                                                       00027900
      J=Y                                                               00028000
      T=J                                                               00028100
C     IF(0.0001-ABS (T-Y))204,233,233                                   00028200
      GO TO 233                                                         00028300
  204 YIJ=C(I+1)*E                                                      00028400
  203 X=((YMAX+YMIN)/YIJ-YINT )/2.0+.00001                              00028500
      K=X                                                               00028600
      IF(K)235,240,240                                                  00028700
  235 Y=K                                                               00028800
      IF(X-Y)236,240,236                                                00028900
  236 K=K-1                                                             00029000
  240 TYMIN=K                                                           00029100
      TYMIN=YIJ*TYMIN                                                   00029200
      TYMAX=TYMIN+YINT*YIJ                                              00029300
      TEST=YINT*(YIJ/10.0)                                              00029400
      IF(YRMA-TYMAX-TEST)10,10,201                                      00029500
   10 TT=YINT/10.                                                       00029600
      JY=TT+.000001                                                     00029700
      YIJ=TEST                                                          00029800
      J=TYMIN/ YIJ                                                      00029900
      IF (K)242,241,241                                                 00030000
  242 J=J-1                                                             00030100
  241 J=J*JY+JY-K                                                       00030200
      JY=J                                                              00030300
      RETURN                                                            00030400
      END                                                               00030500
CPLOTR        SUBROUTINE PLOTR                        JULY 20, 1964     00030600
      SUBROUTINE PLOTR(X,ZMIN,ZMAX,Y,SYM,WMIN,WMAX,NC,NP,YRMA,XRMA)     00030700
C                                                                       00030800
C     PLOTR WAS MODIFIED THIS DATE TO GIVE NICER SCALES.                00030900
C                                                                       00031000
      DIMENSION XY(51,101),Y(15),CLAB(12),XM(6),SYM(15),GF(10),F2T(10)  00031100
      COMMON XR,YR,XMAX,YMAX,XY,NCC,JX,XIJ,TC,TP,JY,YIJ,YMIN,IC         00031200
C                                                                       00031300
 100   FORMAT(1H 6X5(F12.3,8X),F12.3/17X,5(F12.3,8X))                   00031400
 101  FORMAT(1H F12.3,1X,A1,101A1 ,A1)                                  00031500
  102 FORMAT(1H 13X,A1,101A1,A1)                                        00031600
 1000 FORMAT(1H  14X,101A1)                                             00031700
 1001 FORMAT(15X,20(5H+....),1H+)                                       00031800
      BLANKS=(+6H      )                                                00031900
      BLANK=(+1H )                                                      00032000
C      XM(1)=770000000000                                               00032100
C        XM(2)=007700000000                                             00032200
C       XM(3)=000077000000                                              00032300
C        XM(4)=000000770000                                             00032400
C       XM(5)=000000007700                                              00032500
C       XM(6)=000000000077                                              00032600
      GF(1)=(+6H1X    )                                                 00032700
      GF(2)=(+6H2X    )                                                 00032800
      GF(3)=(+6H3X    )                                                 00032900
      GF(4)=(+6H4X    )                                                 00033000
      GF(5)=(+6H5X    )                                                 00033100
      GF(6)=(+6H6X    )                                                 00033200
      GF(7)=(+6H7X    )                                                 00033300
      GF(8)=(+6H8X    )                                                 00033400
      GF(9)=(+6H9X    )                                                 00033500
      GF(10)=(+6H10X   )                                                00033600
      F2T(1)=(+6H(17X  )                                                00033700
      F2T(2)=BLANKS                                                     00033800
      F2T(3)=BLANKS                                                     00033900
      F2T(4)=(+6H4(F12.)                                                00034000
      F2T(5)=(+6H3,8X),)                                                00034100
      F2T(6)=(+6HF12.3 )                                                00034200
      F2T(7)=(+6H/7X   )                                                00034300
      F2T(8)=BLANKS                                                     00034400
      F2T(9)=(+6H5(F12.)                                                00034500
      F2T(10)=(+6H3,8X)))                                               00034600
      IF(JY.EQ.0) GO TO 3002                                            00034700
      IF (JY.LT.11 .AND. JY .GT. 0) GO TO 3000                          00034800
      JY=1                                                              00034900
 3000 F2T(3)=GF(JY)                                                     00035000
      F2T(8)=GF(JY)                                                     00035100
 3002 IF(NCC)48,50,48                                                   00035200
   50 KL=0                                                              00035300
      TC=(+1H.)                                                         00035400
      TP=(+1H+)                                                         00035500
      CALL SCALE(WMIN,WMAX,100.0,JY,YMIN,YMAX,YIJ,YRMA)                 00035600
      YR=YMAX-YMIN                                                      00035700
  230 J=JY                                                              00035800
      IF(J*(J-10))204,201,201                                           00035900
  201 IF(KL)220,220,231                                                 00036000
  231 WRITE            (6,1001)                                         00036100
      IF(KL)250,250,220                                                 00036200
  220 CLAB(1)= YMIN                                                     00036300
      DO 222 I=2,11                                                     00036400
  222 CLAB(I)=CLAB(I-1)+YIJ                                             00036500
      WRITE            (6,100)(CLAB(I),I=1,11,2),(CLAB(J),J=2,10,2)     00036600
      IF(KL)231,231,14                                                  00036700
  204 IF(J-5)205,221,207                                                00036800
  207 J=J-5                                                             00036900
  205 JYT=5-J                                                           00037000
  221 CONTINUE                                                          00037100
      IF(KL)226,226,227                                                 00037200
  226 F2T(3)=GF(JY)                                                     00037300
  225 F2T(8)=GF(JY)                                                     00037400
      TT=JY                                                             00037500
      TT=TT*YIJ/10.                                                     00037600
      CLAB(1)= YMIN+TT                                                  00037700
      DO 223 I=2,10                                                     00037800
  223 CLAB(I)=CLAB(I-1) +YIJ                                            00037900
      WRITE            (6,F2T)(CLAB(I),I=2,10,2),(CLAB(J),J=1,9 ,2)     00038000
      IF(KL)227,227,14                                                  00038100
  227 IF(JY-5)208,209,208                                               00038200
  209 WRITE            (6,1001)                                         00038300
      IF(KL)250,250,226                                                 00038400
  208 WRITE            (6,1000)(TC,I=1,J ),((TP,(TC,I=1,4)),K=1,19),TP,(00038500
     1 TC,I=1,JYT)                                                      00038600
      IF(KL)250,250,226                                                 00038700
  250 CONTINUE                                                          00038800
      NCC=1                                                             00038900
      IC=0                                                              00039000
      IF(NP)80,11,11                                                    00039100
       DO 1 J=1,101                                                     00039200
   11 DO 1 I=1,51                                                       00039300
    1 XY(I,J)=BLANKS                                                    00039400
      CALL SCALE (ZMIN,ZMAX,50.,JX,XMIN,XMAX,XIJ,XRMA)                  00039500
      XR=XMAX-XMIN                                                      00039600
   48 IF(NC)52,13,49                                                    00039700
   49 IF(NP)80,10,10                                                    00039800
   10 DO 9 N=1,NC                                                       00039900
      SYMB=SYM(N)                                                       00040000
      XDIFFR=XMAX-X                                                     00040100
      IF(XDIFFR)105,106,106                                             00040200
  105 XDIFFR=0.0                                                        00040300
  106 YDIFFR=YMAX-Y(N)                                                  00040400
      IF(YDIFFR)107,108,108                                             00040500
  107 YDIFFR=0.0                                                        00040600
  108 L=51.-(50.*XDIFFR)/XR+.5                                          00040700
      K=101.-(100.*YDIFFR)/YR+.5                                        00040800
C      CALL FORM2(T,M,SYMB)                                             00040900
      XY(L,K)=SYM(N)                                                    00041000
 9     CONTINUE                                                         00041100
      GO TO 15                                                          00041200
   80 DO 86 I=1,101                                                     00041300
   86 XY(1,I)=BLANKS                                                    00041400
       L=1                                                              00041500
      DO 95 N=1,NC                                                      00041600
      SYMB=SYM(N)                                                       00041700
      YDIFFR=YMAX-Y(N)                                                  00041800
      IF(YDIFFR)860,865,865                                             00041900
  860 YDIFFR=0.0                                                        00042000
  865 K=101.-(100.*YDIFFR)/YR+.5                                        00042100
C      CALL FORM2(T,M,SYMB)                                             00042200
      IF (XY(L,K).EQ.BLANK) GO TO 3005                                  00042300
      XY(L,K)=(+1HB)                                                    00042400
      GO TO 95                                                          00042500
 3005 XY(L,K)=SYM(N)                                                    00042600
   95 CONTINUE                                                          00042700
      IF(MOD  (IC,5))97,96,97                                           00042800
   96 W=TP                                                              00042900
      GO TO 98                                                          00043000
   97 W=TC                                                              00043100
   98 WRITE            (6,101)X,W,(XY(1,N),N=1,101),W                   00043200
      IC=IC+1                                                           00043300
      GO TO 15                                                          00043400
   13 M=6-JX                                                            00043500
      LL=50+M                                                           00043600
      T=JX                                                              00043700
      IF(5-JX)131,131,135                                               00043800
  131 T=0.0                                                             00043900
  135 RLAB=XMAX-(T*XIJ)/5.0                                             00044000
      W=TC                                                              00044100
      K=52                                                              00044200
      DO 31 L=M,LL                                                      00044300
      K=K-1                                                             00044400
      I=MOD  (L,5)                                                      00044500
      IF(I-1)2,3,2                                                      00044600
    3 W=TP                                                              00044700
      WRITE            (6,101)RLAB,W,(XY(K,N),N=1,101),W                00044800
      RLAB=RLAB-XIJ                                                     00044900
      W=TC                                                              00045000
      GO TO 31                                                          00045100
    2 WRITE            (6,102)W,(XY(K,N),N=1,101),W                     00045200
   31 CONTINUE                                                          00045300
   52 KL=1                                                              00045400
      GO TO 230                                                         00045500
   14 NCC=0                                                             00045600
   15 RETURN                                                            00045700
      END                                                               00045800
CGRAPH        SUBROUTINE GRAPH FOR BMD05R           AUGUST 16, 1965     00045900
      SUBROUTINE GRAPH(XX,YY,A,B,N,NPP)                                 00046000
      DIMENSION XX(500),YY(500),B(10),PP(500),FMT(104)                  00046100
      DIMENSION SYM(15),YYY(15)                                         00046200
      DIMENSION  XY(51,101)                                             00046300
      COMMON XR,YR,XMAX,YMAX,XY,NCC,JX,XIJ,TC,TP,JY,YIJ,YMIN,IC         00046400
      DO 10 I=1,N                                                       00046500
      SUM=0.0                                                           00046600
      AA=1.0                                                            00046700
      DO 5 J=1,NPP                                                      00046800
      AA=AA*XX(I)                                                       00046900
    5 SUM=SUM+B(J)*AA                                                   00047000
      PP(I)=SUM+A                                                       00047100
   10 CONTINUE                                                          00047200
      WRITE            (6,100)                                          00047300
      WRITE            (6,101 )                                         00047400
      DO 15 I=1,N                                                       00047500
      DIFF=YY(I)-PP(I)                                                  00047600
   15 WRITE            (6,102)I,XX(I),YY(I),PP(I),DIFF                  00047700
      SS=10.0**10                                                       00047800
      FF=-10.0**9                                                       00047900
      XS=SS                                                             00048000
      XL=FF                                                             00048100
      DO 300 I=1,N                                                      00048200
      XS=AMIN1(XS,XX(I))                                                00048300
      XL=AMAX1(XL,XX(I))                                                00048400
      SS=AMIN1(SS,YY(I),PP(I))                                          00048500
  300 FF=AMAX1(FF,YY(I),PP(I))                                          00048600
      WRITE            (6,4000)                                         00048700
C     MXY AND LYNN ARE DUMMY VARIABLES FOR SUBR SCALE.                  00048800
      CALL SCALE(SS,FF,100.,MXY,S1,F1,LYNN,FF)                          00048900
 4000 FORMAT(1H0//)                                                     00049000
      MXY=N                                                             00049100
      LYNN=0                                                            00049200
  303 IF(MXY-50) 301,302,302                                            00049300
  301 LYNN=1                                                            00049400
  302 SYM(1)=(+1HO)                                                     00049500
      SYM(2)=(+1HP)                                                     00049600
      DO 50 I=1,N                                                       00049700
      X=XX(I)                                                           00049800
      YYY(1)=YY(I)                                                      00049900
      YYY(2)=PP(I)                                                      00050000
      CALL PLOTR(X ,XS,XL,YYY,SYM,SS,FF,2,-1,FF,XL)                     00050100
      IF(LYNN) 50,50,304                                                00050200
  304 WRITE            (6,307)                                          00050300
  307 FORMAT(1H )                                                       00050400
   50 CONTINUE                                                          00050500
      CALL PLOTR(X ,XS,XL,YYY,SYM,SS,FF,-1,-1,FF,XL)                    00050600
      WRITE            (6,4001)                                         00050700
 4001 FORMAT(12H0GRAPH CODES//13H O=OBSERVED Y/14H P=PREDICTED Y/21H B=O00050800
     XBSERVED=PREDICTED//)                                              00050900
      WRITE            (6,218)S1,F1                                     00051000
  100 FORMAT(1H15X,18HTABLE OF RESIDUALS)                               00051100
  101 FORMAT(/6H0 NO. 4X,7HX VALUE4X,7HY VALUE4X,11HY PREDICTED4X,8HRESI00051200
     1DUAL//)                                                           00051300
  102 FORMAT(I5,F13.4,F11.4,2F13.4)                                     00051400
  218 FORMAT(26H GRAPH SCALE EXTENDS FROM F10.4,4H TO F10.4)            00051500
      RETURN                                                            00051600
      END                                                               00051700
CID   0901HS 15 150    $BMD05R POLYNOMIAL REGRESSION                    00051800
CBMD05R       POLYNOMIAL REGRESSION                 AUGUST 16, 1965     00051900
      DIMENSION X(500,11),SD(11,11),AV(11),B(10),RR(11,11)              00052000
      DIMENSION SE(10),XX(500),YY(500),FMT(120),XXB(10),KODE(8),CONST(8)00052100
      DIMENSION  XY(51,101),SS(10)                                      00052200
      COMMON XR,YR,XMAX,YMAX,XY,NCC,JX,XIJ,TC,TP,JY,YIJ,YMIN,IC,        00052300
     1 N2,NN,     SSDRM,TOTAL,SS                                        00052400
      EQUIVALENCE (IA1,A1),(IA2,A2),(IA3,A3)                            00052500
C                                                                       00052600
  918 FORMAT(45H1BMD05R - POLYNOMIAL REGRESSION - VERSION OF ,          00052700
     1  15HAUGUST 16, 1965/                                             00052800
     X41H HEALTH SCIENCES COMPUTING FACILITY, UCLA//)                   00052900
C                                                                       00053000
      A1=(+6HPROBLM)                                                    00053100
      A2=(+6HFINISH)                                                    00053200
      A3=(+6HSPECTG)                                                    00053300
      NTAPE=5                                                           00053400
 5    READ          ( 5,900)ISUM,PROB,N,NP,IPLOT,NVG,NACC,MTAPE,KVR     00053500
      NPP=0                                                             00053600
      IF(ISUM-IA1)7,4,7                                                 00053700
 7    IF(ISUM-IA2)8,15,8                                                00053800
 8    WRITE            (6,919)                                          00053900
 15   IF(6-NTAPE)16,17,17                                               00054000
 16                                                                     00054100
   16 CONTINUE                                                          00054110
C16   CALL REMOVE(NTAPE)                                                00054200
 17   CALL EXIT                                                         00054300
 4    CALL TPWD(MTAPE,NTAPE)                                            00054400
      IF(NACC)748,748,749                                               00054500
 748  NACC=13                                                           00054600
 749  TOL=10.0**(-NACC)                                                 00054700
 19   WRITE            (6, 918)                                         00054800
      WRITE            (6, 902) PROB                                    00054900
      WRITE            (6, 903) N                                       00055000
      IF(NP*(NP-11))200,8,8                                             00055100
 200  IF((N-NP)*(N-501))205,8,8                                         00055200
 205  IERROR=0                                                          00055300
      NT=NP+1                                                           00055400
      ONO=0.0                                                           00055500
      ON=N                                                              00055600
      ONO=ON                                                            00055700
      DO 721 I=1,500                                                    00055800
      X(I,NT)=0.0                                                       00055900
 721  X(I,1)=0.0                                                        00056000
      DO 20 I=1,NT                                                      00056100
      AV(I)=0.0                                                         00056200
      DO 20 J=1,NT                                                      00056300
 20   SD(I,J)=0.0                                                       00056400
      CALL VFCHCK(KVR)                                                  00056500
      KVR=KVR*12                                                        00056600
      READ           (5,916)(FMT(I),I=1,KVR)                            00056700
      IF(-NVG)22,23,23                                                  00056800
 22   WRITE            (6, 901)                                         00056900
      READ           (5,920)ISUM,M,(KODE(I),CONST(I),I=1,M)             00057000
      IF(ISUM-IA3)210,220,210                                           00057100
 210  WRITE            (6, 921)                                         00057200
      IERROR=-501                                                       00057300
      GO TO 23                                                          00057400
 220  DO 230 I=1,M                                                      00057500
      WRITE            (6, 922)KODE(I),CONST(I)                         00057600
      IF(KODE(I)*(KODE(I)-11))230,225,225                               00057700
 225  WRITE            (6, 923)KODE(I)                                  00057800
 230  CONTINUE                                                          00057900
 23   READ           (5    ,FMT)(X(I,1),X(I,NT),I=1,N)                  00058000
      IF(NTAPE-5)10,11,10                                               00058100
 10   REWIND NTAPE                                                      00058200
 11   IF(NVG)25,25,24                                                   00058300
 24   CALL TRNGEN(N,NT,M,X,KODE,CONST)                                  00058400
      IF(IERROR) 5, 25, 25                                              00058500
 25   SUMY=0.0                                                          00058600
      SUMYY=0.0                                                         00058700
      SUMXY=0.0                                                         00058800
      SUMX=0.0                                                          00058900
      SUMXX=0.0                                                         00059000
      DO 27 I=1,N                                                       00059100
      YY(I)=X(I,NT)                                                     00059200
      XX(I)=X(I,1)                                                      00059300
      SUMX=SUMX+XX(I)                                                   00059400
      SUMY=SUMY+YY(I)                                                   00059500
      SUMXY=SUMXY+XX(I)*YY(I)                                           00059600
      SUMXX=SUMXX+XX(I)*XX(I)                                           00059700
 27   SUMYY=SUMYY+YY(I)*YY(I)                                           00059800
      R=(SUMXY-SUMX*SUMY/ON)/SQRT ((SUMXX-SUMX*SUMX/ON)*(SUMYY-SUMY*SUMY00059900
     1/ON))                                                             00060000
      RRR=R*R                                                           00060100
      IF(NP-1)1010,1010,1212                                            00060200
 1212 DO 30 J=2,NP                                                      00060300
      JJ=J-1                                                            00060400
      DO 30 I=1,N                                                       00060500
 30   X(I,J)=X(I,JJ)*X(I,1)                                             00060600
 1010 DO 36 J=1,NT                                                      00060700
      DO 35 I=1,N                                                       00060800
 35   AV(J)=AV(J)+X(I,J)                                                00060900
 36   AV(J)=AV(J)/ONO                                                   00061000
      DO 40 J=1,NT                                                      00061100
      DO 40 I=1,N                                                       00061200
 40   X(I,J)=X(I,J)-AV(J)                                               00061300
      DO 46 J=1,NT                                                      00061400
      DO 46 K=J,NT                                                      00061500
      DO 45 I=1,N                                                       00061600
 45   SD(J,K)=SD(J,K)+(X(I,J)*X(I,K))                                   00061700
 46   SD(K,J)=SD(J,K)                                                   00061800
      B(1)=SD(1,NT)/SD(1,1)                                             00061900
      A=AV(NT)-B(1)*AV(1)                                               00062000
      SE(1)=SQRT ((SUMYY-A*SUMY-B(1)*SUMXY)/(SD(1,1)*(ON-2.0)))         00062100
      WRITE            (6, 904)                                         00062200
      WRITE            (6, 905)                                         00062300
      WRITE            (6, 906) AV(1)                                   00062400
      WRITE            (6, 907) AV(NT)                                  00062500
      WRITE            (6, 908) A                                       00062600
      WRITE            (6, 909) B(1)                                    00062700
      WRITE            (6, 910) SE(1)                                   00062800
      WRITE            (6,911)R                                         00062900
      SSAR=RRR*SD(NT,NT)                                                00063000
      SSDR=(1.0-RRR)*SD(NT,NT)                                          00063100
      N1=1                                                              00063200
      CALL REPORT (SSAR,SSDR,N1,N,NPP)                                  00063300
      GSSDR=SSDR                                                        00063400
      IF(NP-1)50,50,1414                                                00063500
   50 XXB(1)=B(1)                                                       00063600
      AXX=A                                                             00063700
      NXX=1                                                             00063800
      GO TO 1313                                                        00063900
 1414 DO 73 IJ=2,NP                                                     00064000
      N1=IJ                                                             00064100
      DO 52 J=1,IJ                                                      00064200
       B(J)=SD(J,NT)                                                    00064300
       DO 52 I=1,IJ                                                     00064400
 52    RR(I,J)=SD(I,J)                                                  00064500
      CALL MATINV(RR,IJ,B,D,T)                                          00064600
      IF(T-TOL)66,191,191                                               00064700
 66   WRITE            (6, 917)                                         00064800
      SSDR=GSSDR                                                        00064900
      IF(NPP) 67, 67, 75                                                00065000
 67   NPP=1                                                             00065100
      GO TO 75                                                          00065200
 191  DO 192 I=1,IJ                                                     00065300
      RR(I,I)=-RR(I,I)                                                  00065400
 192  B(I)=-B(I)                                                        00065500
      SSAR=0.0                                                          00065600
      DO 60 I=1,IJ                                                      00065700
 60   SSAR=SSAR+B(I)*SD(I,NT)                                           00065800
      SSDR=SD(NT,NT)-SSAR                                               00065900
      DF=IJ+1                                                           00066000
      VARI=SSDR/(ON-DF)                                                 00066100
      DO 62 J=1,IJ                                                      00066200
      SUMY=VARI*RR(J,J)                                                 00066300
 62   SE(J)=SQRT (SUMY)                                                 00066400
      SU=0.0                                                            00066500
      DO 64 I=1,IJ                                                      00066600
 64   SU=SU+B(I)*AV(I)                                                  00066700
 69   GSSDR=SSDR                                                        00066800
      A=AV(NT)-SU                                                       00066900
      WRITE            (6, 912) N1                                      00067000
      WRITE            (6, 908) A                                       00067100
      WRITE            (6, 913)                                         00067200
      WRITE            (6, 915) (B(I), I=1,N1)                          00067300
      DO 70 I=1,N1                                                      00067400
 70   XXB(I)=B(I)                                                       00067500
      AXX=A                                                             00067600
      NXX=N1                                                            00067700
      WRITE            (6, 914)                                         00067800
      WRITE            (6, 915) (SE(I), I=1,N1)                         00067900
      WRITE            (6, 904)                                         00068000
 73   CALL REPORT (SSAR,SSDR,N1,N,NPP)                                  00068100
 75   N1=105                                                            00068200
      WRITE            (6, 904)                                         00068300
      CALL REPORT (SSAR,SSDR,N1,N,NPP)                                  00068400
 1313 IF(IPLOT-1)5,600,5                                                00068500
 600  CALL GRAPH (XX,YY,AXX,XXB,N,NXX)                                  00068600
      GO TO 5                                                           00068700
 900  FORMAT(A6,A2,I3,4I2,49X,2I2)                                      00068800
 901  FORMAT(21H0TRANSGENERATION CARD//16H CODE   CONSTANT//)           00068900
 902  FORMAT(15H0PROBLEM NO.   A2)                                      00069000
 903  FORMAT(12H SAMPLE SIZEI5)                                         00069100
 904  FORMAT(1H0)                                                       00069200
 905  FORMAT(38H0REGRESSION - ONE INDEPENDENT VARIABLE)                 00069300
 906  FORMAT(23H0XMEAN.....            F12.5)                           00069400
 907  FORMAT(23H YMEAN.....            F12.5)                           00069500
 908  FORMAT(23H0INTERCEPT (A VALUE)...F12.5)                           00069600
 909  FORMAT(23H REG. COEFFICIENT......F12.5)                           00069700
 910  FORMAT(25H STD. ERROR OF REG. COEF.F10.5)                         00069800
 911  FORMAT(23H0CORRELATION COEF......F12.5///)                        00069900
 912  FORMAT(32H0POLYNOMIAL REGRESSION OF DEGREEI3)                     00070000
 913  FORMAT(24H0REGRESSION COEFFICIENTS)                               00070100
 914  FORMAT(25H0STD. ERROR OF REG. COEF.)                              00070200
 915  FORMAT(10F12.5)                                                   00070300
 916  FORMAT(12A6)                                                      00070400
 917  FORMAT(71H0COMPUTATIONAL ACCURACY NOT SUFFICIENT FOR POLYNOMIALS O00070500
     1F HIGHER DEGREE)                                                  00070600
 919  FORMAT(22H0ERROR ON PROBLEM CARD)                                 00070700
 920  FORMAT(A6,I1,8(I2,F6.0))                                          00070800
 921  FORMAT(96H0SPECTG CARD MISPUNCHED OR OUT OF ORDER. PROGRAM WILL PR00070900
     1OCEED TO NEXT JOB, IF ANY, OR TERMINATE.)                         00071000
 922  FORMAT(1H I3,F12.5)                                               00071100
 923  FORMAT(29H0ILLEGAL TRANSGENERATION CODEI3,67H SPECIFIED. PROGRAM W00071200
     1ILL CONTINUE LEAVING OUT THIS TRANSGENERATION.)                   00071300
      END                                                               00071400

ext: for


text:
! Copyright (c) 2018, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

! use only clause in multiple interface blocks

module mm
  integer, parameter :: kk = 4
end module mm

subroutine ss
  interface
    integer(kind=kk) function ff1(aa, bb)
      use mm, only : kk
      implicit none
      integer(kind=kk) :: aa, bb
    end function ff1
  end interface

  interface
    integer(kind=kk) function ff2(aa, bb)
      use mm, only : kk
      implicit none
      integer(kind=kk) :: aa, bb
    end function ff2
  end interface

  if (ff1(1,2) + ff2(3,4) .eq. 10) then
    print*, "PASS"
  else
    print*, "FAIL"
  endif
end subroutine ss

integer(kind=kk) function ff1(aa, bb)
  use mm, only : kk
  implicit none
  integer(kind=kk) :: aa, bb
  ff1 = aa + bb
end function ff1

integer(kind=kk) function ff2(aa, bb)
  use mm, only : kk
  implicit none
  integer(kind=kk) :: aa, bb
  ff2 = aa + bb
end function ff2

  call ss
end

max_stars_repo_name: kammerdienerb/flang

max_issues_repo_name: kammerdienerb/flang

max_forks_repo_name: kammerdienerb/flang


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Make damping matrices for non-linear elastic materials.
!! @author Ilario Mazzieri
!> @date November, 2014
!> @version 1.2
!> @param[in] nn nuber of 1D GLL nodes
!> @param[in] ct 1D GLL nodes
!> @param[in] ww 1D GLL weights
!> @param[in] dd spectral derivative matrix
!> @param[in] rho material density
!> @param[in] gamma0 damping coefficient
!> @param[in] alfa11 costant values for the bilinear map
!> @param[in] alfa12 costant values for the bilinear map
!> @param[in] alfa13 costant values for the bilinear map
!> @param[in] alfa21 costant values for the bilinear map
!> @param[in] alfa22 costant values for the bilinear map
!> @param[in] alfa23 costant values for the bilinear map
!> @param[in] alfa31 costant values for the bilinear map
!> @param[in] alfa32 costant values for the bilinear map
!> @param[in] alfa33 costant values for the bilinear map
!> @param[in] beta11 costant values for the bilinear map
!> @param[in] beta12 costant values for the bilinear map
!> @param[in] beta13 costant values for the bilinear map
!> @param[in] beta21 costant values for the bilinear map
!> @param[in] beta22 costant values for the bilinear map
!> @param[in] beta23 costant values for the bilinear map
!> @param[in] beta31 costant values for the bilinear map
!> @param[in] beta32 costant values for the bilinear map
!> @param[in] beta33 costant values for the bilinear map
!> @param[in] gamma1 costant values for the bilinear map
!> @param[in] gamma2 costant values for the bilinear map
!> @param[in] gamma3 costant values for the bilinear map
!> @param[in] delta1 costant values for the bilinear map
!> @param[in] delta2 costant values for the bilinear map
!> @param[in] delta3 costant values for the bilinear map
!> @param[in] cs_nnz length of cs
!> @param[in] cs connectivity vector
!> @param[in] vcase  depth for non linear block
!> @param[in] R_el  reduction factor associated to strain invariant
!> @param[in] fpeak  peak frequency
!> @param[in] nf number of functions
!> @param[in] func_type function type
!> @param[in] func_indx  indices for the data
!> @param[in] nfdata number of data for each function
!> @param[in] func_data data for the calculation (depending on type)
!> @param[in] t_stress  time
!> @param[in] tag_func  function label
!> @param[in] yon  1 if the node is non-linear elastic, 0 otherwise
!> @param[in] tcase  not-honoring test case
!> @param[in] nnod_loc  number of local nodes
!> @param[in] vs_tria  vs values for each node
!> @param[out] mc_el non-linear damping matrix
!> @param[out] mck_el non-linear damping matrix
!> @param[out] gamma_new gamma value for debug mode

      subroutine MAKE_DAMPING_MATRIX_NLE(nn,ct,ww,dd,rho,gamma0,&
                           alfa11,alfa12,alfa13,alfa21,alfa22,alfa23,&
                           alfa31,alfa32,alfa33,beta11,beta12,beta13,&
                           beta21,beta22,beta23,beta31,beta32,beta33,&
                           gamma1,gamma2,gamma3,delta1,delta2,delta3,&
                           mc_el,mck_el,&
                           cs_nnz,cs,ielem,&
                           vcase,R_el,fpeak, &
                           func_type,func_indx,func_data,nfdata,nf,t_stress,tag_func,yon,gamma_new,&
                           tcase, nnod_loc, vs_tria)

      implicit none

      integer*4 :: nn
      integer*4 :: i,j,k
      integer*4 :: nnt,tagmat
      integer*4 :: cs_nnz
      integer*4 :: vcase,nfdata
      integer*4 :: nf,fn,ielem,tcase,nnod_loc,in,is

      integer*4, dimension(nf) :: func_type
      integer*4, dimension(nf +1) :: func_indx
      integer*4, dimension(0:cs_nnz) :: cs
      integer*4, dimension(nf) :: tag_func

      integer*4, dimension(nn,nn,nn) :: yon

      real*8 :: alfa11,alfa12,alfa13,alfa21,alfa22,alfa23,alfa31,alfa32,alfa33
      real*8 :: beta11,beta12,beta13,beta21,beta22,beta23,beta31,beta32,beta33
      real*8 :: gamma1,gamma2,gamma3,delta1,delta2,delta3
      real*8 :: dxdx,dxdy,dxdz,dydx,dydy,dydz,dzdx,dzdy,dzdz,det_j
      real*8 :: DEPTH
      real*8 :: lambda, mu
      real*8 :: t_stress
      real*8 :: get_func_value
      real*8 :: csi,fpeak,Q,PI,gamma

      real*8, dimension(nfdata) :: func_data
      real*8, dimension(nn) :: ct,ww
      real*8, dimension(nnod_loc) :: vs_tria

      real*8, dimension(nn,nn) :: dd

      real*8, dimension(nn,nn,nn) :: rho,gamma0,gamma_new
      real*8, dimension(nn,nn,nn) :: mc_el,mck_el
      real*8, dimension(nn,nn,nn) :: R_el

      gamma_new = gamma0;

!     ELEMENT NODAL MASS CALCULATION

      do k = 1,nn
         do j = 1,nn
            do i = 1,nn

                if (yon(i,j,k).eq.1) then

                   dxdx = alfa11 +beta12*ct(k) +beta13*ct(j) &
                                        + gamma1*ct(j)*ct(k)
                   dydx = alfa21 +beta22*ct(k) +beta23*ct(j) &
                                        + gamma2*ct(j)*ct(k)
                   dzdx = alfa31 +beta32*ct(k) +beta33*ct(j) &
                                        + gamma3*ct(j)*ct(k)
                   dxdy = alfa12 +beta11*ct(k) +beta13*ct(i) &
                                       + gamma1*ct(k)*ct(i)
                   dydy = alfa22 +beta21*ct(k) +beta23*ct(i) &
                                        + gamma2*ct(k)*ct(i)
                   dzdy = alfa32 +beta31*ct(k) +beta33*ct(i) &
                                        + gamma3*ct(k)*ct(i)
                   dxdz = alfa13 +beta11*ct(j) +beta12*ct(i) &
                                        + gamma1*ct(i)*ct(j)
                   dydz = alfa23 +beta21*ct(j) +beta22*ct(i) &
                                        + gamma2*ct(i)*ct(j)
                   dzdz = alfa33 +beta31*ct(j) +beta32*ct(i) &
                                        + gamma3*ct(i)*ct(j)
                   det_j = dxdz * (dydx*dzdy - dzdx*dydy) &
                                        - dydz * (dxdx*dzdy - dzdx*dxdy) &
                                        + dzdz * (dxdx*dydy - dydx*dxdy)

                  is = nn*nn*(k -1) +nn*(j -1) +i
                  in = cs(cs(ielem -1) +is)
                  !-------------------------------------------------------------------
                  !
                  if(tcase .ne. 16) then
                    do fn = 1,nf
                       if (vcase.eq.tag_func(fn)) then
                          if (func_type(fn) .eq. 61) then
                             csi = get_func_value(nf,func_type,func_indx,func_data, nfdata,&
                                                 fn,R_el(i,j,k))

                              Q = 1.d0/(2.d0*csi)
                              PI = 4.0d0 * datan(1.0d0)
                              gamma = PI * fpeak / Q

                              if (gamma0(i,j,k) .ge. gamma) gamma = gamma0(i,j,k)
                              gamma_new(i,j,k) = gamma

                              mc_el(i,j,k) = 2.d0 * gamma * rho(i,j,k) &
                                                                * det_j * ww(i) * ww(j) * ww(k)
                              mck_el(i,j,k) = (gamma**2) * rho(i,j,k) &
                                                                * det_j * ww(i) * ww(j) * ww(k)

                           endif
                       endif
                     enddo
                   elseif (tcase .eq. 16) then

                     do fn = 1,nf
                         if (vcase .eq. tag_func(fn)) then
                             if (func_type(fn) .eq. 61 .and. vs_tria(in) .lt. 325.d0) then

                               csi = get_func_value(nf,func_type,func_indx,func_data, nfdata,&
                                                 fn,R_el(i,j,k))

                                Q = 1.d0/(2.d0*csi)
                                PI = 4.0d0 * datan(1.0d0)
                                gamma = PI * fpeak / Q

                                if (gamma0(i,j,k) .ge. gamma) gamma = gamma0(i,j,k)
                                gamma_new(i,j,k) = gamma

                                mc_el(i,j,k) = 2.d0 * gamma * rho(i,j,k) &
                                                                  * det_j * ww(i) * ww(j) * ww(k)
                                mck_el(i,j,k) = (gamma**2) * rho(i,j,k) &
                                                                  * det_j * ww(i) * ww(j) * ww(k)

                             elseif (func_type(fn) .eq. 63 .and. vs_tria(in) .lt. 450.d0) then
                               csi = get_func_value(nf,func_type,func_indx,func_data, nfdata,&
                                                 fn,R_el(i,j,k))

                                Q = 1.d0/(2.d0*csi)
                                PI = 4.0d0 * datan(1.0d0)
                                gamma = PI * fpeak / Q

                                if (gamma0(i,j,k) .ge. gamma) gamma = gamma0(i,j,k)
                                gamma_new(i,j,k) = gamma

                                mc_el(i,j,k) = 2.d0 * gamma * rho(i,j,k) &
                                                                * det_j * ww(i) * ww(j) * ww(k)
                                mck_el(i,j,k) = (gamma**2) * rho(i,j,k) &
                                                                * det_j * ww(i) * ww(j) * ww(k)

                              endif
                          endif
                        enddo

                   endif!tcase = 16

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

                endif !if (yon(i,j,k).eq.1) then

            enddo
         enddo
      enddo

      return

      end subroutine MAKE_DAMPING_MATRIX_NLE


text:
Subroutine m1535(lb1, lb2, srt, x1535)
  Save
  s0 = 2.424
  x1535 = 0.
  If (srt<=s0) Return
  sigma = 2.*0.102*(srt-s0)/(0.058+(srt-s0)**2)
  If ((lb1*lb2==18 .And. (lb1==2 .Or. lb2==2)) .Or. (lb1*lb2==6 .And. (lb1==1 .Or. lb2==1)) .Or. (lb1*lb2==8 .And. (lb1==1 .Or. lb2==1))) Then
     x1535 = sigma
     Return
  End If
  If (lb1*lb2==7) Then
     x1535 = 3.*sigma
     Return
  End If
  If ((lb1*lb2==11) .Or. (lb1*lb2==20 .And. (lb1==2 .Or. lb2==2))) Then
     x1535 = sigma
     Return
  End If
  If ((lb1*lb2==10 .And. (lb1==1 .Or. lb2==1)) .Or. (lb1*lb2==22 .And. (lb1==2 .Or. lb2==2))) x1535 = 3.*sigma
  Return
End Subroutine m1535

max_stars_repo_name: xiaohaijin/AMPT

max_issues_repo_name: xiaohaijin/AMPT

max_forks_repo_name: xiaohaijin/AMPT


text:
The ASUCD Wireless Internet Taskforce (AWIT)
The main goals include:
1. Secure an agreement with the administration by February 2010 to expand, wireless internet into the six student priority areas.
2. To have at least one project started by February 2010.
3. To foster a sense of urgency in the administration for WiFi expansion.

Meeting times are on Tuesdays from 45PM in the ASUCD Angelina Malfitano Conference room

Current members include:
President Joe Chatham
Senators:
Previn Witana
Kevin Massoudi
Justin Patrizio
and
Stephanie Macedo  Special Projects Director, ASUCD President
Tamera Melvin  Assistant, ASUCD President

20100218 13:08:59 nbsp Just curious, what were those priority areas, and hows this going?  I havent been on campus in a while, and dont have a student account to use on the wireless network anyway, but Im curious. Users/TomGarberson

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


! { dg-do run { xfail hppa*-*-hpux* } }
! { dg-require-effective-target fortran_largest_fp_has_sqrt }
!
! This test checks whether the largest possible
! floating-point number works.
!
! This is a run-time check. Depending on the architecture,
! this tests REAL(8), REAL(10) or REAL(16) and REAL(16)
! might be a hardware or libquadmath 128bit number.
!
program test_qp
   use iso_fortran_env, only: real_kinds
   implicit none
   integer, parameter :: QP = real_kinds(ubound(real_kinds,dim=1))
   real(qp) :: fp1, fp2, fp3, fp4
   character(len=80) :: str1, str2, str3, str4
   fp1 = 1
   fp2 = sqrt (2.0_qp)
   write (str1,*) fp1
   write (str2,'(g0)') fp1
   write (str3,*) fp2
   write (str4,'(g0)') fp2

!   print '(3a)', '>',trim(str1),'<'
!   print '(3a)', '>',trim(str2),'<'
!   print '(3a)', '>',trim(str3),'<'
!   print '(3a)', '>',trim(str4),'<'

   read (str1, *) fp3
   if (fp1 /= fp3) STOP 1
   read (str2, *) fp3
   if (fp1 /= fp3) STOP 2
   read (str3, *) fp4
   if (abs (fp2 - fp4)/fp2 > epsilon(fp2)) STOP 3
   read (str4, *) fp4
   if (abs (fp2 - fp4)/fp2 > epsilon(fp2)) STOP 4

   select case (qp)
     case (8)
       if (str1 /= "   1.0000000000000000") STOP 5
       if (str2 /= "1.0000000000000000") STOP 6
       if (str3 /= "   1.4142135623730951") STOP 7
       if (str4 /= "1.4142135623730951") STOP 8

     case (10)
       if (str1 /= "   1.00000000000000000000") STOP 9
       if (str2 /= "1.00000000000000000000") STOP 10
       if (str3 /= "   1.41421356237309504876") STOP 11
       if (str4 /= "1.41421356237309504876") STOP 12

     case (16)
       if (digits(1.0_qp) == 113) then
         ! IEEE 754 binary 128 format
         ! e.g. libquadmath/__float128 on i686/x86_64/ia64
         if (str1 /= "   1.00000000000000000000000000000000000") STOP 13
         if (str2 /= "1.00000000000000000000000000000000000") STOP 14
         if (str3 /= "   1.41421356237309504880168872420969798") STOP 15
         if (str4 /= "1.41421356237309504880168872420969798") STOP 16
       else if (digits(1.0_qp) == 106) then
         ! IBM binary 128 format
         if (str1 /= "   1.0000000000000000000000000000000") STOP 17
         if (str2 /= "1.0000000000000000000000000000000") STOP 18
         if (str3(1:37) /= "   1.4142135623730950488016887242097") STOP 19
         if (str4(1:34) /= "1.4142135623730950488016887242097") STOP 20
       end if

       ! Do a libm run-time test
       block
         real(qp), volatile :: fp2a
         fp2a = 2.0_qp
         fp2a = sqrt (fp2a)
         if (abs (fp2a - fp2) > sqrt(2.0_qp)-nearest(sqrt(2.0_qp),-1.0_qp)) STOP 21
       end block

     case default
       STOP 22
   end select

end program test_qp


text:
C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 04.02.01.02/07                        *
C  *    TEST TITLE : Linewidth facilities                  *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

      INTEGER    NALW, IX, IDUM1, IDUM2, IDUM3

C parameters for <inquire workstation connection and type>
      INTEGER   SPECWT, SPECON

      REAL       NOMLW, MINLW, MAXLW, LWIDTH, MINSC, MAXSC, INCR, THISC

      LOGICAL    VALOK, RLZLW

      CHARACTER  MSG*300

      CALL INITGL ('04.02.01.02/07')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)
C open workstation
      CALL POPWK  (WKID, CONID, WTYPE)
      CALL PQWKC  (WKID, ERRIND, SPECON, SPECWT)
      CALL CHKINQ ('pqwkc', ERRIND)

C  <inquire polyline facilities> to determine:
C     nalw  = number of available linewidths
C     nomlw = nominal linewidth
C     minlw = minimum linewidth
C     maxlw = maximum linewidth

      CALL PQPLF (SPECWT, 1, ERRIND, IDUM1, IDUM2,
     1            NALW, NOMLW, MINLW, MAXLW, IDUM3)
      CALL CHKINQ ('pqplf', ERRIND)

      WRITE (MSG, '(A,I6,3(A,E13.4))')
     1  'Implementation reports number of available linewidths = ',
     2   NALW, ';  nominal, minimum, maximum linewidths = ',
     3   NOMLW, ',', MINLW, ',', MAXLW
      CALL INMSG (MSG)

      CALL SETMSG ('39', 'Maximum linewidth should not be less ' //
     1             'than minimum.')
      CALL IFPF (MAXLW .GE. MINLW)

      CALL SETMSG ('40', 'The nominal linewidth, minimum '    //
     1             'linewidth, and maximum linewidth should ' //
     2             'all be positive.')
      CALL IFPF (MINLW .GT. 0 .AND. MAXLW .GT. 0 .AND. NOMLW .GT. 0)

      CALL SETMSG ('41', 'The reported number of available ' //
     1             'linewidths should be at least 0.')
      CALL IFPF (NALW .GE. 0)

C  minsc = minimum effective scale factor
C  maxsc = maximum effective scale factor
      MINSC = MINLW/NOMLW
      MAXSC = MAXLW/NOMLW

      CALL SETMSG ('42', 'All linewidth scale factors should be ' //
     1             'accepted as valid.')

      CALL ERRCTL (.TRUE.)

      LWIDTH = MINSC/10
      CALL PSPLR (WKID, 4, 1, LWIDTH, 1)
      IF (ERRSIG .NE. 0) GOTO 500
      LWIDTH = MAXSC*10
      CALL PSPLR (WKID, 4, 1, LWIDTH, 1)
      IF (ERRSIG .NE. 0) GOTO 500
      LWIDTH = -10.0
      CALL PSPLR (WKID, 4, 1, LWIDTH, 1)
      IF (ERRSIG .NE. 0) GOTO 500
      CALL PASS
      VALOK = .TRUE.
      GOTO 600

C  fail and informational message about scale_factor
500   CONTINUE
      CALL FAIL
      VALOK = .FALSE.
      WRITE (MSG, '(A,F11.2,A,I6,A)') 'Linewidth scale factor of ',
     1         LWIDTH, ' rejected with error code = ', ERRSIG, '.'
      CALL INMSG (MSG)

600   CONTINUE

      CALL SETMSG ('11 15 39', 'The reported minimum linewidth ' //
     1             'should be realizable.')
      CALL IFPF (RLZLW (MINSC, MINSC))

      CALL SETMSG ('11 15 39', 'The reported maximum linewidth ' //
     1             'should be realizable.')
      CALL IFPF (RLZLW (MAXSC, MAXSC))

      IF (.NOT. VALOK) THEN
         CALL INMSG ('Skipping tests of linewidth coercion, since ' //
     1               'validity test was failed.')
         GOTO 610
      ENDIF

      CALL SETMSG ('11 15 39', 'A linewidth scale factor set as ' //
     1             'less than the minimum should be realized as ' //
     2             'the reported minimum.')
      CALL IFPF (RLZLW (MINSC/3, MINSC))

      CALL SETMSG ('11 15 39', 'A linewidth scale factor set as ' //
     1             'greater than the maximum should be realized ' //
     2             'as the reported maximum.')
      CALL IFPF (RLZLW (MAXSC*3, MAXSC))

      CALL SETMSG ('11 15 39', 'A linewidth scale factor set as ' //
     1             'less than zero should be realized as the '    //
     2             'reported minimum.')
      CALL IFPF (RLZLW (-ABS(MAXSC), MINSC))

C  skip_coerce:
610   CONTINUE

      IF (NALW .NE. 0) GOTO 666

      CALL SETMSG ('11 15 39', 'If the reported number of available ' //
     1             'linewidths is zero, then all linewidths between ' //
     2             'the reported minimum and maximum should be '      //
     3             'realizable.')

      INCR = (MAXSC/MINSC) ** 0.25
      THISC = MINSC
      DO 620 IX = 1,3
         THISC = THISC * INCR
         IF (RLZLW (THISC, THISC)) THEN
C           OK so far
         ELSE
            CALL FAIL
            GOTO 666
         ENDIF
620   CONTINUE
      CALL PASS

C  done:
666   CONTINUE
      CALL ERRCTL (.FALSE.)
      CALL ENDIT
      END


text:
Shayna and the Bulldog (SatB) are Music Scene local music geeks who like hanging out together and playing music.  Their primary concern at live shows is that you go home with someone attractive that youll be happy to wake up next to in the morning.  And if not, they at least hope you drink enough that theyre attractive that night.  Oh yeah, they also want you to buy their discs at the shows, so youll have something to listen to the next day in case you dont remember the show.  shrug It happens.  They understand.

Biography
Shayna and the Bulldog (“SatB”) make their home in the idyllic town of Davis, California. A picturesque land of farmhouses, spotted owls, and weather vanes, Davis provides a perfect backdrop for the music of SatB, whose chamber pop rock stylings evoke the warm sun and wildflowers of their northern California roots.

A collaboration of five talented friends and musicians, SatB has been playing music together for over six years, growing personally and creatively in the process. The conception of a SatB song is a truly collective endeavor, in which ideas are shared freely and the aspirations of five artists are poured into a single vessel. Their songs are a testament to what can be accomplished when raw musical inspiration is polished by an honesty that can only be shared between loving compatriots.

After releasing a full length album (Shayna and the Bulldog) and EP (The Youth We Knew) in 2011, SatB has been performing for captivated crowds all over the western United States. Their live concerts are a thrilling communion between band and audience, and each listener is taken on a journey both shared and selfreflective. Traveling, performing, and constantly creating new music provides a joyful way of life for SatB as they continue to flourish with every new fan and each new success.

They played their first gig on Picnic Day 2006.

Members:
Joel Daniel  Bass guitar, Vocals
Charles Castle  Guitar, Keyboard, Vocals
Cozy Gazelle  Guitar, Vocals
Iara  Keyboard, Vocals
Kevin Shakur  Drums

Alumni:
Nina Doherty
Laura Gillies

Website: http://shaynaandthebulldog.com/
Music: http://shayna.bandcamp.com/album/shaynaandthebulldoglp
Facebook: https://www.facebook.com/shaynaandthebulldog


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This software is governed by the CeCILL license under French law and
! abiding by the rules of distribution of free software. You can use,
! modify and/or redistribute the software under the terms of the CeCILL
! license as circulated by CEA, CNRS and Inria at the following URL
! "http://www.cecill.info".
!
! As a counterpart to the access to the source code and rights to copy,
! modify and redistribute granted by the license, users are provided only
! with a limited warranty and the software's author, the holder of the
! economic rights, and the successive licensors have only limited
! liability.
!
! In this respect, the user's attention is drawn to the risks associated
! with loading, using, modifying and/or developing or reproducing the
! software by the user in light of its specific status of free software,
! that may mean that it is complicated to manipulate, and that also
! therefore means that it is reserved for developers and experienced
! professionals having in-depth computer knowledge. Users are therefore
! encouraged to load and test the software's suitability as regards their
! requirements in conditions enabling the security of their systems and/or
! data to be ensured and, more generally, to use and operate it in the
! same conditions as regards security.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

! read values from parameter file, ignoring white lines and comments

  subroutine read_value_integer(iin,ignore_junk,value_to_read)

  implicit none

  integer iin
  logical ignore_junk
  integer value_to_read
  character(len=100) string_read

  call read_next_line(iin,ignore_junk,string_read)
  read(string_read,*) value_to_read

  end subroutine read_value_integer

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

  subroutine read_value_double_precision(iin,ignore_junk,value_to_read)

  implicit none

  integer iin
  logical ignore_junk
  double precision value_to_read
  character(len=100) string_read

  call read_next_line(iin,ignore_junk,string_read)
  read(string_read,*) value_to_read

  end subroutine read_value_double_precision

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

  subroutine read_value_logical(iin,ignore_junk,value_to_read)

  implicit none

  integer iin
  logical ignore_junk
  logical value_to_read
  character(len=100) string_read

  call read_next_line(iin,ignore_junk,string_read)
  read(string_read,*) value_to_read

  end subroutine read_value_logical

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

  subroutine read_value_string(iin,ignore_junk,value_to_read)

  implicit none

  integer iin
  logical ignore_junk
  character(len=100) value_to_read
  character(len=100) string_read

  call read_next_line(iin,ignore_junk,string_read)
  read(string_read,*) value_to_read

  end subroutine read_value_string

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

  subroutine read_two_interface_points(iin,ignore_junk,value_to_read_1,value_to_read_2)

  implicit none

  integer iin
  logical ignore_junk
  double precision value_to_read_1,value_to_read_2
  character(len=100) string_read

  call read_next_line(iin,ignore_junk,string_read)
  read(string_read,*) value_to_read_1,value_to_read_2

  end subroutine read_two_interface_points

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

  subroutine read_next_line(iin,ignore_junk,string_read)

  implicit none

  logical ignore_junk
  character(len=100) string_read

  integer ios,iin,index_equal_sign

  do
    read(unit=iin,fmt="(a100)",iostat=ios) string_read
    if(ios /= 0) stop 'error while reading input file'

! suppress leading white spaces, if any
    string_read = adjustl(string_read)

! suppress trailing carriage return (ASCII code 13) if any (e.g. if input text file coming from Windows/DOS)
    if(index(string_read,achar(13)) > 0) string_read = string_read(1:index(string_read,achar(13))-1)

! exit loop when we find the first line that is not a comment or a white line
    if(len_trim(string_read) == 0) cycle
    if(string_read(1:1) /= '#') exit

  enddo

! suppress trailing white spaces, if any
  string_read = string_read(1:len_trim(string_read))

! suppress trailing comments, if any
  if(index(string_read,'#') > 0) string_read = string_read(1:index(string_read,'#')-1)

! suppress leading junk (up to the first equal sign, included) if needed
  if(ignore_junk) then
    index_equal_sign = index(string_read,'=')
    if(index_equal_sign <= 1 .or. index_equal_sign == len_trim(string_read)) stop 'incorrect syntax detected in DATA/Par_file'
    string_read = string_read(index_equal_sign + 1:len_trim(string_read))
  endif

! suppress leading and trailing white spaces again, if any, after having suppressed the leading junk
  string_read = adjustl(string_read)
  string_read = string_read(1:len_trim(string_read))

  end subroutine read_next_line

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

!--------------------
!--------------------
! uses param_reader.c functions
!--------------------
!--------------------

  subroutine read_value_integer_p(value_to_read, name)

  implicit none

  integer value_to_read
  character(len=*) name
  character(len=100) string_read
  integer ierr
  common /param_err_common/ ierr

  call param_read(string_read, len(string_read), name, len(name), ierr)
  if (ierr /= 0) return
  read(string_read,*) value_to_read

  end subroutine read_value_integer_p

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

  subroutine read_value_double_precision_p(value_to_read, name)

  implicit none

  double precision value_to_read
  character(len=*) name
  character(len=100) string_read
  integer ierr
  common /param_err_common/ ierr

  call param_read(string_read, len(string_read), name, len(name), ierr)
  if (ierr /= 0) return
  read(string_read,*) value_to_read

  end subroutine read_value_double_precision_p

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

  subroutine read_value_logical_p(value_to_read, name)

  implicit none

  logical value_to_read
  character(len=*) name
  character(len=100) string_read
  integer ierr
  common /param_err_common/ ierr

  call param_read(string_read, len(string_read), name, len(name), ierr)
  if (ierr /= 0) return
  read(string_read,*) value_to_read

  end subroutine read_value_logical_p

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

  subroutine read_value_string_p(value_to_read, name)

  implicit none

  character(len=*) value_to_read
  character(len=*) name
  character(len=100) string_read
  integer ierr
  common /param_err_common/ ierr

  call param_read(string_read, len(string_read), name, len(name), ierr)
  if (ierr /= 0) return
  value_to_read = string_read

  end subroutine read_value_string_p

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

  subroutine read_value_integer_next_p(value_to_read, name)

  implicit none

  integer value_to_read
  character(len=*) name
  character(len=100) string_read
  integer ierr
  common /param_err_common/ ierr

  call param_read_nextparam(string_read, len(string_read), name, len(name), ierr)
  if (ierr /= 0) return
  read(string_read,*) value_to_read

  end subroutine read_value_integer_next_p

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

  subroutine read_value_double_prec_next_p(value_to_read, name)

  implicit none

  double precision value_to_read
  character(len=*) name
  character(len=100) string_read
  integer ierr
  common /param_err_common/ ierr

  call param_read_nextparam(string_read, len(string_read), name, len(name), ierr)
  if (ierr /= 0) return
  read(string_read,*) value_to_read

  end subroutine read_value_double_prec_next_p

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

  subroutine read_value_logical_next_p(value_to_read, name)

  implicit none

  logical value_to_read
  character(len=*) name
  character(len=100) string_read
  integer ierr
  common /param_err_common/ ierr

  call param_read_nextparam(string_read, len(string_read), name, len(name), ierr)
  if (ierr /= 0) return
  read(string_read,*) value_to_read

  end subroutine read_value_logical_next_p

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

  subroutine read_material_parameters_p(i,icodematread,val0read,val1read,val2read,val3read, &
                         val4read,val5read,val6read,val7read,val8read,val9read,val10read, &
                         val11read,val12read)

  implicit none

  integer i,icodematread
  double precision val0read,val1read,val2read,val3read,val4read,val5read,val6read,val7read,&
                   val8read,val9read,val10read,val11read,val12read

  character(len=100) string_read
  integer ierr
  common /param_err_common/ ierr

  call param_read_nextline(string_read, len(string_read), ierr)
  if (ierr /= 0) stop 'error reading material parameter'
  print *,trim(string_read)
  read(string_read,*,iostat=ierr) i,icodematread,val0read,val1read,val2read,val3read,val4read,val5read,&
                      val6read,val7read,val8read,val9read,val10read,val11read,val12read

  if( ierr /= 0) stop 'error reading material parameters line'

  end subroutine read_material_parameters_p

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

  subroutine read_region_coordinates_p(value_to_read_1,value_to_read_2, &
                          value_to_read_3,value_to_read_4,value_to_read_5)

  implicit none

  integer value_to_read_1,value_to_read_2,value_to_read_3,value_to_read_4,value_to_read_5
  character(len=100) string_read
  integer ierr
  common /param_err_common/ ierr

  call param_read_nextline(string_read, len(string_read), ierr)
  if (ierr /= 0) stop 'error reading region coordinates'
  !print *,string_read

  read(string_read,*,iostat=ierr) value_to_read_1,value_to_read_2,value_to_read_3,value_to_read_4,value_to_read_5

  if( ierr /= 0) stop 'error reading region coordinates line'

  end subroutine read_region_coordinates_p

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

  subroutine open_parameter_file()

  implicit none
  include 'constants.h'
  integer ierr
  common /param_err_common/ ierr
  character(len=50) filename

  ! to use fortran routines
  !open(unit=IIN,file='DATA/Par_file',status='old',iostat=ios)
  !if( ios /= 0 ) stop 'error opening DATA/Par_file file'

  ! to use c routines
  filename = 'DATA/Par_file'

  call param_open(filename, len_trim(filename), ierr)
  if( ierr /= 0 ) stop 'error opening DATA/Par_file file'

  end subroutine open_parameter_file

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

  subroutine close_parameter_file()

  implicit none
  include 'constants.h'

  ! to use fortran routines
  !close(IIN)

  ! to use c routines
  call param_close()

  end subroutine close_parameter_file

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

  integer function err_occurred()

  implicit none

  integer ierr
  common /param_err_common/ ierr

  err_occurred = ierr

  end function err_occurred