text:
      SUBROUTINE XSFA (X)
C
C     ENTRY SIZE NUMBERS,  1=FIAT, 2=SOS, 3=MD, 4=DPD
C
C     REVISED  8/89,  SEE XSFABD
C
      IMPLICIT INTEGER (A-Z)
      EXTERNAL        LSHIFT,RSHIFT,ANDF,ORF,COMPLF
      DIMENSION       IPRT(23),NSFA(3),DDBN(1),DFNU(1),FCUM(1),
     1                FCUS( 1),FDBN(1),FEQU(1),FILE(1),FKND(1),
     2                FMAT( 1),FNTU(1),FPUN(1),FON (1),FORD(1),
     3                MINP( 1),MLSN(1),MOUT(1),MSCR(1),SAL (1),
     4                SDBN( 1),SNTU(1),SORD(1),PFIL(2,3)
      CHARACTER       UFM*23,UWM*25,UIM*29,SFM*25
      COMMON /XMSSG / UFM,UWM,UIM,SFM
      COMMON /BLANK / IBNK(1)
      COMMON /MACHIN/ MCH
      COMMON /XFIAT / FIAT(7)
      COMMON /XFIST / FIST
      COMMON /XDPL  / DPD(6)
      COMMON /ZZZZZZ/ BUF1
      COMMON /SYSTEM/ IBUFSZ,OUTTAP,DUM(17),PLTFLG,DUM1,THISLK,DUM2,
     1                ICFIAT,DMM(14),NBPC,NBPW,NCPW
      COMMON /IXSFA / LMT3,BFF,PAD,IDEFR1,IDEFR2
      COMMON /XSFA1 / MD(401),SOS(1501),COMM(20),XF1AT(5)
      EQUIVALENCE               (DPD  (1),DNAF    ),(DPD  (2),DMXLG   ),
     1      (DPD  (3),DCULG   ),(DPD  (4),DDBN (1)),(DPD  (6),DFNU (1)),
     2      (FIAT (1),FUNLG   ),(FIAT (2),FMXLG   ),(FIAT (3),FCULG   ),
     3      (FIAT (4),FEQU (1)),(FIAT (4),FILE (1)),(FIAT (4),FORD (1)),
     4      (FIAT (5),FDBN (1)),(FIAT (7),FMAT (1)),(MD   (1),MLGN    ),
     5      (MD   (2),MLSN (1)),(MD   (3),MINP (1)),(MD   (4),MOUT (1)),
     6      (MD   (5),MSCR (1)),(SOS  (1),SLGN    ),(SOS  (2),SDBN (1)),
     7      (SOS  (4),SAL  (1)),(SOS  (4),SNTU (1)),(SOS  (4),SORD (1)),
     8      (XF1AT(1),FNTU (1)),(XF1AT(1),FON  (1)),(XF1AT(2),FPUN (1)),
     9      (XF1AT(3),FCUM (1)),(XF1AT(4),FCUS (1)),(XF1AT(5),FKND (1))
      EQUIVALENCE               (COMM (1),ALMSK   ),(COMM (2),APNDMK  ),
     1      (COMM (3),CURSNO  ),(COMM (4),ENTN1   ),(COMM (5),ENTN2   ),
     2      (COMM (6),ENTN3   ),(COMM (7),ENTN4   ),(COMM (8),FLAG    ),
     3      (COMM (9),FNX     ),(COMM(10),LMSK    ),(COMM(11),LXMSK   ),
     4      (COMM(12),MACSFT  ),(COMM(13),RMSK    ),(COMM(14),RXMSK   ),
     5      (COMM(15),S       ),(COMM(16),SCORNT  ),(COMM(17),TAPMSK  ),
     6      (COMM(18),THCRMK  ),(COMM(19),ZAP     )
      DATA  OSCAR1, OSCAR2/ 4HXOSC, 4HAR  /, POOL  / 4HPOOL  /
      DATA  NSFA  / 4HXSFA, 4H    , 4H    /, NS14  / 4HNS14  /
      DATA  IBEGN,  IEND  / 4HBEGN, 4HEND /
      DATA  PLUS  / 1H+   /
      DATA  PFIL  / 4HPLTP, 4HAR  , 4HGPSE, 4HTS  , 4HELSE, 4HTS   /
C
      CALL XSFADD
      NSFA(3) = IBEGN
      CALL CONMSG (NSFA,3,0)
C
C     ALMSK  = O 377777777777     Z 7FFFFFFF
      ALMSK  = RSHIFT(COMPLF(0),1)
C
C     THCRMK = O 777777000000     Z FFFFFF00
      THCRMK = LSHIFT(ALMSK,NBPW-(3*NBPC))
C
C     S      = O 400000000000     Z 80000000
      S      = LSHIFT(1,NBPW-1)
C
C     MACSFT = SHIFT COUNT TO PLACE INTEGER IN 4TH FROM LEFT CHARACTER
      MACSFT = (NCPW-4)*NBPC
C
      ENTN1  = ICFIAT
      CURSNO = X
C
C     GET OSCAR FILE POSITION AND SAVE IN FNOS
C     ALSO SAVE RECORD POSITION IN RNOS
C
      CALL XPOLCK (OSCAR1,OSCAR2,FNOS,NX)
      IF (FNOS .EQ. 0) GO TO 920
      FNX  = FNOS
      RNOS = CURSNO
      CALL XSOSGN
      IF (MLGN .EQ. 0) GO TO 930
      CALL XCLEAN
C
C     INITIALIZE PRIOR TO FIRST MODULE ALLOCATION
C
      ASSIGN 670 TO ITEST
C
      LMT1  = MLGN *ENTN3
      LMT8  = FUNLG*ENTN1
      LMT8P1= LMT8 + 1
      DO 110 I = 1,LMT8,ENTN1
      IF (ANDF(TAPMSK,FILE(I)) .NE. 0) GO TO 120
  110 CONTINUE
      TAPMSK = 0
C
C     LOOP THRU ALL MODULES IN SOS
C
  120 I = 1
  125 TOTIO = MINP(I)+ MOUT(I)
      TOTF  = TOTIO  + MSCR(I)
      ALCNT = 0
      LMT2  = LMT3 + 1
      LMT4  = LMT3 + MINP(I)*ENTN2
      LMT5  = LMT4 + MOUT(I)*ENTN2
      LMT3  = LMT3 + TOTF   *ENTN2
      LMT9  = FCULG*ENTN1
      NFCULG= LMT9 + 1
      ITIORD= LSHIFT(MLSN(I),16)
      DO 130 J = 1,LMT9,ENTN1
  130 FCUM(J) = 0
C
C     SEQUENCE THRU SOS (ONE MODULE) LOOK FOR NAME MATCH + LTU COMPARE
C
  150 FLAG = 0
      DO 260 K = LMT2,LMT3,ENTN2
      IF (SAL(K) .LT. 0)  GO TO 260
      ITPFLG = ANDF(TAPMSK,SNTU(K))
C
C     SEQUENCE THRU FIAT (NAME MATCH)
C
      DO 170 F1 = 1,LMT9,ENTN1
      IF (SDBN(K).NE.FDBN(F1) .OR. SDBN(K+1).NE.FDBN(F1+1)) GO TO 170
      IF (FPUN(F1) .LT. 0) GO TO 680
      FNTU(F1) = ORF(ANDF(S,FON(F1)),SNTU(K))
      FCUM(F1) = -1
      FCUS(F1) = -1
      IF (FKND(F1) .EQ. 0) FKND(F1) = 1
      GO TO 230
  170 CONTINUE
      IF (MLSN(I) .LT. 0) GO TO 260
      IF (K    .LE. LMT4) GO TO 260
      IF (ANDF(APNDMK,SORD(K)) .EQ. APNDMK) GO TO 260
C
C     SEQUENCE THRU FIAT (LTU COMPARE)
C
      DO 220 F1 = 1,LMT9,ENTN1
      IF (ITIORD .LE. ANDF(LMSK,FORD(F1))) GO TO 220
      IF (FON (F1) .LT. 0) GO TO 220
      IF (FCUM(F1) .LT. 0) GO TO 220
      IF (FDBN(F1) .EQ. 0) GO TO 220
      IF (ANDF(RMSK,FILE(F1)) .EQ. RMSK) GO TO 220
      IF (ANDF(LMSK,FORD(F1)) .EQ. LMSK) GO TO 220
      IF (ITPFLG.NE.0 .AND. ANDF(TAPMSK,FILE(F1)).EQ.0) GO TO 220
      IF (FEQU(F1) .GE. 0) GO TO 210
      FIL = ANDF(RMSK,FILE(F1))
      DO 200 L = 1,LMT9,ENTN1
      IF (FEQU(L) .GE. 0) GO TO 200
      IF (F1      .EQ. L) GO TO 200
      IF (FIL    .NE. ANDF(RMSK,FILE(L))) GO TO 200
      IF (ITIORD .LE. ANDF(LMSK,FORD(L))) GO TO 220
      IF (FON(L)  .LT. 0) GO TO 220
      IF (FCUM(L) .LT. 0) GO TO 220
  200 CONTINUE
  210 IF (FCULG+PAD .GE. FMXLG) GO TO 680
      FON(F1) = ORF(S,FON(F1))
      FDBN(NFCULG  ) = SDBN(K  )
      FDBN(NFCULG+1) = SDBN(K+1)
      FORD(NFCULG  ) = ORF(ANDF(LXMSK,SORD(K)),ANDF(RXMSK,FILE(F1)))
      FNTU(NFCULG  ) = SNTU(K)
      FCUM(NFCULG  ) = -1
      FCUS(NFCULG  ) = -1
      FKND(NFCULG  ) = 2
      NFCULG = NFCULG+ ENTN1
      FCULG  = FCULG + 1
      GO TO 230
  220 CONTINUE
      GO TO 260
  230 SAL(K) = ORF(S,SAL(K))
      ALCNT  = ALCNT + 1
  260 CONTINUE
      IF (ALCNT .EQ. TOTF) GO TO 600
C
C     SEQUENCE THRU SOS (ONE MODULE) LOOK FOR BLANK FILES + GREATER NTU
C
      DO 550 K = LMT2,LMT3,ENTN2
      IF (SAL(K) .LT. 0) GO TO 550
      IF (FLAG.NE.0 .AND. K.GT.LMT4 .AND. K.LE.LMT5) GO TO 150
      IAPFLG = 0
      IUNPFG = 0
      IF (ANDF(APNDMK,SORD(K)) .EQ. APNDMK) IAPFLG = -1
      ITPFLG = ANDF(TAPMSK,SNTU(K))
C
C     SEQUENCE THRU FIAT-UNIQUE (BLANK FILES)
C
      IF (BFF .LT. 0) GO TO 390
      DO 330 F1 = 1,LMT8,ENTN1
      IF (FDBN(F1) .NE. 0) GO TO 330
      IF (ITPFLG.NE.0 .AND. ANDF(TAPMSK,FILE(F1)).EQ.0) GO TO 330
      IF (K.GT.LMT4 .AND. IAPFLG.EQ.0) GO TO 310
      CALL XPOLCK (SDBN(K),SDBN(K+1),FN,NX)
      IF (IAPFLG.NE.0 .AND. FN.EQ.0) GO TO 310
      IF (FN     .NE. 0) GO TO 300
      IF (PLTFLG .NE. 0) GO TO 280
      DO 270 IP = 1,3
      IF (SDBN(K).EQ.PFIL(1,IP) .AND. SDBN(K+1).EQ.PFIL(2,IP)) GO TO 300
  270 CONTINUE
  280 IF (THISLK .NE. NS14) CALL MESAGE (22,0,SDBN(K))
      GO TO 320
  300 FPUN(F1) = FN
      IUNPFG   = F1
  310 FDBN(F1  ) = SDBN(K  )
      FDBN(F1+1) = SDBN(K+1)
      FORD(F1) = ORF(ANDF(LXMSK,SORD(K)),FILE(F1))
      FNTU(F1) = SNTU(K)
      FCUM(F1) =-1
      FCUS(F1) =-1
      FKND(F1) = 3
  320 SAL(K) = ORF(S,SAL(K))
      ALCNT  = ALCNT + 1
      GO TO 540
  330 CONTINUE
      IF (ITPFLG .EQ. 0) BFF = -1
C
C     SEQUENCE THRU FIAT (GREATEST NTU) FOR POOLING
C
  390 IF (MLSN(I) .LT. 0) GO TO 680
C
C     BEFORE PERMITTING POOLING CHECK IF AT LEAST ONE MODULE IS ALLOCATE
C
      IF (I .NE. 1) GO TO 620
  400 MXNTU  = CURSNO
      MXNTUI = 0
      DO 460 F1 = 1,LMT8,ENTN1
      IF (FCUS(F1) .LT. 0) GO TO 460
      IF (IDEFR2   .LT. 0) GO TO 420
      IF (FMAT(F1).NE.0 .OR. FMAT(F1+1).NE.0 .OR. FMAT(F1+2).NE.0)
     1   GO TO 410
      IF (ENTN1.EQ.11 .AND. (FMAT(F1+5).NE.0 .OR. FMAT(F1+6).NE.0 .OR.
     1   FMAT(F1+7).NE.0)) GO TO 410
      GO TO 420
  410 IDEFR1 = -1
      GO TO 460
  420 IF (FKND(F1) .LT. 0) GO TO 460
      IF (FPUN(F1) .NE. 0) GO TO 460
      IF (ITPFLG.NE.0 .AND. ANDF(TAPMSK,FILE(F1)).EQ.0) GO TO 460
      TRIAL = ANDF(FNTU(F1),RMSK)
      IF (TRIAL .LE. MXNTU) GO TO 460
      MXNTU  = TRIAL
      MXNTUI = F1
  460 CONTINUE
      IF (MXNTUI .NE. 0) GO TO 463
C
C     FILE NOT FOUND - HAS A PASS BEEN DEFERRED
C
      IF (IDEFR1 .EQ. 0) GO TO 680
C
C     PASS HAS BEEN DEFERRED - TRY IT NOW
C
      IDEFR1 = 0
      IDEFR2 =-1
      DO 462 IX = 1,LMT8,ENTN1
  462 FKND(IX) = IABS(FKND(IX))
      GO TO 400
C
C     A GREATER NTU FILE EXISTS
C
  463 N = 1
C
C     SEARCH FOR EQUIV OR STACKED MATCH
C
      FIL = ANDF(RMSK,FILE(MXNTUI))
      DO 470 J = LMT8P1,LMT9,ENTN1
      IF (FIL .NE. ANDF(RMSK,FILE(J))) GO TO 470
C
C     A MATCH IS FOUND, IS MATCHED FILE USED IN CURRENT SEG
C
      IF (FCUS(J) .LT. 0) GO TO 490
C
C     IF MATCHED FILE HAS NTU LESS - TEST AND SET DEFER FLAG
C
      IF (IDEFR2 .LT. 0) GO TO 465
      IF (FMAT(J).NE.0 .OR.  FMAT(J+1).NE.0 .OR. FMAT(J+2).NE.0)
     1    GO TO 464
      IF (ENTN1.EQ.11 .AND. (FMAT(J+5).NE.0 .OR. FMAT(J+6).NE.0 .OR.
     1    FMAT(J+7).NE.0)) GO TO 464
      IF (ANDF(RMSK,FNTU(1)) .GE. ANDF(RMSK,FNTU(MXNTUI))) GO TO 465
  464 IDEFR1 = -1
      GO TO 490
C
C     MATCHED FILE IS O.K. - IS IT EQUIV OR STACKED
C
  465 IF (FEQU(J) .GE. 0) GO TO 467
      FKND(J) = 7
      N = N + 1
      GO TO 470
C
C     STACKED - WIPE OUT MATCH (IF EMPTY)
C
  467 IF (FMAT(J).NE.0 .OR.  FMAT(J+1).NE.0 .OR. FMAT(J+2).NE.0)
     1    GO TO 490
      IF (ENTN1.EQ.11 .AND. (FMAT(J+5).NE.0 .OR. FMAT(J+6).NE.0 .OR.
     1    FMAT(J+7).NE.0)) GO TO 490
      FILE(J  ) = 0
      FDBN(J  ) = 0
      FDBN(J+1) = 0
  470 CONTINUE
      FPUN(MXNTUI) = ORF(S,N)
      IF (K.GT.LMT4 .AND. IAPFLG.EQ.0) GO TO 520
      CALL XPOLCK (SDBN(K),SDBN(K+1),FN,NX)
      IF (IAPFLG.NE.0 .AND. FN.EQ.0) GO TO 520
      IF (FN .NE. 0) GO TO 500
      IF (THISLK .NE. 14) CALL MESAGE (22,0,SDBN(K))
      GO TO 530
  490 IF (FKND(MXNTUI) .EQ. 0) FKND(MXNTUI) = 9
      FKND(MXNTUI) = -IABS(FKND(MXNTUI))
      GO TO 400
  500 FPUN(NFCULG) = FN
      IUNPFG = NFCULG
  520 IF (FCULG+PAD .GE. FMXLG) GO TO 680
      FON(MXNTUI ) = ORF(S,FON(MXNTUI))
      FORD(NFCULG) = ORF(ANDF(RXMSK,FILE(MXNTUI)),ANDF(LXMSK,SORD(K)))
      FKND(NFCULG) = ORF(FKND(NFCULG),5)
      FDBN(NFCULG  ) = SDBN(K  )
      FDBN(NFCULG+1) = SDBN(K+1)
      FNTU(NFCULG) = SNTU(K)
      FCUM(NFCULG) = -1
      FCUS(NFCULG) = -1
      NFCULG = NFCULG+ ENTN1
      FCULG  = FCULG + 1
  530 SAL(K) = ORF(S,SAL(K))
      ALCNT  = ALCNT+ 1
  540 IF (IUNPFG   .EQ. 0) GO TO 550
      IF (DFNU(NX) .GE. 0) GO TO 550
      CALL XPLEQK (NX,IUNPFG)
      LMT9  = FCULG*ENTN1
      NFCULG= LMT9 + 1
  550 CONTINUE
C
C     MODULE ALLOCATION COMPLETE
C
  600 CURSNO = ANDF(RMSK,MLSN(I)) + 1
C
C     END OF I MODULE PSEUDO LOOP
C
      I = I + ENTN3
      IF (I .LE. LMT1) GO TO 125
C
  620 CALL XPUNP
      CALL XDPH
C
C     REPOSITION OSCAR FOR SEM
C
      CALL XPOLCK (OSCAR1,OSCAR2,FNOS,NX)
      IF (FNOS .EQ. 0) GO TO 920
  630 CALL OPEN (*940,POOL,BUF1,0)
      IF (FNOS .NE. 1) CALL SKPFIL (POOL,FNOS-1)
      DO 650 J = 1,RNOS
      CALL FWDREC (*950,POOL)
  650 CONTINUE
      CALL CLOSE (POOL,2)
C
  655 CONTINUE
C
C     DUMP FIAT IF SENSE SWITCH 2 IS ON
C
      CALL SSWTCH (2,IX)
      IF (IX .NE. 1) GO TO ITEST, (670,715)
      CALL PAGE1
      CALL PAGE2 (-4)
      WRITE  (OUTTAP,660) FIAT(1),FIAT(2),FIAT(3),X,CURSNO
  660 FORMAT (15H0FIAT AFTER SFA,3I4,12H  OSCAR STR ,I4,6H, STP ,I4, //,
     1        ' EQ AP  LTU  TP  UNIT  NTU  OF SG KN TR DATA-BLK      *',
     2     6X,'*   TRAILER   *      *      *  PRI BLKS   SEC FLS/BLKS',
     3     3X,'TER FLS/BLKS')
      II = FIAT(3)*ENTN1
      DO 665 IX = 1,II,ENTN1
      IPRT( 1) = RSHIFT(FEQU(IX),NBPW-1)
      IPRT( 2) = RSHIFT(ANDF(APNDMK,FORD(IX)),30)
      IPRT( 3) = RSHIFT(ANDF(LMSK  ,FORD(IX)),16)
      IPRT( 4) = RSHIFT(ANDF(TAPMSK,FILE(IX)),15)
      IPRT( 5) = ANDF(RMSK,FILE(IX))
      IPRT( 6) = ANDF(RMSK,FNTU(IX))
      IPRT( 7) = RSHIFT(FON(IX),NBPW-1)
      IPRT( 8) = FCUS(IX)
      IPRT( 9) = FKND(IX)
      IPRT(10) = RSHIFT(ANDF(TAPMSK,FNTU(IX)),15)
      IPRT(11) = FDBN(IX  )
      IPRT(12) = FDBN(IX+1)
      IF (IPRT(11) .NE. 0) GO TO 661
      IPRT(11) = NSFA(2)
      IPRT(12) = NSFA(2)
  661 IF (ENTN1 .EQ. 11) GO TO 662
      IPRT(13) = RSHIFT(FMAT(IX),16)
      IPRT(14) = ANDF(RXMSK,FMAT(IX))
      IPRT(15) = RSHIFT(FMAT(IX+1),16)
      IPRT(16) = ANDF(RXMSK,FMAT(IX+1))
      IPRT(17) = RSHIFT(FMAT(IX+2),16)
      IPRT(18) = ANDF(RXMSK,FMAT(IX+2))
      GO TO 663
  662 IPRT(13) = FMAT(IX  )
      IPRT(14) = FMAT(IX+1)
      IPRT(15) = FMAT(IX+2)
      IPRT(16) = FMAT(IX+5)
      IPRT(17) = FMAT(IX+6)
      IPRT(18) = FMAT(IX+7)
  663 IPRT(19) = RSHIFT(FMAT(IX+3),16)
      ITEMP    = ANDF(FMAT(IX+3),RXMSK)
      IPRT(20) = RSHIFT(ITEMP,8)
      IPRT(21) = RSHIFT(FMAT(IX+4),16)
      IPRT(22) = ITEMP - IPRT(20)*2**8
      IPRT(23) = ANDF(RXMSK,FMAT(IX+4))
      CALL PAGE2 (-1)
      WRITE  (OUTTAP,664) (IPRT(IY),IY=1,23)
  664 FORMAT (1H ,2(I2,1X),I5,1X,I2,2(1X,I5),4(1X,I2),1X,2A4,6I7,
     1        4X,I5,1X,2(7X,I2,1H/,I5))
  665 CONTINUE
      CALL XFLSZD (0,BLKSIZ,0)
      CALL PAGE2 (-2)
      WRITE  (OUTTAP,628) BLKSIZ
  628 FORMAT (30X,20H EACH BLOCK CONTAINS,I5,7H WORDS.)
      WRITE  (OUTTAP,666)
  666 FORMAT (52H POOL FILE CONTENTS   EQ    SIZE   FILE   DATA BLOCK)
      II = DPD(3)*3
      DO 668 IX = 1,II,3
      IPRT(1) = RSHIFT(DFNU(IX),NBPW-1)
      IPRT(2) = RSHIFT(DFNU(IX),16)
      IPRT(3) = ANDF(RXMSK,DFNU(IX))
      IPRT(4) = DDBN(IX  )
      IPRT(5) = DDBN(IX+1)
      CALL PAGE2 (-1)
      WRITE  (OUTTAP,667) (IPRT(IY),IY=1,5)
  667 FORMAT (22X,I2,I7,I7,3X,2A4)
  668 CONTINUE
      CALL DBMDIA
      CALL DBMSTF
C
      GO TO ITEST, (670,715)
C
  670 J = MCH
      IF (IABS(IBNK(ENTN1*5))/1000.NE.J .AND. J.GT.6) COMM(4) = J
      X = CURSNO
      NSFA(3) = IEND
      CALL CONMSG (NSFA,3,0)
      RETURN
C
C     MODULE ALLOCATION INCOMPLETE
C
  680 IF (I      .NE. 1) GO TO 620
      IF (ITPFLG .EQ. 0) GO TO 700
C
C     LOOKING FOR A TAPE + AT LEAST ONE TAPE EXISTS
C
      NOAVAL = 0
      DO 690 M = 1,LMT8,ENTN1
      IF (ANDF(TAPMSK,FILE(M)) .EQ. 0) GO TO 690
      IF (ANDF(TAPMSK,FNTU(M)) .EQ. 0) GO TO 710
      NOAVAL = 1
  690 CONTINUE
      IF (NOAVAL .EQ. 0) GO TO 700
      TAPMSK = 0
      GO TO 790
  700 CURSNO = 0
      GO TO 630
C
C     A TAPE FILE EXIST CONTAINING A D.B. NOT REQUIRING A TAPE  -
C     FREE THAT TAPE***  CHECK FOR EQUIV AND LTU D.B. ON SAME UNIT
C
  710 N = 1
C
      ASSIGN 715 TO ITEST
      GO TO 655
  715 CONTINUE
      ASSIGN 670 TO ITEST
C
      TRIAL = ANDF(RMSK,FILE(M))
      LMT   = LMT8 + 1
      DO 750 J = LMT,LMT9,ENTN1
      IF (TRIAL .NE. ANDF(RMSK,FILE(J))) GO TO 750
      INAM1 = FDBN(J  )
      INAM2 = FDBN(J+1)
      IF (FEQU(M).LT.0 .AND. FEQU(J).LT.0) GO TO 720
      FDBN(J) = ALMSK
      GO TO 725
  720 N = N + 1
  725 DO 730 L = LMT2,LMT3,ENTN2
      IF (INAM1.EQ.SDBN(L) .AND. INAM2.EQ.SDBN(L+1)) GO TO 740
  730 CONTINUE
      GO TO 750
C
C     TURN OFF ALLOC FLAG
C
  740 SAL(L) = ORF(ALMSK,SAL(L))
      ALCNT  = ALCNT - 1
  750 CONTINUE
      INAM1 = FDBN(M  )
      INAM2 = FDBN(M+1)
      DO 760 L = LMT2,LMT3,ENTN2
      IF (INAM1.EQ.SDBN(L) .AND. INAM2.EQ.SDBN(L+1)) GO TO 770
  760 CONTINUE
      GO TO 780
  770 SAL(L) = ORF(ALMSK,SAL(L))
      ALCNT  = ALCNT - 1
  780 FPUN(M)= ORF(S,N)
      CALL XPUNP
      FDBN(M  ) = SDBN(K  )
      FDBN(M+1) = SDBN(K+1)
      FORD(M  ) = ORF(ANDF(LXMSK,SORD(K)),ANDF(RXMSK,FILE(M)))
      FKND(M  ) = 8
C
      CALL SSWTCH (2,IX)
      IF (IX .NE. 1) GO TO 790
      CALL PAGE2 (-2)
      WRITE  (OUTTAP,785)
  785 FORMAT (38H0* XSFA REPEATS TO USE FREED TAPE FILE)
C
  790 BFF = 0
      GO TO 150
C
  920 WRITE  (OUTTAP,921) SFM
  921 FORMAT (A25,' 1001, OSCAR NOT FOUND IN DPL')
      GO TO  1000
  930 WRITE  (OUTTAP,931) SFM
  931 FORMAT (A25,' 1002, OSCAR CONTAINS NO MODULES')
      GO TO  1000
  940 WRITE  (OUTTAP,941) SFM
  941 FORMAT (A25,' 1003, POOL COULD NOT BE OPENED')
      GO TO  1000
  950 WRITE  (OUTTAP,951) SFM
  951 FORMAT (A25,' 1004, ILLEGAL EOF ON POOL')
 1000 CALL MESAGE (-37,0,NSFA)
      RETURN
      END

ext: f


! RUN: %S/test_errors.sh %s %t %flang_fc1
! REQUIRES: shell
implicit none
integer :: x
!ERROR: No explicit type declared for 'y'
y = x
end


text:
      SUBROUTINE MB04QS( TRANC, TRAND, TRANU, M, N, ILO, V, LDV, W, LDW,
     $                   C, LDC, D, LDD, CS, TAU, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     Overwrites general real m-by-n/n-by-m matrices C and D with
C
C               [ op(C) ]
C         U  *  [       ]   if TRANU = 'N', or
C               [ op(D) ]
C
C          T    [ op(C) ]
C         U  *  [       ]   if TRANU = 'T',
C               [ op(D) ]
C
C     where U is defined as the product of symplectic reflectors and
C     Givens rotations,
C
C         U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
C             diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
C                               ....
C             diag( H(k),H(k) ) G(k) diag( F(k),F(k) ),
C
C     with k = m-1, as returned by the SLICOT Library routines MB04PU
C     or MB04RU.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANC   CHARACTER*1
C             Specifies the form of op( C ) as follows:
C             = 'N':  op( C ) = C;
C             = 'T':  op( C ) = C';
C             = 'C':  op( C ) = C'.
C
C     TRAND   CHARACTER*1
C             Specifies the form of op( D ) as follows:
C             = 'N':  op( D ) = D;
C             = 'T':  op( D ) = D';
C             = 'C':  op( D ) = D'.
C
C     TRANU   CHARACTER*1
C             Specifies whether U or U' is applied as follows:
C             = 'N':  apply U;
C             = 'T':  apply U'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrices op(C) and op(D).
C             M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrices op(C) and op(D).
C             N >= 0.
C
C     ILO     (input) INTEGER
C             ILO must have the same value as in the previous call of
C             MB04PU or MB04RU. U is equal to the unit matrix except in
C             the submatrix
C             U([ilo+1:m m+ilo+1:2*m], [ilo+1:m m+ilo+1:2*m]).
C             1 <= ILO <= M+1.
C
C     V       (input) DOUBLE PRECISION array, dimension (LDV,M)
C             On entry, the leading M-by-M part of this array must
C             contain in its columns the vectors which define the
C             elementary reflectors H(i).
C
C     LDV     INTEGER
C             The leading dimension of the array V.  LDV >= MAX(1,M).
C
C     W       (input) DOUBLE PRECISION array, dimension (LDW,M)
C             On entry, the leading M-by-M part of this array must
C             contain in its columns the vectors which define the
C             elementary reflectors F(i).
C
C     LDW     INTEGER
C             The leading dimension of the array W.  LDW >= MAX(1,M).
C
C     C       (input/output) DOUBLE PRECISION array, dimension
C                     (LDC,N) if TRANC = 'N',
C                     (LDC,M) if TRANC = 'T' or TRANC = 'C'.
C             On entry with TRANC = 'N', the leading M-by-N part of this
C             array must contain the matrix C.
C             On entry with TRANC = 'T' or TRANC = 'C', the leading
C             N-by-M part of this array must contain the transpose of
C             the matrix C.
C             On exit with TRANC = 'N', the leading M-by-N part of this
C             array contains the updated matrix C.
C             On exit with TRANC = 'T' or TRANC = 'C', the leading
C             N-by-M part of this array contains the transpose of the
C             updated matrix C.
C
C     LDC     INTEGER
C             The leading dimension of the array C.
C             LDC >= MAX(1,M),  if TRANC = 'N';
C             LDC >= MAX(1,N),  if TRANC = 'T' or TRANC = 'C'.
C
C     D       (input/output) DOUBLE PRECISION array, dimension
C                     (LDD,N) if TRAND = 'N',
C                     (LDD,M) if TRAND = 'T' or TRAND = 'C'.
C             On entry with TRAND = 'N', the leading M-by-N part of this
C             array must contain the matrix D.
C             On entry with TRAND = 'T' or TRAND = 'C', the leading
C             N-by-M part of this array must contain the transpose of
C             the matrix D.
C             On exit with TRAND = 'N', the leading M-by-N part of this
C             array contains the updated matrix D.
C             On exit with TRAND = 'T' or TRAND = 'C', the leading
C             N-by-M part of this array contains the transpose of the
C             updated matrix D.
C
C     LDD     INTEGER
C             The leading dimension of the array D.
C             LDD >= MAX(1,M),  if TRAND = 'N';
C             LDD >= MAX(1,N),  if TRAND = 'T' or TRAND = 'C'.
C
C     CS      (input) DOUBLE PRECISION array, dimension (2*N-2)
C             On entry, the first 2*N-2 elements of this array must
C             contain the cosines and sines of the symplectic Givens
C             rotations G(i), as returned by MB04PU or MB04RU.
C
C     TAU     (input) DOUBLE PRECISION array, dimension (N-1)
C             On entry, the first N-1 elements of this array must
C             contain the scalar factors of the elementary reflectors
C             F(i), as returned by MB04PU or MB04RU.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal value
C             of LDWORK.
C             On exit, if  INFO = -18,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N).
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     CONTRIBUTORS
C
C     D. Kressner (Technical Univ. Berlin, Germany) and
C     P. Benner (Technical Univ. Chemnitz, Germany), December 2003.
C
C     REVISIONS
C
C     V. Sima, Nov. 2011 (SLICOT version of the HAPACK routine DOSMPV).
C
C     KEYWORDS
C
C     Elementary matrix operations, orthogonal symplectic matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANC, TRAND, TRANU
      INTEGER           ILO, INFO, LDC, LDD, LDV, LDW, LDWORK, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  C(LDC,*), CS(*), D(LDD,*), DWORK(*), TAU(*),
     $                  V(LDV,*), W(LDW,*)
C     .. Local Scalars ..
      LOGICAL           LQUERY, LTRC, LTRD, LTRU
      INTEGER           IC, ID, IERR, JC, JD, MH, MINWRK
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          MB04QB, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      LTRC = LSAME( TRANC, 'T' ) .OR. LSAME( TRANC, 'C' )
      LTRD = LSAME( TRAND, 'T' ) .OR. LSAME( TRAND, 'C' )
      LTRU = LSAME( TRANU, 'T' )
      MH = MAX( 0, M - ILO )
C
C     Check the scalar input parameters.
C
      IF (      .NOT.( LTRC .OR. LSAME( TRANC, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF ( .NOT.( LTRU .OR. LSAME( TRANU, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF ( M.LT.0 ) THEN
         INFO = -4
      ELSE IF ( N.LT.0 ) THEN
         INFO = -5
      ELSE IF ( ILO.LT.1 .OR. ILO.GT.M+1 ) THEN
         INFO = -6
      ELSE IF ( LDV.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF ( LDW.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF ( ( LTRC .AND. LDC.LT.MAX( 1, N ) ).OR.
     $     ( .NOT.LTRC .AND. LDC.LT.MAX( 1, M ) ) ) THEN
         INFO = -12
      ELSE IF ( ( LTRD .AND. LDD.LT.MAX( 1, N ) ).OR.
     $     ( .NOT.LTRD .AND. LDD.LT.MAX( 1, M ) ) ) THEN
         INFO = -14
      ELSE
         LQUERY = LDWORK.EQ.-1
         MINWRK = MAX( 1, N )
         IF ( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            DWORK(1) = DBLE( MINWRK )
            INFO = -18
         ELSE IF( LQUERY ) THEN
            IF ( M.LE.ILO .OR. N.EQ.0 ) THEN
               DWORK(1) = ONE
            ELSE
               CALL MB04QB( TRANC, TRAND, TRANU, 'C', 'C', MH, N, MH, V,
     $                      LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK,
     $                      -1, IERR )
               DWORK(1) = MAX( MINWRK, INT( DWORK(1) ) )
            END IF
            RETURN
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04QS', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( M.LE.ILO .OR. N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF ( LTRC ) THEN
         IC = 1
         JC = ILO + 1
      ELSE
         IC = ILO + 1
         JC = 1
      END IF
      IF ( LTRD ) THEN
         ID = 1
         JD = ILO + 1
      ELSE
         ID = ILO + 1
         JD = 1
      END IF
C
      CALL MB04QB( TRANC, TRAND, TRANU, 'Columnwise', 'Columnwise', MH,
     $             N, MH, V(ILO+1,ILO), LDV, W(ILO+1,ILO), LDW,
     $             C(IC,JC), LDC, D(ID,JD), LDD, CS(2*ILO-1), TAU(ILO),
     $             DWORK, LDWORK, IERR )
      RETURN
C *** Last line of MB04QS ***
      END

max_stars_repo_name: bnavigator/SLICOT-Reference

max_issues_repo_name: RJHKnight/slicotr

max_forks_repo_name: RJHKnight/slicotr


!=============================================================================!
        program main
!
!  MKMEAN:  Make a mean file for the linearized Navier-Stokes solver
!
!  Revised:  3-15-01  Changed to IJ on input and output format, still JI
!                     internally
!
!=============================================================================!
        use const
        implicit none

        real, allocatable :: vm(:,:,:), x(:,:), y(:,:)
        real    :: tmp
        integer :: nx, ny, nz, ndof=5

        real    :: Ma, Re, Pr, gamma=1.4, gamma1=0.4, cv=716.5
        integer :: i, j, k, idof
!=============================================================================!
        write(*,"(/,'MakeMean ',/)")
        write(*,"('Enter Re, Ma, Pr ==> ',$)")
        read (*,*) Re, Ma, Pr

!.... read in the grid file

        open(unit=10,file='grid.dat',form='unformatted',status='old')
        read(10) nx, ny, nz
        write(*,"('Read grid with dimensions (',i3,',',i3,',',i3,')')") &
                nx,ny,nz
        allocate( x(ny,nx), y(ny,nx) )
        read(10) (((x(j,i), i = 1, nx), j = 1, ny), k = 1, nz), &
                 (((y(j,i), i = 1, nx), j = 1, ny), k = 1, nz), &
                 (((   tmp, i = 1, nx), j = 1, ny), k = 1, nz)
        close(10)

        allocate( vm(ny,nx,ndof) )

        call mean( vm, x, y, nx, ny, ndof, Ma, Re, Pr )

        open(unit=10, file='mean.dat', form='unformatted', status='unknown')
        write(10) 0, zero, nx, ny, nz, ndof, Re, Ma, Pr, gamma, cv
        write(10) (((vm(j,i,idof), idof=1,ndof), i=1,nx), j=1,ny)
        close(10)

        stop
        end

!=============================================================================!
        module mkmean
!=============================================================================!
        use const
        real, allocatable :: xb(:), yb(:), el(:), r(:)
        real, allocatable :: bn1(:), bn2(:)
        real :: xi, yi
        integer :: jel

        contains

!=============================================================================!
        function uint(s)
!=============================================================================!
        implicit none
        real :: uint, xj, yj, s
!=============================================================================!
        xj = xb(jel) + bn2(jel) * s
        yj = yb(jel) - bn1(jel) * s

        uint = ( (xi-xj) ) /  &
     &         ( (xi-xj)**2 + (yi-yj)**2 )

        return
        end function uint

!=============================================================================!
        function vint(s)
!=============================================================================!
        implicit none
        real :: vint, xj, yj, s
!=============================================================================!
        xj = xb(jel) + bn2(jel) * s
        yj = yb(jel) - bn1(jel) * s

        vint = ( (yi-yj) ) /  &
     &         ( (xi-xj)**2 + (yi-yj)**2 )

        return
        end function vint

        end module mkmean

!=============================================================================!
        subroutine mean(vml, x, y, nx, ny, ndof, Ma, Re, Pr)
!=============================================================================!
        use const
        use mkmean
        implicit none

        integer :: nx, ny, ndof
        real    :: vml(ny,nx,ndof), x(ny,nx), y(ny,nx)
        real    :: Ma, Re, Pr, gamma=1.4, gamma1=0.4, cv=716.5

        real, allocatable :: ym(:,:), vt(:,:,:), vs(:,:,:)
        real :: ymaxm
        integer :: i, j, k, nxm, nym, ndofm, ier, idof

        real :: b, rbeta, u, v, t, rho, p, c, alpha

        character*1 ans
        character*80 name

        real :: result, errest, dummy
        integer :: np, nel

        real :: xii, eta, u1, u2, x0, y0, th, tmp
!=============================================================================!

        write(*,"('Use [M]ean flow profile,         [N]o flow, ', / , &
                & '    [U]nit flow,                 [P]otential flow,' , / , &
                & '    [C]urved mesn flow profile   ==> ',$)")
        read(*,"(a1)") ans

!.... input from file

        if (ans.eq.'M' .or. ans.eq.'m') then

!.... read the mean profile and spline to the computational grid

        write(*,"('Enter profile name ==> ',$)")
        read(*,*) name
        open (unit=10, file=name, form='formatted', status='old', err=1000)

        nxm = 1
        nym = 0
 20     continue
        read(10,*,end=30) tmp
        nym = nym + 1
        goto 20
 30     continue
        rewind(10)

!       read (10,*,err=1000,end=1010) nxm, nym, ndofm, ymaxm
!       if (ndofm .ne. ndof) then
!         write (*,*) 'NDOF in mean field is incorrect ',ndofm
!         call exit(1)
!       end if

        allocate( ym(nym,nxm), vt(nym,nxm,ndof), vs(nym,nxm,ndof), STAT=ier )
        if (ier .ne. 0) then
          write(*,*) 'Error allocating mean field'
          call exit(1)
        end if

        do i = 1, nxm
          do j = 1, nym
            read (10,*,err=1000,end=1010) ym(j,i), (vt(j,i,k),k=1,ndof)
          end do
          call SPLINE(nym, ym(1,i), vt(1,i,1), vs(1,i,1))
          call SPLINE(nym, ym(1,i), vt(1,i,2), vs(1,i,2))
          call SPLINE(nym, ym(1,i), vt(1,i,3), vs(1,i,3))
          call SPLINE(nym, ym(1,i), vt(1,i,4), vs(1,i,4))
          call SPLINE(nym, ym(1,i), vt(1,i,5), vs(1,i,5))
        end do

        close (10)

        ymaxm = ym(nym,1)

!.... Evaluate the mean field on the disturbance grid

        do i = 1, nx
          do j = 1, ny
            if (y(j,i) .lt. ymaxm) then
              call SPEVAL(nym, ym(1,1), vt(1,1,1), vs(1,1,1), &
                          y(j,i), vml(j,i,1))
              call SPEVAL(nym, ym(1,1), vt(1,1,2), vs(1,1,2), &
                          y(j,i), vml(j,i,2))
              call SPEVAL(nym, ym(1,1), vt(1,1,3), vs(1,1,3), &
                          y(j,i), vml(j,i,3))
              call SPEVAL(nym, ym(1,1), vt(1,1,4), vs(1,1,4), &
                          y(j,i), vml(j,i,4))
              call SPEVAL(nym, ym(1,1), vt(1,1,5), vs(1,1,5), &
                          y(j,i), vml(j,i,5))
            else
              vml(j,i,1) = vt(nym,1,1)
              vml(j,i,2) = vt(nym,1,2)
              vml(j,i,3) = vt(nym,1,3)
              vml(j,i,4) = vt(nym,1,4)
              vml(j,i,5) = vt(nym,1,5)
            end if
!           write (*,"(7(e13.6,1x))") y(j,i), (vml(j,i,k), k = 1, ndof)
          end do
        end do

!.... make the flow parallel

        write(*,"('WARNING: using parallel flow assumption...')")
        vml(:,:,3) = zero

        deallocate( ym, vt, vs )

        else if (ans.eq.'P' .or. ans.eq.'p') then       ! potential soln

          write(*,"('Enter the sweep angle ==> ',$)")
          read(*,*) alpha

          b = one / pi
          if (Ma.lt.one) then
            rbeta = sqrt(one - Ma**2)
          else
            rbeta = sqrt(Ma**2 - one)
          end if

          do i = 1, nx
            do j = 1, ny

              xi = x(j,i)
              yi = y(j,i)

!.... potential flow for a Rankine Oval

!             u   = one + (x(j,i)-b)/pi/rbeta**2/((x(j,i)-b)**2 + &
!                   rbeta**2*y(j,i)**2)
!             v   = rbeta*y(j,i)/pi/((x(j,i)-b)**2+rbeta**2*y(j,i)**2)
!             t   = one - pt5*gamma1*Ma**2*( u**2 + v**2 - one )
!             rho = t**(one/gamma1)
!             p   = rho * t / ( gamma * Ma**2 )
!             c   = sqrt(t)/Ma

!.... potential flow for parabolic cylinder (currently incompressible)

              eta = sqrt(pt5 - xi + pt5*sqrt((two*xi-one)**2 + four*yi**2))
              xii  = yi / eta
              u  = (eta**2 - eta + xii**2) / (xii**2 + eta**2)
              v  = xii / (xii**2 + eta**2)
              t   = one - pt5*gamma1*Ma**2*( u**2 + v**2 - one )
              rho = t**(one/gamma1)
              p   = rho * t / ( gamma * Ma**2 )
              c   = sqrt(t)/Ma

              vml(j,i,1) = rho
              vml(j,i,2) = u
              vml(j,i,3) = v
              vml(j,i,4) = tan(alpha)
              vml(j,i,5) = t
            end do
          end do

        else if (ans.eq.'U' .or. ans.eq.'u') then

          write(*,"('Enter the sweep angle ==> ',$)")
          read(*,*) alpha

          vml(:,:,1) = one
          vml(:,:,2) = one
          vml(:,:,3) = zero
          vml(:,:,4) = tan(alpha)
          vml(:,:,5) = one

        else if (ans.eq.'C' .or. ans.eq.'c') then

        write(*,"('Enter profile name ==> ',$)")
        read(*,*) name
        open (unit=10, file=name, form='formatted', status='old', err=1000)

        nxm = 1
        nym = 0
 40     continue
        read(10,*,end=50) tmp
        nym = nym + 1
        goto 40
 50     continue
        rewind(10)

!       read (10,*,err=1000,end=1010) nxm, nym, ndofm, ymaxm
!       if (ndofm .ne. ndof) then
!         write (*,*) 'NDOF in mean field is incorrect ',ndofm
!         call exit(1)
!       end if

        allocate( ym(nym,nxm), vt(nym,nxm,ndof), vs(nym,nxm,ndof), STAT=ier )
        if (ier .ne. 0) then
          write(*,*) 'Error allocating mean field'
          call exit(1)
        end if

        write(*,*) nxm, nym
        do i = 1, nxm
          do j = 1, nym
            read (10,*,err=1000,end=1010) ym(j,i), (vt(j,i,k),k=1,ndof)
          end do
          call SPLINE(nym, ym(1,i), vt(1,i,1), vs(1,i,1))
          call SPLINE(nym, ym(1,i), vt(1,i,2), vs(1,i,2))
          call SPLINE(nym, ym(1,i), vt(1,i,3), vs(1,i,3))
          call SPLINE(nym, ym(1,i), vt(1,i,4), vs(1,i,4))
          call SPLINE(nym, ym(1,i), vt(1,i,5), vs(1,i,5))
        end do
        close (10)

        ymaxm = ym(nym,1)

!.... Evaluate the mean field on the disturbance grid

        do i = 1, 1
          do j = 1, ny
            if (y(j,i) .lt. ymaxm) then
              call SPEVAL(nym, ym(1,1), vt(1,1,1), vs(1,1,1), &
                          y(j,1), vml(j,i,1))
              call SPEVAL(nym, ym(1,1), vt(1,1,2), vs(1,1,2), &
                          y(j,1), vml(j,i,2))
              call SPEVAL(nym, ym(1,1), vt(1,1,3), vs(1,1,3), &
                          y(j,1), vml(j,i,3))
              call SPEVAL(nym, ym(1,1), vt(1,1,4), vs(1,1,4), &
                          y(j,1), vml(j,i,4))
              call SPEVAL(nym, ym(1,1), vt(1,1,5), vs(1,1,5), &
                          y(j,1), vml(j,i,5))
            else
              vml(j,i,1) = vt(nym,1,1)
              vml(j,i,2) = vt(nym,1,2)
              vml(j,i,3) = vt(nym,1,3)
              vml(j,i,4) = vt(nym,1,4)
              vml(j,i,5) = vt(nym,1,5)
            end if
          end do
        end do

        write(*,"('WARNING: using parallel flow assumption...')")
        vml(:,:,3) = zero

!.... rotate to the new coordinate system

        write(*,"('Enter (x0, y0) ==> ',$)")
        read(*,*) x0, y0
        do i = 1, nx
          th = atan2( y(1,i)+y0, x(1,i)+x0 )
          do j = 1, ny
            vml(j,i,1) = vml(j,1,1)
            vml(j,i,2) =  sin(th) * vml(j,1,2) + cos(th) * vml(j,1,3)
            vml(j,i,3) = -cos(th) * vml(j,1,2) + sin(th) * vml(j,1,3)
            vml(j,i,4) = vml(j,1,4)
            vml(j,i,5) = vml(j,1,5)
          end do
        end do

        deallocate( ym, vt, vs )

        else            ! no flow

          vml(:,:,1) = one
          vml(:,:,2) = zero
          vml(:,:,3) = zero
          vml(:,:,4) = zero
          vml(:,:,5) = one

        end if

        return

1000    write(*,"('Error reading file mean.dat\')")
        call exit(1)
1010    write(*,"('End of file encountered in profile.dat\')")
        call exit(1)

        end

!-------------------------------------------------------------------------
!         b = one / pi
!         if (Ma.lt.one) then
!           rbeta = sqrt(one - Ma**2)
!         else
!           rbeta = sqrt(Ma**2 - one)
!         end if
!
!         do i = 1, nx
!           do j = 1, ny
!             u   = one + (x(j,i)-b)/pi/rbeta**2/((x(j,i)-b)**2 + &
!                   rbeta**2*y(j,i)**2)
!             v   = rbeta*y(j,i)/pi/((x(j,i)-b)**2+rbeta**2*y(j,i)**2)
!             t   = one - pt5*gamma1*Ma**2*( u**2 + v**2 - one )
!             rho = t**(one/gamma1)
!             p   = rho * t / ( gamma * Ma**2 )
!             c   = sqrt(t)/Ma
!
!             vml(j,i,1) = rho
!             vml(j,i,2) = u
!             vml(j,i,3) = v
!             vml(j,i,4) = zero
!             vml(j,i,5) = t
!           end do
!         end do
!-------------------------------------------------------------------------
!         open(unit=10,file='bndry.dat')
!         read(10,*) np
!         nel = np - 1
!         allocate( xb(np), yb(np), el(nel), r(nel), bn1(nel), bn2(nel) )
!         do i = 1, np
!           read(10,*) xb(i), yb(i)
!         end do
!         close(10)
!
!         open(10,file='pot.dat')
!         do jel = 1, nel
!           read(10,*) dummy, dummy, el(jel), bn1(jel), bn2(jel), r(jel)
!         end do
!         close(10)
!
!         do i = 250, 250
!           do j = 10,ny
!             write(*,*) i, j
!
!             xi = x(j,i)
!             yi = y(j,i)
!
!             u = one
!             v = zero
!             do jel = 1, nel
!               write(*,*) jel
!               call QDNG( uint, 0, el(jel), 1.0e-10, 0.0, &
!     &                     result, errest)
!               u = u + r(jel)*pt5/pi * result
!               call QDNG( vint, 0, el(jel), 1.0e-10, 0.0, &
!     &                     result, errest)
!               v = v +  r(jel)*pt5/pi * result
!             end do
!
!             t   = one - pt5*gamma1*Ma**2*( u**2 + v**2 - one )
!             rho = t**(one/gamma1)
!             p   = rho * t / ( gamma * Ma**2 )
!             c   = sqrt(t)/Ma
!
!             vml(j,i,1) = rho
!             vml(j,i,2) = u
!             vml(j,i,3) = v
!             vml(j,i,4) = zero
!             vml(j,i,5) = t
!             write(11,"(8(1pe13.6,1x))") xi, rho, u, v, t
!           end do
!         end do
!-------------------------------------------------------------------------
!         open(unit=10,file='bndry.dat')
!         read(10,*) np
!         nel = np - 1
!         allocate( xb(np), yb(np), el(nel), r(nel), bn1(nel), bn2(nel) )
!         do i = 1, np
!           read(10,*) xb(i), yb(i)
!         end do
!         close(10)
!
!         open(10,file='pot.dat')
!         do jel = 1, nel
!           read(10,*) dummy, dummy, el(jel), bn1(jel), bn2(jel), r(jel)
!         end do
!         close(10)
!
!         do i = 1, nx
!           do j = 1,ny
!
!             xi = x(j,i)
!             yi = y(j,i)
!
!             u = one
!             v = zero
!             do jel = 1, nel
!               call QDNG( uint, 0, el(jel), 1.0e-10, 0.0, &
!     &                     result, errest)
!               u = u + r(jel)*pt5/pi * result
!               call QDNG( vint, 0, el(jel), 1.0e-10, 0.0, &
!     &                     result, errest)
!               v = v +  r(jel)*pt5/pi * result
!             end do
!
!             t   = one - pt5*gamma1*Ma**2*( u**2 + v**2 - one )
!             rho = t**(one/gamma1)
!             p   = rho * t / ( gamma * Ma**2 )
!             c   = sqrt(t)/Ma
!
!             vml(j,i,1) = rho
!             vml(j,i,2) = u
!             vml(j,i,3) = v
!             vml(j,i,4) = zero
!             vml(j,i,5) = t
!
!             write(11,"(8(1pe13.6,1x))") xi, rho, u, v, t
!           end do
!         end do


text:
        !COMPILER-GENERATED INTERFACE MODULE: Thu Apr 13 17:24:30 2017
        MODULE TRIDIAGONAL__genmod
          INTERFACE
            SUBROUTINE TRIDIAGONAL(N,AU,BU,CU,DU,FI,LT,VALUE)
              INTEGER(KIND=4), INTENT(IN) :: N
              REAL(KIND=8), INTENT(IN) :: AU(N)
              REAL(KIND=8), INTENT(IN) :: BU(N)
              REAL(KIND=8), INTENT(IN) :: CU(N)
              REAL(KIND=8), INTENT(IN) :: DU(N)
              INTEGER(KIND=4), INTENT(IN) :: FI
              INTEGER(KIND=4), INTENT(IN) :: LT
              REAL(KIND=8), INTENT(OUT) :: VALUE(N)
            END SUBROUTINE TRIDIAGONAL
          END INTERFACE
        END MODULE TRIDIAGONAL__genmod

max_stars_repo_name: BingzhangChen/NPZDFeCONT

max_issues_repo_name: BingzhangChen/NPZDFeCONT

max_forks_repo_name: BingzhangChen/NPZDFeCONT


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> A module for handling scratch memory for matrix multiplication.
!> The purpose of this module is to avoid having to allocate memory on the
!> heap during a matrix multiply, and to manage the underlying hash table.
MODULE MatrixMemoryPoolModule
  USE DataTypesModule, ONLY: NTREAL, NTCOMPLEX
  USE TripletModule, ONLY : Triplet_r, Triplet_c
  IMPLICIT NONE
  PRIVATE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> A memory pool datatype that can be reused for matrix matrix multiplication.
  !> this is to prevent excessive alloc/dealloc.
  TYPE, PUBLIC :: MatrixMemoryPool_lr
     PRIVATE
     !> Shape of matrix: columns
     INTEGER, PUBLIC :: columns
     !> Shape of matrix: rows
     INTEGER, PUBLIC :: rows
     !> storage for actual values added to the matrix.
     TYPE(Triplet_r), DIMENSION(:), ALLOCATABLE, PUBLIC :: pruned_list
     !> storage for potential values added to the matrix.
     REAL(NTREAL), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: value_array
     !> true if an element has been pushed to this part of the matrix.
     LOGICAL, DIMENSION(:,:), ALLOCATABLE, PUBLIC :: dirty_array
     !> Storage space for indices, hashed.
     INTEGER, DIMENSION(:,:), ALLOCATABLE, PUBLIC :: hash_index
     !> Internal storage space for amount of items added to a bucket.
     INTEGER, DIMENSION(:,:), ALLOCATABLE, PUBLIC :: inserted_per_bucket
     !> Size of the buckets.
     INTEGER, PUBLIC :: hash_size
  END TYPE MatrixMemoryPool_lr
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> A memory pool datatype that can be reused for matrix matrix multiplication.
  !> this is to prevent excessive alloc/dealloc.
  TYPE, PUBLIC :: MatrixMemoryPool_lc
     PRIVATE
     !> Shape of matrix: columns
     INTEGER, PUBLIC :: columns
     !> Shape of matrix: rows
     INTEGER, PUBLIC :: rows
     !> storage for actual values added to the matrix.
     TYPE(Triplet_c), DIMENSION(:), ALLOCATABLE, PUBLIC :: pruned_list
     !> storage for potential values added to the matrix.
     COMPLEX(NTCOMPLEX), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: value_array
     !> true if an element has been pushed to this part of the matrix.
     LOGICAL, DIMENSION(:,:), ALLOCATABLE, PUBLIC :: dirty_array
     !> Storage space for indices, hashed.
     INTEGER, DIMENSION(:,:), ALLOCATABLE, PUBLIC :: hash_index
     !> Internal storage space for amount of items added to a bucket.
     INTEGER, DIMENSION(:,:), ALLOCATABLE, PUBLIC :: inserted_per_bucket
     !> Size of the buckets.
     INTEGER, PUBLIC :: hash_size
  END TYPE MatrixMemoryPool_lc
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  PUBLIC :: ConstructMatrixMemoryPool
  PUBLIC :: DestructMatrixMemoryPool
  PUBLIC :: CheckMemoryPoolValidity
  PUBLIC :: SetPoolSparsity
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  INTERFACE MatrixMemoryPool_lr
     MODULE PROCEDURE ConstructMatrixMemoryPool_lr
  END INTERFACE MatrixMemoryPool_lr
  INTERFACE MatrixMemoryPool_lc
     MODULE PROCEDURE ConstructMatrixMemoryPool_lc
  END INTERFACE MatrixMemoryPool_lc
  INTERFACE ConstructMatrixMemoryPool
     MODULE PROCEDURE ConstructMatrixMemoryPoolSub_lr
     MODULE PROCEDURE ConstructMatrixMemoryPoolSub_lc
  END INTERFACE ConstructMatrixMemoryPool
  INTERFACE DestructMatrixMemoryPool
     MODULE PROCEDURE DestructMatrixMemoryPool_lr
     MODULE PROCEDURE DestructMatrixMemoryPool_lc
  END INTERFACE DestructMatrixMemoryPool
  INTERFACE CheckMemoryPoolValidity
     MODULE PROCEDURE CheckMemoryPoolValidity_lr
     MODULE PROCEDURE CheckMemoryPoolValidity_lc
  END INTERFACE CheckMemoryPoolValidity
  INTERFACE SetPoolSparsity
     MODULE PROCEDURE SetPoolSparsity_lr
     MODULE PROCEDURE SetPoolSparsity_lc
  END INTERFACE SetPoolSparsity
CONTAINS!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> Subroutine wrapper for the constructor.
  SUBROUTINE ConstructMatrixMemoryPoolSub_lr(this, columns, rows, sparsity_in)
    !> The matrix to construct.
    TYPE(MatrixMemoryPool_lr), TARGET :: this
    !> Number of columns in the matrix.
    INTEGER, INTENT(IN) :: columns
    !> Number of rows in the matrix.
    INTEGER, INTENT(IN) :: rows
    !> Estimated sparsity (optional).
    REAL(NTREAL), INTENT(IN), OPTIONAL :: sparsity_in

    IF (PRESENT(sparsity_in)) THEN
       this = MatrixMemoryPool_lr(columns, rows, sparsity_in)
    ELSE
       this = MatrixMemoryPool_lr(columns, rows)
    END IF
  END SUBROUTINE ConstructMatrixMemoryPoolSub_lr
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> Subroutine wrapper for the constructor.
  SUBROUTINE ConstructMatrixMemoryPoolSub_lc(this, columns, rows, sparsity_in)
    !> The matrix to construct.
    TYPE(MatrixMemoryPool_lc), TARGET :: this
    !> Number of columns in the matrix.
    INTEGER, INTENT(IN) :: columns
    !> Number of rows in the matrix.
    INTEGER, INTENT(IN) :: rows
    !> Estimated sparsity (optional).
    REAL(NTREAL), INTENT(IN), OPTIONAL :: sparsity_in

    IF (PRESENT(sparsity_in)) THEN
       this = MatrixMemoryPool_lc(columns, rows, sparsity_in)
    ELSE
       this = MatrixMemoryPool_lc(columns, rows)
    END IF
  END SUBROUTINE ConstructMatrixMemoryPoolSub_lc
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> Construct Matrix Memory Pool object.
  FUNCTION ConstructMatrixMemoryPool_lr(columns, rows, sparsity_in) RESULT(this)
    !> The matrix to construct.
    TYPE(MatrixMemoryPool_lr), TARGET :: this
    !> Number of columns in the matrix.
    INTEGER, INTENT(IN) :: columns
    !> Number of rows in the matrix.
    INTEGER, INTENT(IN) :: rows
    !> Estimated sparsity (optional).
    REAL(NTREAL), INTENT(IN), OPTIONAL :: sparsity_in

  !! Temporary variables
  INTEGER :: alloc_stat
  INTEGER :: num_buckets

  this%columns = columns
  this%rows = rows

  IF (.NOT. PRESENT(sparsity_in)) THEN
     this%hash_size = 1
  ELSE
     this%hash_size = INT(1.0/sparsity_in)
     IF (this%hash_size > columns) this%hash_size = columns
  END IF

  num_buckets = columns/this%hash_size + 1

  !! Allocate
  ALLOCATE(this%pruned_list(columns*rows), stat=alloc_stat)
  ALLOCATE(this%value_array(columns,rows), stat=alloc_stat)
  ALLOCATE(this%dirty_array(columns,rows), stat=alloc_stat)

  ALLOCATE(this%hash_index(columns,rows))
  ALLOCATE(this%inserted_per_bucket(columns,rows))

  this%value_array = 0
  this%hash_index = 0
  this%inserted_per_bucket = 0
  this%dirty_array = .FALSE.

  END FUNCTION ConstructMatrixMemoryPool_lr
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> Construct Matrix Memory Pool object.
  FUNCTION ConstructMatrixMemoryPool_lc(columns, rows, sparsity_in) RESULT(this)
    !> The matrix to construct.
    TYPE(MatrixMemoryPool_lc), TARGET :: this
    !> Number of columns in the matrix.
    INTEGER, INTENT(IN) :: columns
    !> Number of rows in the matrix.
    INTEGER, INTENT(IN) :: rows
    !> Estimated sparsity (optional).
    REAL(NTREAL), INTENT(IN), OPTIONAL :: sparsity_in

  !! Temporary variables
  INTEGER :: alloc_stat
  INTEGER :: num_buckets

  this%columns = columns
  this%rows = rows

  IF (.NOT. PRESENT(sparsity_in)) THEN
     this%hash_size = 1
  ELSE
     this%hash_size = INT(1.0/sparsity_in)
     IF (this%hash_size > columns) this%hash_size = columns
  END IF

  num_buckets = columns/this%hash_size + 1

  !! Allocate
  ALLOCATE(this%pruned_list(columns*rows), stat=alloc_stat)
  ALLOCATE(this%value_array(columns,rows), stat=alloc_stat)
  ALLOCATE(this%dirty_array(columns,rows), stat=alloc_stat)

  ALLOCATE(this%hash_index(columns,rows))
  ALLOCATE(this%inserted_per_bucket(columns,rows))

  this%value_array = 0
  this%hash_index = 0
  this%inserted_per_bucket = 0
  this%dirty_array = .FALSE.

  END FUNCTION ConstructMatrixMemoryPool_lc
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> A destructor for a matrix memory pool
  PURE SUBROUTINE DestructMatrixMemoryPool_lr(this)
    !> The matrix being destructed.
    TYPE(MatrixMemoryPool_lr), INTENT(INOUT) :: this

  !! Perform deallocations.
  IF (ALLOCATED(this%pruned_list)) DEALLOCATE(this%pruned_list)
  IF (ALLOCATED(this%value_array)) DEALLOCATE(this%value_array)
  IF (ALLOCATED(this%dirty_array)) DEALLOCATE(this%dirty_array)
  IF (ALLOCATED(this%hash_index)) DEALLOCATE(this%hash_index)
  IF (ALLOCATED(this%inserted_per_bucket)) DEALLOCATE(this%inserted_per_bucket)

  END SUBROUTINE DestructMatrixMemoryPool_lr
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> A destructor for a matrix memory pool
  PURE SUBROUTINE DestructMatrixMemoryPool_lc(this)
    !> The matrix being destructed.
    TYPE(MatrixMemoryPool_lc), INTENT(INOUT) :: this

  !! Perform deallocations.
  IF (ALLOCATED(this%pruned_list)) DEALLOCATE(this%pruned_list)
  IF (ALLOCATED(this%value_array)) DEALLOCATE(this%value_array)
  IF (ALLOCATED(this%dirty_array)) DEALLOCATE(this%dirty_array)
  IF (ALLOCATED(this%hash_index)) DEALLOCATE(this%hash_index)
  IF (ALLOCATED(this%inserted_per_bucket)) DEALLOCATE(this%inserted_per_bucket)

  END SUBROUTINE DestructMatrixMemoryPool_lc
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> Checks if a given memory pool has been validly allocated to handle
  !> the given parameters.
  PURE FUNCTION CheckMemoryPoolValidity_lr(this, columns, rows) RESULT(isvalid)
    !> The memory pool to check.
    TYPE(MatrixMemoryPool_lr), INTENT(in) :: this
    !> Number of columns in the matrix.
    INTEGER, INTENT(IN) :: columns
    !> Number of rows in the matrix.
    INTEGER, INTENT(IN) :: rows
    !> true if the memory pool is valid.
    LOGICAL :: isvalid

  isvalid = .TRUE.
  !! Check allocation
  IF (.NOT. ALLOCATED(this%pruned_list)) isvalid = .FALSE.
  IF (.NOT. ALLOCATED(this%value_array)) isvalid = .FALSE.

  !! Check allocation size
  IF (.NOT. SIZE(this%value_array,dim=2) .EQ. rows) THEN
     isvalid = .FALSE.
  END IF
  IF (.NOT. SIZE(this%value_array,dim=1) .EQ. columns) THEN
     isvalid = .FALSE.
  END IF

  END FUNCTION CheckMemoryPoolValidity_lr
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> Checks if a given memory pool has been validly allocated to handle
  !> Checks if a given memory pool has been validly allocated to handle
  !> the given parameters.
  PURE FUNCTION CheckMemoryPoolValidity_lc(this, columns, rows) RESULT(isvalid)
    !> The memory pool to check.
    TYPE(MatrixMemoryPool_lc), INTENT(in) :: this
    !> Number of columns in the matrix.
    INTEGER, INTENT(IN) :: columns
    !> Number of rows in the matrix.
    INTEGER, INTENT(IN) :: rows
    !> true if the memory pool is valid.
    LOGICAL :: isvalid

  isvalid = .TRUE.
  !! Check allocation
  IF (.NOT. ALLOCATED(this%pruned_list)) isvalid = .FALSE.
  IF (.NOT. ALLOCATED(this%value_array)) isvalid = .FALSE.

  !! Check allocation size
  IF (.NOT. SIZE(this%value_array,dim=2) .EQ. rows) THEN
     isvalid = .FALSE.
  END IF
  IF (.NOT. SIZE(this%value_array,dim=1) .EQ. columns) THEN
     isvalid = .FALSE.
  END IF

  END FUNCTION CheckMemoryPoolValidity_lc
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> Sets the expected sparsity of the matrix, which helps with hashing.
  SUBROUTINE SetPoolSparsity_lr(this,sparsity)
    !> The memory pool to set the sparsity of.
    TYPE(MatrixMemoryPool_lr), INTENT(INOUT), TARGET :: this
    !> The sparsity value.
    REAL(NTREAL), INTENT(IN) :: sparsity

  !! Local Variables
  INTEGER :: num_buckets

  this%hash_size = INT(1.0/sparsity)
  IF (this%hash_size > this%columns) this%hash_size = this%columns
  num_buckets = this%columns/this%hash_size + 1

  END SUBROUTINE SetPoolSparsity_lr
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> Sets the expected sparsity of the matrix, which helps with hashing.
  SUBROUTINE SetPoolSparsity_lc(this,sparsity)
    !> The memory pool to set the sparsity of.
    TYPE(MatrixMemoryPool_lc), INTENT(INOUT), TARGET :: this
    !> The sparsity value.
    REAL(NTREAL), INTENT(IN) :: sparsity

  !! Local Variables
  INTEGER :: num_buckets

  this%hash_size = INT(1.0/sparsity)
  IF (this%hash_size > this%columns) this%hash_size = this%columns
  num_buckets = this%columns/this%hash_size + 1

  END SUBROUTINE SetPoolSparsity_lc
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
END MODULE MatrixMemoryPoolModule


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

! CHECK-LABEL: func @_QPmaxval_test(
! CHECK-SAME: %[[arg0:.*]]: !fir.box<!fir.array<?xi32>>{{.*}}) -> i32
integer function maxval_test(a)
integer :: a(:)
! CHECK-DAG:  %[[c0:.*]] = arith.constant 0 : index
! CHECK-DAG:  %[[a2:.*]] = fir.absent !fir.box<i1>
! CHECK-DAG:  %[[a4:.*]] = fir.convert %[[arg0]] : (!fir.box<!fir.array<?xi32>>) -> !fir.box<none>
! CHECK:  %[[a6:.*]] = fir.convert %[[c0]] : (index) -> i32
! CHECK:  %[[a7:.*]] = fir.convert %[[a2]] : (!fir.box<i1>) -> !fir.box<none>
maxval_test = maxval(a)
! CHECK:  %{{.*}} = fir.call @_FortranAMaxvalInteger4(%[[a4]], %{{.*}}, %{{.*}}, %[[a6]], %[[a7]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> i32
end function

! CHECK-LABEL: func @_QPmaxval_test2(
! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.char<1>>, %[[arg1:.*]]: index, %[[arg2:.*]]: !fir.box<!fir.array<?x!fir.char<1>>> {fir.bindc_name = "a"}) -> !fir.boxchar<1> {
character function maxval_test2(a)
character :: a(:)
! CHECK-DAG:  %[[a0:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>>
! CHECK:  %[[a1:.*]] = fir.absent !fir.box<i1>
! CHECK-DAG:  %[[a5:.*]] = fir.convert %[[a0]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
! CHECK:  %[[a6:.*]] = fir.convert %[[arg2]] : (!fir.box<!fir.array<?x!fir.char<1>>>) -> !fir.box<none>
! CHECK-DAG:  %[[a8:.*]] = fir.convert %[[a1]] : (!fir.box<i1>) -> !fir.box<none>
maxval_test2 = maxval(a)
! CHECK:  %{{.*}} = fir.call @_FortranAMaxvalCharacter(%[[a5]], %[[a6]], %{{.*}}, %{{.*}}, %[[a8]]) : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.ref<i8>, i32, !fir.box<none>) -> none
end function

! CHECK-LABEL: func @_QPmaxval_test3(
! CHECK-SAME: %[[arg0:.*]]: !fir.box<!fir.array<?x?xi32>>{{.*}}, %[[arg1:.*]]: !fir.box<!fir.array<?xi32>>
subroutine maxval_test3(a,r)
integer :: a(:,:)
integer :: r(:)
! CHECK-DAG:  %[[c2_i32:.*]] = arith.constant 2 : i32
! CHECK-DAG:  %[[a0:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>>
! CHECK:  %[[a1:.*]] = fir.absent !fir.box<i1>
! CHECK-DAG:  %[[a6:.*]] = fir.convert %[[a0]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK:  %[[a7:.*]] = fir.convert %[[arg0]] : (!fir.box<!fir.array<?x?xi32>>) -> !fir.box<none>
! CHECK-DAG:  %[[a9:.*]] = fir.convert %[[a1]] : (!fir.box<i1>) -> !fir.box<none>
r = maxval(a,dim=2)
! CHECK:  %{{.*}} = fir.call @_FortranAMaxvalDim(%[[a6]], %[[a7]], %[[c2_i32]], %{{.*}}, %{{.*}}, %[[a9]]) : (!fir.ref<!fir.box<none>>, !fir.box<none>, i32, !fir.ref<i8>, i32, !fir.box<none>) -> none
! CHECK:  %[[a11:.*]] = fir.load %[[a0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
! CHECK-DAG:  %[[a13:.*]] = fir.box_addr %[[a11]] : (!fir.box<!fir.heap<!fir.array<?xi32>>>) -> !fir.heap<!fir.array<?xi32>>
! CHECK-DAG:  fir.freemem %[[a13]]
end subroutine

! CHECK-LABEL: func @_QPtest_maxval_optional_scalar_mask(
! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<!fir.logical<4>>
subroutine test_maxval_optional_scalar_mask(mask, array)
integer :: array(:)
logical, optional :: mask
print *, maxval(array, mask)
! CHECK:  %[[VAL_7:.*]] = fir.is_present %[[VAL_1]] : (!fir.ref<!fir.logical<4>>) -> i1
! CHECK:  %[[VAL_8:.*]] = fir.embox %[[VAL_1]] : (!fir.ref<!fir.logical<4>>) -> !fir.box<!fir.logical<4>>
! CHECK:  %[[VAL_9:.*]] = fir.absent !fir.box<!fir.logical<4>>
! CHECK:  %[[VAL_10:.*]] = arith.select %[[VAL_7]], %[[VAL_8]], %[[VAL_9]] : !fir.box<!fir.logical<4>>
! CHECK:  %[[VAL_17:.*]] = fir.convert %[[VAL_10]] : (!fir.box<!fir.logical<4>>) -> !fir.box<none>
! CHECK: fir.call @_FortranAMaxvalInteger4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_17]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> i32
end subroutine

! CHECK-LABEL: func @_QPtest_maxval_optional_array_mask(
! CHECK-SAME:  %[[VAL_0:.*]]: !fir.box<!fir.array<?x!fir.logical<4>>>
subroutine test_maxval_optional_array_mask(mask, array)
integer :: array(:)
logical, optional :: mask(:)
print *, maxval(array, mask)
! CHECK:  %[[VAL_13:.*]] = fir.convert %[[VAL_0]] : (!fir.box<!fir.array<?x!fir.logical<4>>>) -> !fir.box<none>
! CHECK: fir.call @_FortranAMaxvalInteger4(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_13]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32, !fir.box<none>) -> i32
end subroutine

max_stars_repo_name: colemancda/llvm-project

max_issues_repo_name: colemancda/llvm-project

max_forks_repo_name: colemancda/llvm-project


text:
module util_module

  use amrex_constants_module
  use amrex_fort_module, only : rt => amrex_real

  implicit none

contains

  subroutine get_xn(xn_zone)

    use network,       only: nspec, spec_names
    use extern_probin_module, only: xin_file

    real(rt), intent(  out) :: xn_zone(:,:)

    integer         :: un, i
    real(rt) :: summ, usr_in
    character (len=4096) :: line

    ! read in an inputs file containing the mass fractions.
    ! each species is on its own line.
    ! Allow for comment lines with '#' in the first column
    open(newunit=un, file=xin_file, status='old')

    summ = ZERO

    i = 1
    do while (i <= nspec)
       ! read the line into a character buffer
       read (un,'(a)') line
       if (index(line, '#') == 1) cycle

       read (line,*) xn_zone(i,:)

       i = i + 1
    enddo

    ! need to add check on the species name, and check that we sum to 1

    close(un)
  end subroutine get_xn

end module util_module

max_stars_repo_name: doreenfan/Microphysics

max_issues_repo_name: Youhichka/Microphysics

max_forks_repo_name: Youhichka/Microphysics


text:
Tree Associates are arborists who provide expert opinion regarding landscape trees.  They provide a wide range of tree services concerning tree preservation, appraisal and management to a diverse clientele.  Their services include tree surveys, tree risk and root damage evaluation, tree health assessment, tree preservation plans, tree appraisal, expert witness testimony and forensic expert services.  Their clientele include insurance companies and adjusters, attorneys, governmental agencies, developers, landscape architects, homeowners associations and homeowners.

Territory served
  http://treeassociates.net/clientsindaviswoodlandandyolocounty/ Davis, Woodland, Winters, West Sacramento and all of Yolo County.
  Vacaville, Dixon, Fairfield, Vallejo and all of Solano County.
  http://localwiki.net/sac/Tree_Associates_Professional_Consulting_Arborists Sacramento, http://localwiki.net/elkgrove/Tree_Associates_Professional_Consulting_Arborists Elk Grove, Wilton, http://treeassociates.net/clientsinsacramentocityandcounty/ Folsom and all of Sacramento County.
  http://lincoln.wikispot.org/Tree_Associates_Professional_Consulting_Arborists Roseville, Lincoln and surrounding areas of Placer County.
  Napa and surrounding areas of Napa County.
  http://lamorinda.wikispot.org/Tree_Associates_Professional_Consulting_Arborists San Ramon and surrounding areas of Contra Costa County.
  http://treeassociates.net/clientsinsanfranciscobayareacaliforniastatewide/ San Francisco Bay Area, Sierra Nevada and Northern California.

Analysis of Soil Problems that Inhibit Tree Growth
Tree Associates was hired by Tom to examine a redwood tree that was growing poorly on Morro Bay Avenue in west Davis. John Lichter examined the soil profile and collected soil samples for chemical analysis. High soil salinity, soil density and poor drainage were negatively impacting tree performance. Tree Associates worked with Tom to develop an effective strategy for improved growth of the redwood tree and to enable addditional conifer trees to be planted on the property.

Loss of foliage in redwood trees

Jessica was concerned about the loss of foliage, canopy thinning, and loss of canopy density in her redwood trees on Almond Lane in Davis, CA.  After examining the trees and soil, Tree Associates determined that the soil was not receiving ample irrigation and recommended that she increase the irrigation run times.  Tree Associates also collected samples to submit to pathologists at the California Department of Food and Agriculture Plant Pest Diagnostics Lab to test for the possibility of disease in the trees.

More about Tree Associates
  http://davis.patch.com/listings/treeassociates Tree Associates  Davis, CA Patch
  http://www.linkedin.com/pub/johnlichter/6/a85/808 John Lichter  LinkedIn

See more: Tree Services

20130829 21:18:56 nbsp I hired John Lichter of Tree Associates to evaluate a large English Laurel in my yard that had been losing leaves. He did a careful examination of the tree and found it to be basically healthy, but made several specific suggestions about the irrigation and trimming of the tree. While he was on site, he evaluated several other trees in the yard and offered suggestions about their care. I found John to be thorough, very knowledgeable, conscientious, honest, and articulate. I would definitely hire him again.  Users/AnneJackson

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


MODULE NCA_VARS_GLOBAL
  USE NCA_INPUT_VARS
  implicit none

  !SIZE OF THE PROBLEM
  !Ns       = # of levels per spin
  !Nlevels  = 2*Ns = total #  of levels
  !Nfock = 2**Nlevels = 2**(2Ns) max size of the Hilbert space
  !Nsectors = # of sectors
  !=========================================================
  integer                                                 :: Ns
  integer                                                 :: Nlevels
  integer                                                 :: Nsectors
  integer                                                 :: Nfock

  !local part of the Hamiltonian
  !=========================================================
  complex(8),dimension(:,:,:,:),allocatable               :: impHloc           !local hamiltonian

  !Some maps between sectors and full Hilbert space (pointers)
  !=========================================================
  integer,allocatable,dimension(:,:)                      :: getsector
  integer,allocatable,dimension(:,:)                      :: getCsector
  integer,allocatable,dimension(:,:)                      :: getCDGsector
  integer,allocatable,dimension(:)                        :: getdim,getnup,getndw

  !TO BE REMOVED or MODIFIED
  type hilbert_space_operator
     real(8),dimension(:,:),allocatable :: Op
  end type hilbert_space_operator
  type(hilbert_space_operator),dimension(:,:),allocatable :: Coperator,CDGoperator
  real(8),dimension(:,:),allocatable                      :: EigBasis
  real(8),dimension(:),allocatable                        :: EigValues

  !SECTOR-TO-FOCK SPACE STRUCTURE
  !=========================================================
  type sector_map
     integer,dimension(:),allocatable :: map
  end type sector_map
  interface map_allocate
     module procedure                 :: map_allocate_scalar
     module procedure                 :: map_allocate_vector
  end interface map_allocate
  interface map_deallocate
     module procedure                 :: map_deallocate_scalar
     module procedure                 :: map_deallocate_vector
  end interface map_deallocate

  !Partition functions
  !=========================================================
  real(8)                                                 :: zeta_function

  !Anderson model Hybridization function Delta_nca(tau) : (Nspin,Nspin,Norb,Norb,0:Ltau)
  !=========================================================
  complex(8),allocatable,dimension(:,:,:,:,:)             :: NcaDeltaAnd_iw
  real(8),allocatable,dimension(:,:,:,:,:)                :: NcaDeltaAnd_tau

  !Atomic limit bare and dressed propagato: ncaR0(tau),ncaR(tau): [Nfock][Nfock][0:Ltau]
  !=========================================================
  real(8),allocatable,dimension(:,:,:)                    :: ncaR0
  real(8),allocatable,dimension(:,:,:)                    :: ncaR

  !Impurity Green's function and Self-Energies: (Nspin,Nspin,Norb,Norb,:)
  !=========================================================
  complex(8),allocatable,dimension(:,:,:,:,:)             :: impSmats
  complex(8),allocatable,dimension(:,:,:,:,:)             :: impStail
  complex(8),allocatable,dimension(:,:,:,:,:)             :: impGmats
  complex(8),allocatable,dimension(:,:,:,:,:)             :: impG0mats

  !Density and double occupancy
  !=========================================================
  real(8),dimension(:),allocatable                        ::  nca_dens
  real(8),dimension(:,:),allocatable                      ::  nca_dens_spin
  real(8),dimension(:),allocatable                        ::  nca_docc
  real(8),dimension(:),allocatable                        ::  nca_sz2
  real(8),dimension(:,:),allocatable                      ::  nca_zeta

contains

  subroutine map_allocate_scalar(H,N)
    type(sector_map)              :: H
    integer                       :: N
    allocate(H%map(N))
  end subroutine map_allocate_scalar
  !
  subroutine map_allocate_vector(H,N)
    type(sector_map),dimension(:) :: H
    integer,dimension(size(H))    :: N
    integer                       :: i
    do i=1,size(H)
       allocate(H(i)%map(N(i)))
    enddo
  end subroutine map_allocate_vector

  subroutine map_deallocate_scalar(H)
    type(sector_map)              :: H
    deallocate(H%map)
  end subroutine map_deallocate_scalar
  !
  subroutine map_deallocate_vector(H)
    type(sector_map),dimension(:) :: H
    integer                       :: i
    do i=1,size(H)
       deallocate(H(i)%map)
    enddo
  end subroutine map_deallocate_vector

END MODULE NCA_VARS_GLOBAL


text:
Debats du Senat (hansard)
1ere Session, 36e Legislature,
Volume 137, Numero 38
Le jeudi 12 fevrier 1998
L'honorable Gildas L. Molgat, President
Le deces de John G.H. Halstead
La crise dans le systeme de sante
Feu l'honorable juge Mark McGuigan, c.p., c.r.
La qualite du debat au Senat
Regie interne, budgets et administration
Presentation du neuvieme rapport du comite
Conference parlementaire des Ameriques
Depot du rapport de la delegation du Parlement du Canada
Droits de l'enfant non encore ne
La creation du comite parlementaire mixte-Avis de motion
La politique du Canada relative a la crise actuelle-Avis d'interpellation
Le manque d'accessibilite pour les personnes handicapees-Avis d'interpellation
La Commission canadienne du ble-Le montant total des impayes-La position du gouvernement
Etude du rapport final du comite senatorial special-Suite du debat
Projet de loi modificatif-Deuxieme lecture-Ajournement du debat
Le jeudi 12 fevrier 1998
La seance est ouverte a 14 heures, le President etant au fauteuil.
Le deces de John G.H. Halstead
L'honorable Jerahmiel S. Grafstein :
Tous etaient imbus du role social auquel les avait prepares leur foi.
La moralite etait a la base de leurs principes et de leurs politiques.
A son retour au Canada, il s'est joint au service exterieur.
John ecrivait remarquablement bien et avait un grand sens de la strategie.
Il etait actif au sein de l'Institut d'etudes strategiques.
Les grands amours de John ont ete l'Europe, l'OTAN et l'Allemagne.
John et moi partagions un grand interet pour la litterature et l'histoire allemandes.
Quand on lui a decerne l'Ordre du Canada, en 1996, il a declare ceci:
Il n'est pas la pour faire de l'argent.
Le gouvernement est la pour servir les gens qui l'ont elu.
John savait envisager l'avenir dans un esprit clair et concis.
J'offre mes condoleances a sa femme, Jean, et a son fils, Christopher.
La crise dans le systeme de sante
L'honorable Erminie J. Cohen :
C'est une source de grandes preoccupations.
Epuises, les medecins cherchent une solution;
Les compressions font mal;
Les medecins reclament de l'aide.
La est le probleme.
Pour reprendre les mots du docteur Gregg MacLean, president de la Saint John Medical Society:
Le probleme est le sous-financement.
Feu l'honorable juge Mark McGuigan, c.p., c.r.
Honorables senateurs, l'honorable juge Mark McGuigan nous a quittes, il y a quelques semaines.
Il naquit a l'Ile-du-Prince-Edouard en 1931.
Il a fait ses etudes de droit a Osgoode Hall et a l'Universite Colombia.
Professeur de droit, doyen, il a excelle dans sa carriere universitaire.
Apres une carriere universitaire, suivie d'une carriere politique, il a entrepris une carriere judiciaire.
En 1984, on l'a nomme a la Cour d'appel federale.
C'etait un juge eminent et on se rappellera de ses decisions.
La qualite du debat au Senat
Je ne crois pas avoir deja entendu un debat aussi bon que celui d'hier.
Ce qui s'est passe hier etait peut-etre un moment tres important pour nous.
Nous nous sommes analyses, ainsi que nos pouvoirs.
Le debat que nous avons eu hier a ete utile et benefique.
Je felicite le comite, qui a presente son rapport, et aussi le senateur Ghitter.
Son Honneur le President :
Ils sont inscrits au Programme d'etudes canadiennes.
Regie interne, budgets et administration
Presentation du neuvieme rapport du comite
Le jeudi 12 fevrier 1998
Le plan de depense pour 1998-1999 ainsi qu'un resume accompagnent ce rapport.
Son Honneur le President :
Honorables senateurs, quand etudierons-nous le rapport?
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Son Honneur le President :
Honorables senateurs, la permission est-elle accordee?
L'honorable Noel A. Kinsella (chef adjoint suppleant de l'opposition) :
Honorables senateurs, quand etudierons-nous cette question?
Toutefois, vous vous appretez a proposer une nouvelle motion.
L'honorable John Lynch-Staunton (chef de l'opposition) :
Nous n'avons pas de copies de la motion.
Son Honneur le President :
Pourrions-nous commencer par determiner si la permission est accordee?
Son Honneur le President :
Oui, plus tard aujourd'hui.
Son Honneur le President :
La permission a ete accordee.
Nous serons alors saisis de la motion selon les regles.
L'honorable Eymard G. Corbin :
Une copie de la motion pourrait etre remise a tous les senateurs.
Son Honneur le President :
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Son Honneur le President :
Honorables senateurs, la permission est-elle accordee?
Conference parlementaire des Ameriques
Depot du rapport de la delegation du Parlement du Canada
Son Honneur le President :
Droits de l'enfant non encore ne
La creation du comite parlementaire mixte-Avis de motion
Honorables senateurs, je donne avis que, le 25 fevrier 1998, je proposerai:
La politique du Canada relative a la crise actuelle-Avis d'interpellation
L'honorable Jerahmiel S. Grafstein :
Le manque d'accessibilite pour les personnes handicapees-Avis d'interpellation
L'honorable Brenda M. Robertson :
La Commission canadienne du ble-Le montant total des impayes-La position du gouvernement
L'honorable Leonard J. Gustafson :
On a mentionne les chiffres de 6 milliards, 8 milliards et meme 20 milliards.
Est-ce que ce sont les agriculteurs, le gouvernement ou la Commission?
Si c'est la Commission canadienne du ble alors, indirectement, ce sont les agriculteurs.
Est-ce que l'on demande un interet sur les montants en souffrance?
L'honorable Eric Arthur Berntson :
Arrondissez au milliard le plus proche.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Je reviendrai des que possible avec une reponse complete a cette question.
L'honorable Duncan J. Jessiman :
Honorables senateurs, j'ai une question a l'intention du leader du gouvernement au Senat.
L'honorable B. Alasdair Graham (leader du gouvernement) :
L'honorable Fernand Robichaud (Saint-Louis-de-Kent) :
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
Les pecheurs cotiers du Nouveau-Brunswick sont inquiets et vivent dans l'incertitude.
L'honorable B. Alasdair Graham (leader du gouvernement) :
C'est une revendication que les pecheurs cotiers font depuis quelques annees.
L'honorable J. Michael Forrestall :
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Cette equipe existe depuis quelque temps.
Voulez-vous une liste des precedents?
Honorables senateurs, j'ai fourni une telle liste il y a quelques mois.
Le leader du gouvernement n'avait pas juge bon d'agir a ce moment-la.
La situation a maintenant change.
Une occasion se presente maintenant.
Le leader sait que le gouvernement peut attribuer ce contrat.
Des elections viennent d'etre declenchees.
Faisons quelque chose pour les gens de la Nouvelle-Ecosse.
L'honorable Noel A. Kinsella (chef adjoint suppleant de l'opposition) :
Honorables senateurs, j'ai une question a poser au leader du gouvernement au Senat.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Au lieu de cela, les entreprises les detruisent ou les brulent.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Honorables senateurs, j'aurais une question complementaire a poser.
Ce qui me preoccupe, c'est la baisse de la population rurale.
Les agriculteurs estiment que c'est un probleme grave.
Je vous serais tres reconnaissante de transmettre cette information au ministre.
Je presenterai une reponse plus complete a l'honorable senateur le plus tot possible.
Honorables senateurs, j'ai une question pour le leader du gouvernement.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Honorables senateurs, je suis certain que cette mesure est envisagee.
Dans ce cas, je vais fournir quelques bonnes idees au gouvernement.
L'honorable Erminie J. Cohen :
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Honorables senateurs, nous traversons une periode de compressions.
Nous essayons d'equilibrer le budget.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Honorables senateurs, mon collegue m'apprend une nouvelle.
Honorables senateurs, j'espere que les leaders militaires savent ce qu'ils font.
Nos forces armees ont leve l'ancre et sont en route pour le golfe Persique.
C'est ce qui m'inquiete.
Le senateur souleve un point valable.
Il semblerait, d'apres ces informations, que de nombreuses vies sont en jeu.
Je suis certain que cette question preoccupe tous les senateurs.
Etude du rapport final du comite senatorial special-Suite du debat
L'honorable Rose-Marie Losier-Cool :
Toutefois, le rapport nous permet de constater qu'il reste beaucoup a faire.
L'enseignement postsecondaire peut agrandir a l'infini les horizons d'une personne.
Les individus enrichis apporteront mille et un avantages au reste de la population.
Ces sommes sont-elles excessives pour un etudiant provenant d'une famille canadienne moyenne?
Ce ne sera pas tache facile.
Nos universites doivent etre des conservatoires de connaissances.
Et je cite directement du rapport:
Le rapport nous dit, et je cite:
D'ailleurs, a ce sujet, je cite encore le rapport:
L'honorable Noel A. Kinsella (chef adjoint suppleant de l'opposition) :
Honorables senateurs, je propose l'ajournement du debat au nom du senateur Andreychuk.
Son Honneur le President :
(Sur la motion du senateur Kinsella, au nom du senateur Forest, le debat est ajourne.)
Projet de loi modificatif-Deuxieme lecture-Ajournement du debat
Ils ne seraient pas armes.
Ils auraient l'appui de la GRC, au besoin.
C'est une question delicate.
(Sur la motion du senateur Kinsella, le debat est ajourne.)
L'honorable Stanley Haidasz , conformement a l'avis du10 fevrier 1998, propose:
Par consequent, honorables senateurs, je vous engage a appuyer cette motion.
Son Honneur le President :
Vous plait-il, honorables senateurs, d'adopter la motion?
Que le comite presente son rapport final au plus tardle 31 mars 1998.
Son Honneur le President :
Je crois comprendre qu'il y a eu entente sur quelques modifications mineures.
Nous devrions peut-etre clarifier la situation.
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Son Honneur le President :
Tout d'abord, les senateurs approuvent-ils les revisions du texte?
L'honorable Eymard G. Corbin :
Honorables senateurs, a mon sens, le premier paragraphe du texte francais est incorrect.
Je le lis pour illustrer mon intervention:
A la deuxieme ligne, il me semble, on devrait plutot lire:
Son Honneur le President :
L'honorable Noel Kinsella (chef adjoint suppleant de l'opposition :
Quand on dit en francais:
[...] tienne compte des debat du Senat du 11 fevrier [...]
C'est relatif au rapport provisoire, le debat porte sur le rapport.
L'honorable John Lynch-Staunton (chef de l'opposition) :
Le rapport portait sur le rapport.
Le mot relatif englobe tout, les debats relatifs au rapport.
Nous n'avons que deux semaines.
Son Honneur le President :
J'ai plusieurs propositions.
Son Honneur le President :
On va eliminer le mot dans et on va ajouter relatif a ce rapport.
Son Honneur le President :
Est-ce que cela reglerait la question?
Nous devons proceder avec la motion.
Desirez-vous que je lise la version francaise?
Pourquoi employer ici le mot determine?
Il n'est pas question de determiner quoi que ce soit.
Je suis d'accord avec le senateur Lynch-Staunton.
Son Honneur le President :
En version francaise, je me demande si on doit ajouter obtenir l'avis additionnel.
Je ne le sais pas.
Son Honneur le President :
Je vais prendre la derniere proposition d'abord.
Est-ce que vous etes d'accord, honorables senateurs?
Est-ce d'accord, honorables senateurs?
Son Honneur le President :
C'est donc le texte definitif.
Vous plait-il, honorables senateurs, d'adopter la motion?
Son Honneur le President :
Son Honneur le President :
Honorables senateurs, j'avais deja mis la motion aux voix.
Sommes-nous d'accord pour revenir en arriere?
Son Honneur le President :
Son Honneur le President :
La motion a ete lue.
Vous plait-il, honorables senateurs, d'adopter la motion?
(Le Senat s'ajourne au mardi 17 fevrier 1998, a 14 heures.)