text:
      BLOCK DATA
      INTEGER NSUBS
      PARAMETER (NSUBS = 8)
      CHARACTER*7        SNAMES( NSUBS )
      COMMON             /SNAMEC/SNAMES
      DATA               SNAMES/'PSSWAP ', 'PSSCAL ', 'PSCOPY ',
     $                   'PSAXPY ', 'PSDOT  ', 'PSNRM2 ',
     $                   'PSASUM ', 'PSAMAX '/
      END BLOCK DATA

      PROGRAM PSBLA1TIM
*
*  -- PBLAS timing driver (version 2.0.2) --
*     Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
*     May 1 2012
*
*  Purpose
*  =======
*
*  PSBLA1TIM  is the main timing program for the Level 1 PBLAS routines.
*
*  The program must be driven by a short data file.  An  annotated exam-
*  ple of a data file can be obtained by deleting the first 3 characters
*  from the following 40 lines:
*  'Level 1 PBLAS, Timing input file'
*  'Intel iPSC/860 hypercube, gamma model.'
*  'PSBLAS1TIM.SUMM'          output file name (if any)
*  6       device out
*  1       number of process grids (ordered pairs of P & Q)
*  2 2 1 4 2 3 8        values of P
*  2 2 4 1 3 2 1        values of Q
*  1.0E0                value of ALPHA
*  2                    number of tests problems
*  3  4                 values of N
*  6 10                 values of M_X
*  6 10                 values of N_X
*  2  5                 values of IMB_X
*  2  5                 values of INB_X
*  2  5                 values of MB_X
*  2  5                 values of NB_X
*  0  1                 values of RSRC_X
*  0  0                 values of CSRC_X
*  1  1                 values of IX
*  1  1                 values of JX
*  1  1                 values of INCX
*  6 10                 values of M_Y
*  6 10                 values of N_Y
*  2  5                 values of IMB_Y
*  2  5                 values of INB_Y
*  2  5                 values of MB_Y
*  2  5                 values of NB_Y
*  0  1                 values of RSRC_Y
*  0  0                 values of CSRC_Y
*  1  1                 values of IY
*  1  1                 values of JY
*  6  1                 values of INCY
*  PSSWAP  T            put F for no test in the same column
*  PSSCAL  T            put F for no test in the same column
*  PSCOPY  T            put F for no test in the same column
*  PSAXPY  T            put F for no test in the same column
*  PSDOT   T            put F for no test in the same column
*  PSNRM2  T            put F for no test in the same column
*  PSASUM  T            put F for no test in the same column
*  PSAMAX  T            put F for no test in the same column
*
*  Internal Parameters
*  ===================
*
*  TOTMEM  INTEGER
*          TOTMEM  is  a machine-specific parameter indicating the maxi-
*          mum  amount  of  available  memory per  process in bytes. The
*          user  should  customize TOTMEM to his  platform.  Remember to
*          leave  room  in  memory  for the  operating system, the BLACS
*          buffer, etc.  For  example,  on  a system with 8 MB of memory
*          per process (e.g., one processor  on an Intel iPSC/860),  the
*          parameters we use are TOTMEM=6200000  (leaving 1.8 MB for OS,
*          code, BLACS buffer, etc).  However,  for PVM,  we usually set
*          TOTMEM = 2000000.  Some experimenting  with the maximum value
*          of TOTMEM may be required. By default, TOTMEM is 2000000.
*
*  REALSZ  INTEGER
*          REALSZ  indicates  the  length in bytes on the given platform
*          for  a  single  precision  real. By default, REALSZ is set to
*          four.
*
*  MEM     REAL array
*          MEM is an array of dimension TOTMEM / REALSZ.
*          All arrays used by SCALAPACK routines are allocated from this
*          array MEM and referenced by pointers. The  integer  IPA,  for
*          example, is a pointer to the starting element of MEM for  the
*          matrix A.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            MAXTESTS, MAXGRIDS, REALSZ, TOTMEM, MEMSIZ,
     $                   NSUBS
      PARAMETER          ( MAXTESTS = 20, MAXGRIDS = 20, REALSZ = 4,
     $                   TOTMEM = 2000000, NSUBS = 8,
     $                   MEMSIZ = TOTMEM / REALSZ )
      INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
     $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
     $                   RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
     $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
     $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
     $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
*     ..
*     .. Local Scalars ..
      INTEGER            CSRCX, CSRCY, I, IAM, ICTXT, IMBX, IMBY, IMIDX,
     $                   IMIDY, INBX, INBY, INCX, INCY, IPOSTX, IPOSTY,
     $                   IPREX, IPREY, IPX, IPY, IX, IXSEED, IY, IYSEED,
     $                   J, JX, JY, K, MBX, MBY, MEMREQD, MPX, MPY, MX,
     $                   MY, MYCOL, MYROW, N, NBX, NBY, NGRIDS, NOUT,
     $                   NPCOL, NPROCS, NPROW, NQX, NQY, NTESTS, NX, NY,
     $                   PISCLR, RSRCX, RSRCY
      REAL               ALPHA, PSCLR, PUSCLR
      DOUBLE PRECISION   ADDS, CFLOPS, MULTS, NOPS, WFLOPS
*     ..
*     .. Local Arrays ..
      CHARACTER*80       OUTFILE
      LOGICAL            LTEST( NSUBS ), YCHECK( NSUBS )
      INTEGER            CSCXVAL( MAXTESTS ), CSCYVAL( MAXTESTS ),
     $                   DESCX( DLEN_ ), DESCY( DLEN_ ), IERR( 2 ),
     $                   IMBXVAL( MAXTESTS ), IMBYVAL( MAXTESTS ),
     $                   INBXVAL( MAXTESTS ), INBYVAL( MAXTESTS ),
     $                   INCXVAL( MAXTESTS ), INCYVAL( MAXTESTS ),
     $                   IXVAL( MAXTESTS ), IYVAL( MAXTESTS ),
     $                   JXVAL( MAXTESTS ), JYVAL( MAXTESTS ),
     $                   MBXVAL( MAXTESTS ), MBYVAL( MAXTESTS ),
     $                   MXVAL( MAXTESTS ), MYVAL( MAXTESTS ),
     $                   NBXVAL( MAXTESTS ), NBYVAL( MAXTESTS ),
     $                   NVAL( MAXTESTS ), NXVAL( MAXTESTS ),
     $                   NYVAL( MAXTESTS ), PVAL( MAXTESTS ),
     $                   QVAL( MAXTESTS ), RSCXVAL( MAXTESTS ),
     $                   RSCYVAL( MAXTESTS )
      REAL               MEM( MEMSIZ )
      DOUBLE PRECISION   CTIME( 1 ), WTIME( 1 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_BARRIER, BLACS_EXIT, BLACS_GET,
     $                   BLACS_GRIDEXIT, BLACS_GRIDINFO, BLACS_GRIDINIT,
     $                   BLACS_PINFO, IGSUM2D, PB_BOOT, PB_COMBINE,
     $                   PB_TIMER, PSAMAX, PSASUM, PSAXPY,
     $                   PSBLA1TIMINFO, PSCOPY, PSDOT, PSLAGEN, PSNRM2,
     $                   PSSCAL, PSSWAP, PVDESCCHK, PVDIMCHK
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE
*     ..
*     .. Common Blocks ..
      CHARACTER*7        SNAMES( NSUBS )
      LOGICAL            ABRTFLG
      INTEGER            INFO, NBLOG
      COMMON             /SNAMEC/SNAMES
      COMMON             /INFOC/INFO, NBLOG
      COMMON             /PBERRORC/NOUT, ABRTFLG
*     ..
*     .. Data Statements ..
      DATA               YCHECK/.TRUE., .FALSE., .TRUE., .TRUE., .TRUE.,
     $                   .FALSE., .FALSE., .FALSE./
*     ..
*     .. Executable Statements ..
*
*     Initialization
*
*     Set flag so that the PBLAS error handler won't abort on errors, so
*     that the tester will detect unsupported operations.
*
      ABRTFLG = .FALSE.
*
*     Seeds for random matrix generations.
*
      IXSEED = 100
      IYSEED = 200
*
*     Get starting information
*
      CALL BLACS_PINFO( IAM, NPROCS )
      CALL PSBLA1TIMINFO( OUTFILE, NOUT, NTESTS, NVAL, MXVAL, NXVAL,
     $                    IMBXVAL, MBXVAL, INBXVAL, NBXVAL, RSCXVAL,
     $                    CSCXVAL, IXVAL, JXVAL, INCXVAL, MYVAL,
     $                    NYVAL, IMBYVAL, MBYVAL, INBYVAL, NBYVAL,
     $                    RSCYVAL, CSCYVAL, IYVAL, JYVAL, INCYVAL,
     $                    MAXTESTS, NGRIDS, PVAL, MAXGRIDS, QVAL,
     $                    MAXGRIDS, LTEST, IAM, NPROCS, ALPHA, MEM )
*
      IF( IAM.EQ.0 )
     $   WRITE( NOUT, FMT = 9986 )
*
*     Loop over different process grids
*
      DO 60 I = 1, NGRIDS
*
         NPROW = PVAL( I )
         NPCOL = QVAL( I )
*
*        Make sure grid information is correct
*
         IERR( 1 ) = 0
         IF( NPROW.LT.1 ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = 9999 ) 'GRID SIZE', 'NPROW', NPROW
            IERR( 1 ) = 1
         ELSE IF( NPCOL.LT.1 ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = 9999 ) 'GRID SIZE', 'NPCOL', NPCOL
            IERR( 1 ) = 1
         ELSE IF( NPROW*NPCOL.GT.NPROCS ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = 9998 ) NPROW*NPCOL, NPROCS
            IERR( 1 ) = 1
         END IF
*
         IF( IERR( 1 ).GT.0 ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = 9997 ) 'GRID'
            GO TO 60
         END IF
*
*        Define process grid
*
         CALL BLACS_GET( -1, 0, ICTXT )
         CALL BLACS_GRIDINIT( ICTXT, 'Row-major', NPROW, NPCOL )
         CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
*        Go to bottom of process grid loop if this case doesn't use my
*        process
*
         IF( MYROW.GE.NPROW .OR. MYCOL.GE.NPCOL )
     $      GO TO 60
*
*        Loop over number of tests
*
         DO 50 J = 1, NTESTS
*
*           Get the test parameters
*
            N     = NVAL( J )
            MX    = MXVAL( J )
            NX    = NXVAL( J )
            IMBX  = IMBXVAL( J )
            MBX   = MBXVAL( J )
            INBX  = INBXVAL( J )
            NBX   = NBXVAL( J )
            RSRCX = RSCXVAL( J )
            CSRCX = CSCXVAL( J )
            IX    = IXVAL( J )
            JX    = JXVAL( J )
            INCX  = INCXVAL( J )
            MY    = MYVAL( J )
            NY    = NYVAL( J )
            IMBY  = IMBYVAL( J )
            MBY   = MBYVAL( J )
            INBY  = INBYVAL( J )
            NBY   = NBYVAL( J )
            RSRCY = RSCYVAL( J )
            CSRCY = CSCYVAL( J )
            IY    = IYVAL( J )
            JY    = JYVAL( J )
            INCY  = INCYVAL( J )
*
            IF( IAM.EQ.0 ) THEN
               WRITE( NOUT, FMT = * )
               WRITE( NOUT, FMT = 9996 ) J, NPROW, NPCOL
               WRITE( NOUT, FMT = * )
*
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9994 )
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9993 ) N, IX, JX, MX, NX, IMBX, INBX,
     $                                   MBX, NBX, RSRCX, CSRCX, INCX
*
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9992 )
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9993 ) N, IY, JY, MY, NY, IMBY, INBY,
     $                                   MBY, NBY, RSRCY, CSRCY, INCY
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = 9983 )
            END IF
*
*           Check the validity of the input and initialize DESC_
*
            CALL PVDESCCHK( ICTXT, NOUT, 'X', DESCX,
     $                      BLOCK_CYCLIC_2D_INB, MX, NX, IMBX, INBX,
     $                      MBX, NBX, RSRCX, CSRCX, INCX, MPX, NQX,
     $                      IPREX, IMIDX, IPOSTX, 0, 0, IERR( 1 ) )
            CALL PVDESCCHK( ICTXT, NOUT, 'Y', DESCY,
     $                      BLOCK_CYCLIC_2D_INB, MY, NY, IMBY, INBY,
     $                      MBY, NBY, RSRCY, CSRCY, INCY, MPY, NQY,
     $                      IPREY, IMIDY, IPOSTY, 0, 0, IERR( 2 ) )
*
            IF( IERR( 1 ).GT.0 .OR. IERR( 2 ).GT.0 )
     $         GO TO 40
*
*           Assign pointers into MEM for matrices corresponding to
*           vectors X and Y. Ex: IPX starts at position MEM( 1 ).
*
            IPX = 1
            IPY = IPX + DESCX( LLD_ ) * NQX
*
*           Check if sufficient memory.
*
            MEMREQD = IPY + DESCY( LLD_ ) * NQY - 1
            IERR( 1 ) = 0
            IF( MEMREQD.GT.MEMSIZ ) THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9990 ) MEMREQD*REALSZ
               IERR( 1 ) = 1
            END IF
*
*           Check all processes for an error
*
            CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 )
*
            IF( IERR( 1 ).GT.0 ) THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9991 )
               GO TO 40
            END IF
*
*           Loop over all PBLAS 1 routines
*
            DO 30 K = 1, NSUBS
*
*              Continue only if this sub has to be tested.
*
               IF( .NOT.LTEST( K ) )
     $            GO TO 30
*
*              Check the validity of the operand sizes
*
               CALL PVDIMCHK( ICTXT, NOUT, N, 'X', IX, JX, DESCX, INCX,
     $                        IERR( 1 ) )
               CALL PVDIMCHK( ICTXT, NOUT, N, 'Y', IY, JY, DESCY, INCY,
     $                        IERR( 2 ) )
*
               IF( IERR( 1 ).NE.0 .OR. IERR( 2 ).NE.0 )
     $            GO TO 30
*
*              Generate distributed matrices X and Y
*
               CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MX, NX, 1,
     $                       1, DESCX, IXSEED, MEM( IPX ),
     $                       DESCX( LLD_ ) )
               IF( YCHECK( K ) )
     $            CALL PSLAGEN( .FALSE., 'None', 'No diag', 0, MY, NY,
     $                          1, 1, DESCY, IYSEED, MEM( IPY ),
     $                          DESCY( LLD_ ) )
*
               INFO = 0
               CALL PB_BOOT()
               CALL BLACS_BARRIER( ICTXT, 'All' )
*
*              Call the PBLAS routine
*
               IF( K.EQ.1 ) THEN
*
*                 Test PSSWAP
*
                  ADDS  = 0.0D+0
                  MULTS = 0.0D+0
                  CALL PB_TIMER( 1 )
                  CALL PSSWAP( N, MEM( IPX ), IX, JX, DESCX, INCX,
     $                         MEM( IPY ), IY, JY, DESCY, INCY )
                  CALL PB_TIMER( 1 )
*
               ELSE IF( K.EQ.2 ) THEN
*
*                 Test PSSCAL
*
                  ADDS  = 0.0D+0
                  MULTS = DBLE( N )
                  CALL PB_TIMER( 1 )
                  CALL PSSCAL( N, ALPHA, MEM( IPX ), IX, JX, DESCX,
     $                         INCX )
                  CALL PB_TIMER( 1 )
*
               ELSE IF( K.EQ.3 ) THEN
*
*                 Test PSCOPY
*
                  ADDS  = 0.0D+0
                  MULTS = 0.0D+0
                  CALL PB_TIMER( 1 )
                  CALL PSCOPY( N, MEM( IPX ), IX, JX, DESCX, INCX,
     $                         MEM( IPY ), IY, JY, DESCY, INCY )
                  CALL PB_TIMER( 1 )
*
               ELSE IF( K.EQ.4 ) THEN
*
*                 Test PSAXPY
*
                  ADDS  = DBLE( N )
                  MULTS = DBLE( N )
                  CALL PB_TIMER( 1 )
                  CALL PSAXPY( N, ALPHA, MEM( IPX ), IX, JX, DESCX,
     $                         INCX, MEM( IPY ), IY, JY, DESCY, INCY )
                  CALL PB_TIMER( 1 )
*
               ELSE IF( K.EQ.5 ) THEN
*
*                 Test PSDOT
*
                  ADDS = DBLE( N-1 )
                  MULTS = DBLE( N )
                  CALL PB_TIMER( 1 )
                  CALL PSDOT( N, PSCLR, MEM( IPX ), IX, JX, DESCX, INCX,
     $                        MEM( IPY ), IY, JY, DESCY, INCY )
                  CALL PB_TIMER( 1 )
*
               ELSE IF( K.EQ.6 ) THEN
*
*                 Test PSNRM2
*
                  ADDS  = DBLE( N-1 )
                  MULTS = DBLE( N )
                  CALL PB_TIMER( 1 )
                  CALL PSNRM2( N, PUSCLR, MEM( IPX ), IX, JX, DESCX,
     $                         INCX )
                  CALL PB_TIMER( 1 )
*
               ELSE IF( K.EQ.7 ) THEN
*
*                 Test PSASUM
*
                  ADDS  = DBLE( N - 1 )
                  MULTS = 0.0D+0
                  CALL PB_TIMER( 1 )
                  CALL PSASUM( N, PUSCLR, MEM( IPX ), IX, JX, DESCX,
     $                         INCX )
                  CALL PB_TIMER( 1 )
*
               ELSE IF( K.EQ.8 ) THEN
*
                  ADDS  = 0.0D+0
                  MULTS = 0.0D+0
                  CALL PB_TIMER( 1 )
                  CALL PSAMAX( N, PSCLR, PISCLR, MEM( IPX ), IX, JX,
     $                         DESCX, INCX )
                  CALL PB_TIMER( 1 )
*
               END IF
*
*              Check if the operation has been performed.
*
               IF( INFO.NE.0 ) THEN
                  IF( IAM.EQ.0 )
     $               WRITE( NOUT, FMT = 9985 ) INFO
                  GO TO 30
               END IF
*
               CALL PB_COMBINE( ICTXT, 'All', '>', 'W', 1, 1, WTIME )
               CALL PB_COMBINE( ICTXT, 'All', '>', 'C', 1, 1, CTIME )
*
*              Only node 0 prints timing test result
*
               IF( IAM.EQ.0 ) THEN
*
*                 Calculate total flops
*
                  NOPS = ADDS + MULTS
*
*                 Print WALL time if machine supports it
*
                  IF( WTIME( 1 ).GT.0.0D+0 ) THEN
                     WFLOPS = NOPS / ( WTIME( 1 ) * 1.0D+6 )
                  ELSE
                     WFLOPS = 0.0D+0
                  END IF
*
*                 Print CPU time if machine supports it
*
                  IF( CTIME( 1 ).GT.0.0D+0 ) THEN
                     CFLOPS = NOPS / ( CTIME( 1 ) * 1.0D+6 )
                  ELSE
                     CFLOPS = 0.0D+0
                  END IF
*
                  WRITE( NOUT, FMT = 9984 ) SNAMES( K ), WTIME( 1 ),
     $                                      WFLOPS, CTIME( 1 ), CFLOPS
*
               END IF
*
   30       CONTINUE
*
   40       IF( IAM.EQ.0 ) THEN
               WRITE( NOUT, FMT = 9995 )
               WRITE( NOUT, FMT = * )
               WRITE( NOUT, FMT = 9988 ) J
            END IF
*
   50   CONTINUE
*
        IF( IAM.EQ.0 ) THEN
           WRITE( NOUT, FMT = * )
           WRITE( NOUT, FMT = 9987 )
           WRITE( NOUT, FMT = * )
        END IF
*
        CALL BLACS_GRIDEXIT( ICTXT )
*
   60 CONTINUE
*
      CALL BLACS_EXIT( 0 )
*
 9999 FORMAT( 'ILLEGAL ', A, ': ', A, ' = ', I10,
     $        ' should be at least 1' )
 9998 FORMAT( 'ILLEGAL GRID: NPROW*NPCOL = ', I4,
     $        '. It can be at most', I4 )
 9997 FORMAT( 'Bad ', A, ' parameters: going on to next test case.' )
 9996 FORMAT( 2X, 'Test number ', I2 , ' started on a ', I4, ' x ',
     $        I4, ' process grid.' )
 9995 FORMAT( 2X, '---------------------------------------------------',
     $        '--------------------------' )
 9994 FORMAT( 2X, '     N     IX     JX     MX     NX  IMBX  INBX',
     $        '   MBX   NBX RSRCX CSRCX   INCX' )
 9993 FORMAT( 2X,I6,1X,I6,1X,I6,1X,I6,1X,I6,1X,I5,1X,I5,1X,I5,1X,I5,1X,
     $        I5,1X,I5,1X,I6 )
 9992 FORMAT( 2X, '     N     IY     JY     MY     NY  IMBY  INBY',
     $        '   MBY   NBY RSRCY CSRCY   INCY' )
 9991 FORMAT( 'Not enough memory for this test: going on to',
     $        ' next test case.' )
 9990 FORMAT( 'Not enough memory. Need: ', I12 )
 9988 FORMAT( 2X, 'Test number ', I2, ' completed.' )
 9987 FORMAT( 2X, 'End of Tests.' )
 9986 FORMAT( 2X, 'Tests started.' )
 9985 FORMAT( 2X, '   ***** Operation not supported, error code: ',
     $        I5, ' *****' )
 9984 FORMAT( 2X, '|  ', A, 2X, F13.3, 2X, F13.3, 2X, F13.3, 2X, F13.3 )
 9983 FORMAT( 2X, '            WALL time (s)    WALL Mflops ',
     $        '  CPU time (s)     CPU Mflops' )
*
      STOP
*
*     End of PSBLA1TIM
*
      END
      SUBROUTINE PSBLA1TIMINFO( SUMMRY, NOUT, NMAT, NVAL, MXVAL, NXVAL,
     $                          IMBXVAL, MBXVAL, INBXVAL, NBXVAL,
     $                          RSCXVAL, CSCXVAL, IXVAL, JXVAL,
     $                          INCXVAL, MYVAL, NYVAL, IMBYVAL, MBYVAL,
     $                          INBYVAL, NBYVAL, RSCYVAL, CSCYVAL,
     $                          IYVAL, JYVAL, INCYVAL, LDVAL, NGRIDS,
     $                          PVAL, LDPVAL, QVAL, LDQVAL, LTEST, IAM,
     $                          NPROCS, ALPHA, WORK )
*
*  -- PBLAS test routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      INTEGER            IAM, LDPVAL, LDQVAL, LDVAL, NGRIDS, NMAT, NOUT,
     $                   NPROCS
      REAL               ALPHA
*     ..
*     .. Array Arguments ..
      CHARACTER*( * )    SUMMRY
      LOGICAL            LTEST( * )
      INTEGER            CSCXVAL( LDVAL ), CSCYVAL( LDVAL ),
     $                   IMBXVAL( LDVAL ), IMBYVAL( LDVAL ),
     $                   INBXVAL( LDVAL ), INBYVAL( LDVAL ),
     $                   INCXVAL( LDVAL ), INCYVAL( LDVAL ),
     $                   IXVAL( LDVAL ), IYVAL( LDVAL ), JXVAL( LDVAL ),
     $                   JYVAL( LDVAL ), MBXVAL( LDVAL ),
     $                   MBYVAL( LDVAL ), MXVAL( LDVAL ),
     $                   MYVAL( LDVAL ), NBXVAL( LDVAL ),
     $                   NBYVAL( LDVAL ), NVAL( LDVAL ), NXVAL( LDVAL ),
     $                   NYVAL( LDVAL ), PVAL( LDPVAL ), QVAL( LDQVAL ),
     $                   RSCXVAL( LDVAL ), RSCYVAL( LDVAL ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  PSBLA1TIMINFO  get  the needed startup information for timing various
*  Level 1 PBLAS routines, and transmits it to all processes.
*
*  Notes
*  =====
*
*  For packing the information we assumed that the length in bytes of an
*  integer is equal to the length in bytes of a real single precision.
*
*  Arguments
*  =========
*
*  SUMMRY  (global output) CHARACTER*(*)
*          On  exit,  SUMMRY  is  the  name of output (summary) file (if
*          any). SUMMRY is only defined for process 0.
*
*  NOUT    (global output) INTEGER
*          On exit, NOUT  specifies the unit number for the output file.
*          When NOUT is 6, output to screen,  when  NOUT is 0, output to
*          stderr. NOUT is only defined for process 0.
*
*  NMAT    (global output) INTEGER
*          On exit,  NMAT  specifies the number of different test cases.
*
*  NVAL    (global output) INTEGER array
*          On entry, NVAL is an array of dimension LDVAL.  On exit, this
*          array contains the values of N to run the code with.
*
*  MXVAL   (global output) INTEGER array
*          On entry, MXVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCX( M_ )  to run the code
*          with.
*
*  NXVAL   (global output) INTEGER array
*          On entry, NXVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCX( N_ )  to run the code
*          with.
*
*  IMBXVAL (global output) INTEGER array
*          On entry,  IMBXVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCX( IMB_ ) to run the
*          code with.
*
*  MBXVAL  (global output) INTEGER array
*          On entry,  MBXVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCX( MB_ ) to  run the
*          code with.
*
*  INBXVAL (global output) INTEGER array
*          On entry,  INBXVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCX( INB_ ) to run the
*          code with.
*
*  NBXVAL  (global output) INTEGER array
*          On entry,  NBXVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCX( NB_ ) to  run the
*          code with.
*
*  RSCXVAL (global output) INTEGER array
*          On entry, RSCXVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCX( RSRC_ ) to run the
*          code with.
*
*  CSCXVAL (global output) INTEGER array
*          On entry, CSCXVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCX( CSRC_ ) to run the
*          code with.
*
*  IXVAL   (global output) INTEGER array
*          On entry, IXVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of IX to run the code with.
*
*  JXVAL   (global output) INTEGER array
*          On entry, JXVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of JX to run the code with.
*
*  INCXVAL (global output) INTEGER array
*          On entry,  INCXVAL  is  an array of dimension LDVAL. On exit,
*          this array  contains the values of INCX to run the code with.
*
*  MYVAL   (global output) INTEGER array
*          On entry, MYVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCY( M_ )  to run the code
*          with.
*
*  NYVAL   (global output) INTEGER array
*          On entry, NYVAL is an array of dimension LDVAL. On exit, this
*          array  contains  the values  of  DESCY( N_ )  to run the code
*          with.
*
*  IMBYVAL (global output) INTEGER array
*          On entry,  IMBYVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCY( IMB_ ) to run the
*          code with.
*
*  MBYVAL  (global output) INTEGER array
*          On entry,  MBYVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCY( MB_ ) to  run the
*          code with.
*
*  INBYVAL (global output) INTEGER array
*          On entry,  INBYVAL  is an array of  dimension LDVAL. On exit,
*          this  array  contains  the values of DESCY( INB_ ) to run the
*          code with.
*
*  NBYVAL  (global output) INTEGER array
*          On entry,  NBYVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains  the values of DESCY( NB_ ) to  run the
*          code with.
*
*  RSCYVAL (global output) INTEGER array
*          On entry, RSCYVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCY( RSRC_ ) to run the
*          code with.
*
*  CSCYVAL (global output) INTEGER array
*          On entry, CSCYVAL  is an array of  dimension  LDVAL. On exit,
*          this  array  contains the values of DESCY( CSRC_ ) to run the
*          code with.
*
*  IYVAL   (global output) INTEGER array
*          On entry, IYVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of IY to run the code with.
*
*  JYVAL   (global output) INTEGER array
*          On entry, JYVAL is an array of dimension LDVAL. On exit, this
*          array  contains the values of JY to run the code with.
*
*  INCYVAL (global output) INTEGER array
*          On entry,  INCYVAL  is  an array of dimension LDVAL. On exit,
*          this array  contains the values of INCY to run the code with.
*
*  LDVAL   (global input) INTEGER
*          On entry, LDVAL specifies the maximum number of different va-
*          lues that can be used for  DESCX(:),  IX, JX, INCX, DESCY(:),
*          IY,  JY  and  INCY.  This  is also the maximum number of test
*          cases.
*
*  NGRIDS  (global output) INTEGER
*          On exit, NGRIDS specifies the number of different values that
*          can be used for P and Q.
*
*  PVAL    (global output) INTEGER array
*          On entry, PVAL is an array of dimension LDPVAL. On exit, this
*          array contains the values of P to run the code with.
*
*  LDPVAL  (global input) INTEGER
*          On entry,  LDPVAL  specifies  the maximum number of different
*          values that can be used for P.
*
*  QVAL    (global output) INTEGER array
*          On entry, QVAL is an array of dimension LDQVAL. On exit, this
*          array contains the values of Q to run the code with.
*
*  LDQVAL  (global input) INTEGER
*          On entry,  LDQVAL  specifies  the maximum number of different
*          values that can be used for Q.
*
*  LTEST   (global output) LOGICAL array
*          On entry,  LTEST  is an array of dimension at least eight. On
*          exit, if LTEST( i ) is .TRUE., the i-th Level 1 PBLAS routine
*          will be tested.  See  the  input file for the ordering of the
*          routines.
*
*  IAM     (local input) INTEGER
*          On entry,  IAM  specifies the number of the process executing
*          this routine.
*
*  NPROCS  (global input) INTEGER
*          On entry, NPROCS specifies the total number of processes.
*
*  ALPHA   (global output) REAL
*          On exit, ALPHA specifies the value of alpha to be used in all
*          the test cases.
*
*  WORK    (local workspace) INTEGER array
*          On   entry,   WORK   is   an  array  of  dimension  at  least
*          MAX( 2, 2*NGRIDS+23*NMAT+NSUBS ) with NSUBS = 8.  This  array
*          is  used  to  pack all output arrays in order to send info in
*          one message.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NIN, NSUBS
      PARAMETER          ( NIN = 11, NSUBS = 8 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LTESTT
      INTEGER            I, ICTXT, J
*     ..
*     .. Local Arrays ..
      CHARACTER*7        SNAMET
      CHARACTER*79       USRINFO
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_ABORT, BLACS_GET, BLACS_GRIDEXIT,
     $                   BLACS_GRIDINIT, BLACS_SETUP, ICOPY, IGEBR2D,
     $                   IGEBS2D, SGEBR2D, SGEBS2D
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Common Blocks ..
      CHARACTER*7        SNAMES( NSUBS )
      COMMON             /SNAMEC/SNAMES
*     ..
*     .. Executable Statements ..
*
*
*     Process 0 reads the input data, broadcasts to other processes and
*     writes needed information to NOUT
*
      IF( IAM.EQ.0 ) THEN
*
*        Open file and skip data file header
*
         OPEN( NIN, FILE='PSBLAS1TIM.dat', STATUS='OLD' )
         READ( NIN, FMT = * ) SUMMRY
         SUMMRY = ' '
*
*        Read in user-supplied info about machine type, compiler, etc.
*
         READ( NIN, FMT = 9999 ) USRINFO
*
*        Read name and unit number for summary output file
*
         READ( NIN, FMT = * ) SUMMRY
         READ( NIN, FMT = * ) NOUT
         IF( NOUT.NE.0 .AND. NOUT.NE.6 )
     $      OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
*
*        Read and check the parameter values for the tests.
*
*        Get number of grids
*
         READ( NIN, FMT = * ) NGRIDS
         IF( NGRIDS.LT.1 .OR. NGRIDS.GT.LDPVAL ) THEN
            WRITE( NOUT, FMT = 9998 ) 'Grids', LDPVAL
            GO TO 100
         ELSE IF( NGRIDS.GT.LDQVAL ) THEN
            WRITE( NOUT, FMT = 9998 ) 'Grids', LDQVAL
            GO TO 100
         END IF
*
*        Get values of P and Q
*
         READ( NIN, FMT = * ) ( PVAL( I ), I = 1, NGRIDS )
         READ( NIN, FMT = * ) ( QVAL( I ), I = 1, NGRIDS )
*
*        Read ALPHA
*
         READ( NIN, FMT = * ) ALPHA
*
*        Read number of tests.
*
         READ( NIN, FMT = * ) NMAT
         IF( NMAT.LT.1 .OR. NMAT.GT.LDVAL ) THEN
            WRITE( NOUT, FMT = 9998 ) 'Tests', LDVAL
            GO TO 100
         END IF
*
*        Read in input data into arrays.
*
         READ( NIN, FMT = * ) ( NVAL   ( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( MXVAL  ( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( NXVAL  ( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( IMBXVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( INBXVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( MBXVAL ( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( NBXVAL ( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( RSCXVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( CSCXVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( IXVAL  ( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( JXVAL  ( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( INCXVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( MYVAL  ( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( NYVAL  ( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( IMBYVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( INBYVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( MBYVAL ( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( NBYVAL ( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( RSCYVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( CSCYVAL( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( IYVAL  ( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( JYVAL  ( I ), I = 1, NMAT )
         READ( NIN, FMT = * ) ( INCYVAL( I ), I = 1, NMAT )
*
*        Read names of subroutines and flags which indicate
*        whether they are to be tested.
*
         DO 10 I = 1, NSUBS
            LTEST( I ) = .FALSE.
   10    CONTINUE
   20    CONTINUE
         READ( NIN, FMT = 9996, END = 50 ) SNAMET, LTESTT
         DO 30 I = 1, NSUBS
            IF( SNAMET.EQ.SNAMES( I ) )
     $         GO TO 40
   30    CONTINUE
*
         WRITE( NOUT, FMT = 9995 )SNAMET
         GO TO 100
*
   40    CONTINUE
         LTEST( I ) = LTESTT
         GO TO 20
*
   50    CONTINUE
*
*        Close input file
*
         CLOSE ( NIN )
*
*        For pvm only: if virtual machine not set up, allocate it and
*        spawn the correct number of processes.
*
         IF( NPROCS.LT.1 ) THEN
            NPROCS = 0
            DO 60 I = 1, NGRIDS
               NPROCS = MAX( NPROCS, PVAL( I )*QVAL( I ) )
   60       CONTINUE
            CALL BLACS_SETUP( IAM, NPROCS )
         END IF
*
*        Temporarily define blacs grid to include all processes so
*        information can be broadcast to all processes
*
         CALL BLACS_GET( -1, 0, ICTXT )
         CALL BLACS_GRIDINIT( ICTXT, 'Row-major', 1, NPROCS )
*
*        Pack information arrays and broadcast
*
         CALL SGEBS2D( ICTXT, 'All', ' ', 1, 1, ALPHA, 1 )
*
         WORK( 1 ) = NGRIDS
         WORK( 2 ) = NMAT
         CALL IGEBS2D( ICTXT, 'All', ' ', 2, 1, WORK, 2 )
*
         I = 1
         CALL ICOPY( NGRIDS, PVAL,     1, WORK( I ), 1 )
         I = I + NGRIDS
         CALL ICOPY( NGRIDS, QVAL,     1, WORK( I ), 1 )
         I = I + NGRIDS
         CALL ICOPY( NMAT,   NVAL,     1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   MXVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   NXVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   IMBXVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   INBXVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   MBXVAL,   1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   NBXVAL,   1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   RSCXVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   CSCXVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   IXVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   JXVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   INCXVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   MYVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   NYVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   IMBYVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   INBYVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   MBYVAL,   1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   NBYVAL,   1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   RSCYVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   CSCYVAL,  1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   IYVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   JYVAL,    1, WORK( I ), 1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   INCYVAL,  1, WORK( I ), 1 )
         I = I + NMAT
*
         DO 70 J = 1, NSUBS
            IF( LTEST( J ) ) THEN
               WORK( I ) = 1
            ELSE
               WORK( I ) = 0
            END IF
            I = I + 1
   70    CONTINUE
         I = I - 1
         CALL IGEBS2D( ICTXT, 'All', ' ', I, 1, WORK, I )
*
*        regurgitate input
*
         WRITE( NOUT, FMT = 9999 )
     $               'Level 1 PBLAS timing program.'
         WRITE( NOUT, FMT = 9999 ) USRINFO
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9999 )
     $               'Timing of the real single precision '//
     $               'Level 1 PBLAS'
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9999 )
     $               'The following parameter values will be used:'
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9993 ) NMAT
         WRITE( NOUT, FMT = 9992 ) NGRIDS
         WRITE( NOUT, FMT = 9990 )
     $               'P', ( PVAL(I), I = 1, MIN(NGRIDS, 5) )
         IF( NGRIDS.GT.5 )
     $      WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 6,
     $                                  MIN( 10, NGRIDS ) )
         IF( NGRIDS.GT.10 )
     $      WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 11,
     $                                  MIN( 15, NGRIDS ) )
         IF( NGRIDS.GT.15 )
     $      WRITE( NOUT, FMT = 9991 ) ( PVAL(I), I = 16, NGRIDS )
         WRITE( NOUT, FMT = 9990 )
     $               'Q', ( QVAL(I), I = 1, MIN(NGRIDS, 5) )
         IF( NGRIDS.GT.5 )
     $      WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 6,
     $                                  MIN( 10, NGRIDS ) )
         IF( NGRIDS.GT.10 )
     $      WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 11,
     $                                  MIN( 15, NGRIDS ) )
         IF( NGRIDS.GT.15 )
     $      WRITE( NOUT, FMT = 9991 ) ( QVAL(I), I = 16, NGRIDS )
         WRITE( NOUT, FMT = 9994 ) ALPHA
         IF( LTEST( 1 ) ) THEN
            WRITE( NOUT, FMT = 9989 ) SNAMES( 1 ), ' ... Yes'
         ELSE
            WRITE( NOUT, FMT = 9989 ) SNAMES( 1 ), ' ... No '
         END IF
         DO 80 I = 2, NSUBS
            IF( LTEST( I ) ) THEN
               WRITE( NOUT, FMT = 9988 ) SNAMES( I ), ' ... Yes'
            ELSE
               WRITE( NOUT, FMT = 9988 ) SNAMES( I ), ' ... No '
            END IF
   80    CONTINUE
         WRITE( NOUT, FMT = * )
*
      ELSE
*
*        If in pvm, must participate setting up virtual machine
*
         IF( NPROCS.LT.1 )
     $      CALL BLACS_SETUP( IAM, NPROCS )
*
*        Temporarily define blacs grid to include all processes so
*        information can be broadcast to all processes
*
         CALL BLACS_GET( -1, 0, ICTXT )
         CALL BLACS_GRIDINIT( ICTXT, 'Row-major', 1, NPROCS )
*
         CALL SGEBR2D( ICTXT, 'All', ' ', 1, 1, ALPHA, 1, 0, 0 )
*
         CALL IGEBR2D( ICTXT, 'All', ' ', 2, 1, WORK, 2, 0, 0 )
         NGRIDS = WORK( 1 )
         NMAT   = WORK( 2 )
*
         I = 2*NGRIDS + 23*NMAT + NSUBS
         CALL IGEBR2D( ICTXT, 'All', ' ', I, 1, WORK, I, 0, 0 )
*
         I = 1
         CALL ICOPY( NGRIDS, WORK( I ), 1, PVAL,     1 )
         I = I + NGRIDS
         CALL ICOPY( NGRIDS, WORK( I ), 1, QVAL,     1 )
         I = I + NGRIDS
         CALL ICOPY( NMAT,   WORK( I ), 1, NVAL,     1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, MXVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, NXVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, IMBXVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, INBXVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, MBXVAL,   1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, NBXVAL,   1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, RSCXVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, CSCXVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, IXVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, JXVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, INCXVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, MYVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, NYVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, IMBYVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, INBYVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, MBYVAL,   1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, NBYVAL,   1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, RSCYVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, CSCYVAL,  1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, IYVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, JYVAL,    1 )
         I = I + NMAT
         CALL ICOPY( NMAT,   WORK( I ), 1, INCYVAL,  1 )
         I = I + NMAT
*
         DO 90 J = 1, NSUBS
            IF( WORK( I ).EQ.1 ) THEN
               LTEST( J ) = .TRUE.
            ELSE
               LTEST( J ) = .FALSE.
            END IF
            I = I + 1
   90    CONTINUE
*
      END IF
*
      CALL BLACS_GRIDEXIT( ICTXT )
*
      RETURN
*
  100 WRITE( NOUT, FMT = 9997 )
      CLOSE( NIN )
      IF( NOUT.NE.6 .AND. NOUT.NE.0 )
     $   CLOSE( NOUT )
      CALL BLACS_ABORT( ICTXT, 1 )
*
      STOP
*
 9999 FORMAT( A )
 9998 FORMAT( ' Number of values of ',5A, ' is less than 1 or greater ',
     $        'than ', I2 )
 9997 FORMAT( ' Illegal input in file ',40A,'.  Aborting run.' )
 9996 FORMAT( A7, L2 )
 9995 FORMAT( '  Subprogram name ', A7, ' not recognized',
     $        /' ******* TESTS ABANDONED *******' )
 9994 FORMAT( 2X, 'Alpha                     : ', G16.6 )
 9993 FORMAT( 2X, 'Number of Tests           : ', I6 )
 9992 FORMAT( 2X, 'Number of process grids   : ', I6 )
 9991 FORMAT( 2X, '                          : ', 5I6 )
 9990 FORMAT( 2X, A1, '                         : ', 5I6 )
 9989 FORMAT( 2X, 'Routines to be tested     :      ', A, A8 )
 9988 FORMAT( 2X, '                                 ', A, A8 )
*
*     End of PSBLA1TIMINFO
*
      END

ext: f

max_stars_repo_name: jschueller/scalapack

max_issues_repo_name: jschueller/scalapack

max_forks_repo_name: jschueller/scalapack


text:
! Specifics for windows

module dll_mod
    use, intrinsic :: iso_c_binding
    use kernel32    ! Allows use of LoadLibrary, GetProcAddress and FreeLibrary on Windows
    use gen_util_mod
    use output_mod
    implicit none

    private
    public load_user_library

    character(len=4), parameter     :: lib_ext = '.dll'

    contains

    subroutine load_user_library(fun_cptr, path_name, fun_name)
    implicit none
        type(c_funptr), allocatable         :: fun_cptr(:)  ! C-type pointer to the dll's subroutine
        integer(c_intptr_t)                 :: fun_tmp      ! Temporary integer with pointer location
        character(len=*)         			:: path_name    ! dynamically linked library name
        character(len=*)                    :: fun_name(:)  ! Base function name (without underscores)

        integer(handle)                     :: dll_handle   ! C-type handle to entire dll
        character(len=100)		            :: fun_mangle(4)! Different attempts of name-mangling scheme to find function
        integer					            :: k1           ! Loop through the fun_mangle variable
        integer                             :: nfun, kf     ! Number of functions to load from dll, and looping iterator for the same

        nfun = size(fun_name)
        allocate(fun_cptr(nfun))

        dll_handle = LoadLibrary( trim(path_name)//trim(lib_ext)//c_null_char )
        if (dll_handle==0) then
            call write_output('Cannot locate "'//trim(path_name)//trim(lib_ext)//'"', 'error', 'inp', halt=.false.)
            call write_output('Check that you have compiled it as 64 bit', 'error', 'inp', halt=.false.)
            call write_output('Please verify that it is available in path', 'error', 'inp', loc=.false.)

        else
            do kf=1,nfun
                fun_mangle(1) = upcase(fun_name(kf))
                fun_mangle(2) = trim(fun_mangle(1))//'_'
                fun_mangle(3) = lowcase(fun_name(kf))
                fun_mangle(4) = trim(fun_mangle(3))//'_'

    		    do k1=1,size(fun_mangle)
    			    fun_tmp = GetProcAddress(dll_handle, trim(fun_mangle(k1))//c_null_char)
    			    if (fun_tmp/=0) then
    				    exit
				    endif
			    enddo
			    if (fun_tmp==0) then
                    call write_output('Cannot find subroutine '//fun_name(kf)//' in "'//trim(path_name)//trim(lib_ext)//'"', 'error', 'inp', halt=.false.)
				    call write_output('Please verify that '//fun_name(kf)//' exists using "dumpbin /exports '//trim(path_name)//trim(lib_ext), 'error', 'inp', loc=.false.)
                endif
                fun_cptr(kf) = transfer(fun_tmp, fun_cptr(kf))
            enddo
        endif

    end subroutine

end module dll_mod

max_stars_repo_name: KnutAM/matmodfit

max_issues_repo_name: KnutAM/matmodfit

max_forks_repo_name: KnutAM/matmodfit


text:
needs net/sockets

variable sock
with~ ~sockets

: init
	" ronware.org" 80 connectsocket	|  -1 on failure, else a valid socket we can talk to
	sock ! ;

: ok
	sock @ 1+ 0if ." Couldn't open a socket." cr bye then
	." Got a valid socket: " sock @ . cr
	;

: +lplace-cr
	scratch +lplace
	crlf scratch +lplace ;

: getpage
	scratch off
	" GET /ok.html HTTP/1.1" +lplace-cr
	" Host: ronware.org:80" +lplace-cr
	crlf scratch +lplace
	sock @  scratch lcount 0 send ." send: " . cr
	sock @ scratch 4096 0  recv
	scratch swap type cr
	;

init ok getpage sock @ closesocket bye

max_stars_repo_name: ronaaron/reva

max_issues_repo_name: ronaaron/reva

max_forks_repo_name: ronaaron/reva


text:
program t
  implicit none
  integer::s,a
  print '(i0)',s()
  print '(i0)',a()
end program t

integer function s()
  implicit none
  integer::a
  s=0
  return
  entry a
  s=1
end function s

max_stars_repo_name: maddenp/ppp

max_issues_repo_name: maddenp/ppp

max_forks_repo_name: maddenp/ppp


text:
      MODULE MOD_ETL

      CONTAINS

      SUBROUTINE ETL(job)

      use UTILS, only: ASSERT
      use MOD_READMOD
      use MOD_WRITMS
      use MOD_WRITMSI
      use MOD_READPOP
      use MOD_COOP_M
      use MOD_READMS
      use MOD_READMSI
      use MOD_LIOP
      use MOD_DATOM_M
      use MOD_READRAD
      use MOD_ETLRAY
      use MOD_extUray
      use MOD_DIFFUS
      use MOD_ELIMIN
      use MOD_PRIINTL
      use MOD_STORXJL
      use MOD_FLGRID
      use MOD_DECETL
      use MOD_PRELINE
      use MOD_ETLHIST
      use MOD_WRITMOD
      use MOD_REBLANK
      use MOD_PRIETL
      use MOD_WRITRADL
      use MOD_FORMATS
      use MOD_ERROR
      use MOD_TICTOC
      use PARAMS_ARRAY
      use ABUNDANCES
      USE CONSTANTS
      USE COMMON_BLOCK
      USE FILE_OPERATIONS
      USE VARDATOM
      USE VARHMINUS
      USE VARSTEAL

      IMPLICIT REAL*8(A - H, O - Z)

      INTEGER :: LASTUPD
      integer :: timer
      integer :: NDUMMY0

      real*8, allocatable :: DUMMY2(:,:)
      real*8 :: DUMMY0

      COMMON /COMLBKG/ LBKG,XLBKG1,XLBKG2

      INTEGER XLBKG1,XLBKG2

      LOGICAL LBKG

!     RINAT TAGIROV:
!     See Fig. 7-29 in Mihalas, Stellar Atmospheres, 2nd edition, 1978
!     for the geometry of the ray-by-ray solution as well as
!     Mihalas, Kunasz & Hummer, 1975, 202: 465 - 489
!     "Solution of the comoving-frame equation of transfer in spherically symmetric flows.
!     I.Computational method for equivalent-two-level-atom source functions"

      COMMON // ASF(NDDIM),BSF(NDDIM),PP(NDDIM)
     $ ,XJLMEAN(NDDIM),HBLUWI(NDDIM)
     $ ,TA(NDDIM),TB(NDDIM),TC(NDDIM),UB(NDDIM),GA(NDDIM),H(NDDIM)
     $ ,QQ(NDDIM),S(NDDIM),V(NDDIM),VA(NDDIM),VB(NDDIM),Uray(NDDIM)
     $ ,AF(NFLDIM,NFLDIM),BF(NFLDIM,NFLDIM)
     $ ,XJ(NFLDIM,NDDIM),XH(NFLDIM,NDDIM),XK(NFLDIM,NDDIM)
     $ ,XN(NFLDIM,NDDIM),W0(NDDIM),W1(NDDIM),W2(NDDIM),W3(NDDIM)
     $ ,BMHO(NFLDIM),BMNO(NFLDIM),BMHI(NFLDIM),BMNI(NFLDIM)

      COMMON /COMELI/ XJCIND(NDDIM)

      LOGICAL :: PR_COND

      REAL*8, ALLOCATABLE :: U(:, :)

!     the Local approximate lambda-Operator for a given line
      REAL*8, ALLOCATABLE :: LO(:)

      parameter(IPDIM = 25, NBDIM = 99)

      COMMON /LIBLDAT/ SCAGRI(IPDIM), SCAEVT(IPDIM,NBDIM),
     $                                ABSEVT(IPDIM,NBDIM)
      COMMON /LIBLPAR/ ALMIN, ALMAX, LBLAON, IPMAX, NBMAX, NBINW
      COMMON /LIBLFAC/ SCAFAC(NDDIM,NFDIM),ABSFAC(NDDIM,NFDIM)

      CHARACTER MODHEAD*104,MODHOLD*104, CARD*80, LCARD*420
      CHARACTER CNAME*10, CREAD*10
      CHARACTER*10 MAINPRO(NDDIM),MAINLEV(NDDIM)
      CHARACTER*10 NAMEU, NAMEJ
      CHARACTER*7 JOB
      character*7 LINE(MAXIND)
      LOGICAL ETLKEY,LINEKEY(maxind)
      integer,external :: time
      logical :: ierr9

      real*8, allocatable, dimension(:) :: opal, etal

      real*8 :: start, finish

      call cpu_time(start); call system("echo -n $(date +%s) >> wall_time.etl")

      print*, 'entering etl... ' // writeTOC()

      call tic(timer)

!***  DECODING INPUT CARDS
      CALL DECETL(LSOPA,LSINT,VDOP,LINE,NLINE,LINEKEY,MAXIND,LBLANK)

      IF (NLINE .EQ. 0) THEN; WRITE(6, *) 'NO LINE OPTIONS DECODED'; GOTO 99; ENDIF

      CALL FLGRID(NFLDIM, NFL, PHI, PWEIGHT, DELTAX)

!***  changes by Margit Haberreiter
      CALL DATOM_M(N,LEVEL,NCHARG,WEIGHT,ELEVEL,EION,MAINQN,
     $             EINST,ALPHA,SEXPO,AGAUNT,COCO,KEYCOL,ALTESUM,
     $             INDNUP,INDLOW,LASTIND,NATOM,
     $             ELEMENT,SYMBOL,NOM,KODAT,ATMASS,STAGE,NFIRST,
     $             NLAST,WAVARR,SIGARR,NFDIM)

!***  READING OF THE MODEL FILE
      IFL = 3; open(IFL, file = 'MODFILE', STATUS = 'OLD')

      CALL READMOD(IFL,N,ND,TEFF,RADIUS,NP,P,Z,ENTOT,VELO,
     $             GRADI,RSTAR,VDOPOLD,NF,
     $             XLAMBDA(1 : NF),FWEIGHT(1 : NF),AKEY(1 : NF),
     $             ABXYZ,NATOM,MODHEAD,JOBNUM,LBLANK)

      close(IFL)

      if (allocated(opal)) deallocate(opal); allocate(opal(ND))
      if (allocated(etal)) deallocate(etal); allocate(etal(ND))

      print *,'ETL: ND = ',ND,' NP = ',NP
      call assert(ND*NP>1,'ND*NP <= 1')

!     LOO is declared in common_block.for
      IF (ALLOCATED(LOO)) DEALLOCATE(LOO)

      ALLOCATE(U(ND, NP))
      ALLOCATE(LOO(ND, LASTIND))

      IF (JOBNUM .GE. 1000) JOBNUM = JOBNUM - 100
      PRINT *,'ETL: VDOP=',VDOP
      If (vdop.le.0.) vdop=vdopold

      IFL=3
      open (IFL,file='POPNUM',STATUS='OLD')

      call readpop(ifl,T,popnum,pop1,pop2,pop3,rne,n,nd,modhead,jobnum)

      close (ifl)

!***  read the radiation field from files RADIOC and RADIOL (pop1 is used as dummy storage)
      CALL READRAD(NF,ND,POP1,XJCARR,XJC,XJL,
     $             HTOT,GTOT,XTOT,ETOT,EMFLUX,TOTIN,TOTOUT,
     $             NCHARG,EDDARR,EDDI,NOM,WCHARM,N,lastind,
     $             EINST,MODHEAD,JOBNUM)

      JOBNUM = JOBNUM + 1

      if (vdop.ne.vdopold) then
         IFL=3
         open (IFL,file='MODFILE',STATUS='OLD')
         print *,' Line Doppler width changed'
         CALL WRITMOD(IFL,N,ND,TEFF,RADIUS,NP,P,Z,ENTOT,VELO,
     $                GRADI,RSTAR,VDOP,NF,
     $                XLAMBDA(1 : NF),FWEIGHT(1 : NF),AKEY(1 : NF),
     $                ABXYZ,NATOM,MODHEAD,JOBNUM)
         close(IFL)
      endif
!***  NO LINE BLANKETING WITHIN A LINE
!     switch off LB
      LBLANK=0

      CALL REBLANK (LBLANK,NF,XLAMBDA,ND,ENTOT,RNE,SCAFAC,ABSFAC)

!     INTRODUCING DIMENSIONLESS VELOCITY UNITS:
!     ********************************************
!     RINAT TAGIROV:
!     The description of VDOP is given in LIOP.for
!     ********************************************
      DO L = 1, ND

         VELO(L) =  VELO(L)  / VDOP

         GRADI(L) = GRADI(L) / VDOP

      ENDDO

!***  CHECK WHETHER THESE DATA EXIST AND BELONG TO THE PRESENT MODEL
      IFL=9
	ierr9=.false.
      open (IFL,file='RADIOCL',STATUS='UNKNOWN')
      IERR=-10
      CNAME='MODHEAD'
      READ (ifl,'(A10)',err=1001,end=101) cread
      if (cread.eq.cname) then
         READ (ifl,'(A104)',err=1001,end=101) MODHOLD
         IF (MODHEAD .NE. MODHOLD) then
            goto 101
         else
            ierr=0
	   endif
	endif
101    continue

      IF (IERR.ne.0 .OR. JOB.EQ.'newline')THEN
         rewind (ifl)
         CNAME='MODHEAD'
         write (ifl,'(A10)')  cname
	   write (ifl,'(A104)') MODHEAD
         CNAME='JOBNUM'
         CALL WRITMSI1(IFL,JOBNUM,CNAME,-1,IERR)
      ELSE
	   cname='JOBNUM'
         CALL READMSI1(ifl,LASTUPD,cname,ierr)
         IF (LASTUPD.GE. JOBNUM) PRINT *,
     $     ' ETL: WARNING - BACKGROUND DATA YOUNGER THAN PRESENT MODEL'
         IF (LASTUPD .LT. JOBNUM-20) PRINT *,
     $     ' ETL: WARNING - BACKGROUND DATA OLDER THAN 20 JOBS'
	   ierr9=.true.
      ENDIF

!***  NEWBGC = COUNTER OF LINES FOR WHICH NEW BACKGROUND CONT. RAD. FIELD IS
!***  CALCULATED
      NEWBGC = 0

!***  BEGINNING OF LOOP FOR EACH LINE ******************************************
!***  ONLY LINES WHICH APPEAR IN AN INPUT OPTION ARE TREATED !
!***  ( IN THE SEQUENCE OF THEIR OCCURENCE )

      ALLOCATE(LO(ND))

!      ALLOCATE(AW(NP, ND))

!      ALLOCATE(OpticalDepthLine(ND))
!      ALLOCATE(OpticalDepthLineCont(ND))

!      OPEN(UNIT = 14, FILE = 'line_feautrier_matrix.out',     FORM = 'FORMATTED')
!      OPEN(UNIT = 16, FILE = 'line_lambda_operator_diag.out', FORM = 'FORMATTED')

!      WRITE(14, 10231)
!      WRITE(16, 10233)

      SIGMAKI(1, 1) = -1.

      LineNumber = 1

      DO 7 NL = 1, NLINE

      ETLKEY = LINEKEY(NL)

!***  PREPARING SOME QUANTITIES FOR THE CONSIDERED LINE

      CALL PRELINE(NUP,LOW,IND,N,LRUD,XLAM,ND,NFL,LINE,BMHO,BMNO,
     $             BMHI,BMNI,XJLMEAN,HBLUWI,XJ,XH,XK,XN,ELEVEL,NL,
     $             EINST,INDNUP,INDLOW,LASTIND)

      IF ( (NUP .EQ. 0) .OR. (LRUD .EQ. 0) ) GOTO 7 ! THIS IS HOW WE GET 75 LINES OUT OF NLINE = 150

!***  COMPUTATION OF THE ETLA SOURCE FUNCTION COEFFICIENTS, ASF AND BSF
!***  RATES AND POPNUMBERS ARE UPDATED !
!***  THIS ROUTINE IS SKIPPED FOR SUBSEQUENT "FORMAL" LINES
!***  EXCEPT OF THE FIRST FORMAL LINE WHICH FOLLOWS AN ETL LINE
      IF (ETLKEY) GOTO 2
      IF (NL .EQ. 1) GOTO 3
      IF (LINEKEY(NL-1)) GOTO 2
      GOTO 3
    2 CONTINUE
!***  ETLA option not active
         print *,' ETLA option is not active'
         write (6,*) ' ETLA option is not active'
	   stop 'ETLA'
    3 CONTINUE

!***  INNER BOUNDARY VALUES
      CALL DIFFUS (XLAM,T,RADIUS,ND,BCORE,DBDR)

!***  CONTINUUM AND LINE OPACITIES
      CALL COOP_M(XLAM,ND,T,RNE,POPNUM,ENTOT,RSTAR,
     $            OPA,ETA,THOMSON,IWARN,MAINPRO,MAINLEV,NOM,
     $            N,LEVEL,NCHARG,WEIGHT,ELEVEL,EION,EINST,
     $            ALPHA,SEXPO,AGAUNT,0,DUMMY2,
     $            WAVARR(1 : N, 1 : NF),SIGARR(1 : N, 1 : NF),
     $            LBKG,XLBKG1,XLBKG2,NF)

!***  BACKGROUND CONTINUUM RADIATION FIELD

      write (NAMEU,FMT_KEY) 'U   ',IND
      write (NAMEJ,FMT_KEY) 'XJC ',IND
      if (ierr9) then

        !*** READ U AND XJC FROM FILE 9
      IERR=1
      CALL READMS (ifl,U,ND*NP,NAMEU,IERR)
      call assert(ierr==0,'Error reading U from File')
      CALL READMS (ifl,XJCIND,ND,NAMEJ,ierr)
      call assert(ierr==0,'Error reading XJCIND from File')

      else

!***     DATA FOR THAT LINE NOT PRESENT - CALCULATE IT NEW ...

      CALL ELIMIN(XLAM,DUMMY1,DUMMY0,U,Z,XJCIND,RADIUS,P,
     $            BCORE,DBDR,OPA,ETA,THOMSON,EDDI,ND,NP)

!***     ... and write it for use in the next iteration
      CALL WRITMS(ifl,U,ND*NP,NAMEU,-1,IERR)
      CALL WRITMS(ifl,XJCIND,ND,NAMEJ,-1,IERR)

      NEWBGC = NEWBGC + 1

      ENDIF

      !ADD THE THOMSON EMISSIVITY, USING THE CONTINUUM RADIATION FIELD :
      ETA(:ND)=ETA(:ND)+OPA(:ND)*THOMSON(:ND)*XJCIND(:ND)

      CALL LIOP_RTE(EINST(NUP,LOW),WEIGHT(LOW),WEIGHT(NUP),LOW,NUP,
     $              ND,XLAM,ENTOT,POPNUM,RSTAR,OPAL,ETAL,VDOP, N)

!***  FORMAL SOLUTION OF RAD.TRANSFER IN THE COMOVING FRAME
!***  IN ORDER TO OBTAIN THE 0. TO 3. MOMENTS OF THE RADIATION FIELD
!***  AND HENCE THE EDDINGTON FACTORS

      LO(1 : ND) = 0.0D0

!***  LOOP FOR RAY-BY-RAY COMPUTATION

      DO 13 JP = 1, NP - 1

      LMAX = MIN0(NP + 1 - JP, ND)

      CALL EXTURAY(U, URAY, ND, NP, JP)

      CALL ETLRAY(URAY,Z,OPA,OPAL,ETA,ETAL,XJLMEAN,RADIUS,ND,NP,JP,P,
     $            UB,GA,H,QQ,S,V,VA,VB,VELO,GRADI,PP,
     $            BMHO,BMNO,BMHI,BMNI,BCORE,DBDR,
     $            XJCIND,ELEVEL,LOW,
     $            PHI,PWEIGHT,NFL,DELTAX,XJ,XH,XK,XN,W0,W1,W2,W3,
     $            NL, XLAM, LO)

   13 CONTINUE

      LSOPAP = 1

      IF (LSOPA.GT.0 .and. nl.eq.LSOPA)
     $      CALL PRIETL (IND,XLAM,ND,OPA,OPAL,ETA,ETAL,RADIUS,
     $      JOBNUM,LSOPAP,XJLMEAN,MODHEAD,ASF,BSF,T,ETLKEY)
      IF (.NOT.ETLKEY) GOTO 20
         print *,' ETLA option is not active'
         write (6,*) ' ETLA option is not active'
	   stop 'ETLA'

!***  UPDATING THE LINE RADIATION FIELD IN THE MODEL FILE AND IN THE CURRENT XJL
   20 continue

!     RINAT TAGIROV:
!     We found an abnormal behavior of the local operator element
!     at the boundary points: LO(ND - 1) > LO(ND) and LO(1) > LO(2).
!     It might have something to do with the boundary conditions in the
!     Feautrier system for the solution of the radiative transfer equation (see CMFSET).
!     See Mihalas, Kunasz & Hummer, 1975, 202: 465 - 489
!     "Solution of the comoving-frame equation of transfer in spherically symmetric flows.
!     I.Computational method for equivalent-two-level-atom source functions" for boundary conditions formulation.
!     It follows from the paper that the boundary conditions are of the first order only.
!     It is consistent with the comments in CMFSET (see the core rays for the boundary
!     condition at the innermost point of the atmosphere model)
!     This might be the cause of such behavior.
!     In the paper it says that refining the atmosphere model
!     near the boundary points can help. I did that but no improvement was attained.
!     Maybe I did the refinement of the atmosphere model wrongly.
!     Another idea that comes to mind is that this behavior after all may not have
!     anything to do with the boundary conditions, but with the angular and
!     frequency weights W0 and PWEIGHT (see ETLRAY.FOR).
!     If there is something wrong with them it might affect both intensity XJLMEAN and LO element,
!     but I did not check this possibility.
!     Be that as it may, in what follows, to obviate this irregular behavior I linearly
!     extrapolated LO(ND) and LO(1) using the two preceding LO elements.

      LO(1) =  EXTRAP_LO_B_VAL(LO, ND, 3, 2, 1)
      LO(ND) = EXTRAP_LO_B_VAL(LO, ND, ND - 2, ND - 1, ND)

!     XJLMEAN is stored in XJL, LO is stored in LOO (which means LO OVERALL, i.e. for all lines at once)
      CALL STORXJL(XJL, XJLMEAN, ND, LASTIND, IND, LOO, LO)

      LineNumber = LineNumber + 1

    7 CONTINUE
!     END OF LOOP FOR EACH LINE

      DEALLOCATE(LO)

      CLOSE(ifl)

!***  store the line radiation field in file RADIOL
      call writradl(XJL,XJLMEAN,EINST,NCHARG,NOM,ND,N,LASTIND,MODHEAD,JOBNUM)

      IF (LSINT.GT.0) CALL PRIINTL(N,LEVEL,WEIGHT,EINST,LASTIND,LINE,NLINE,
     $                             INDLOW,INDNUP,ELEVEL,ND,XJL,LSINT,JOBNUM,MODHEAD)

!***  UPDATING THE MODEL HISTORY
      CALL ETLHIST(NLINE,LINE,LINEKEY,JOBNUM,VDOP,VDOPOLD,LAST,LCARD)

      open (7,file='MODHIST',status='old')
  8   read (7,'(A80)',end=11) card
	goto 8
 11   continue
	if (last.gt.400) last=400
      write (LCARD(LAST+1:LAST+20),'(" Rtime:",i9," sec")') toc()
      write (7,'(A120)') LCARD
      close (7)

!***  LOGFILE REMARK ON CONTINUUM BACKGROUND CALCULATIONS
      IF (NEWBGC .GT. 0) THEN
	   print '("NEW BACKGROUND CONTINUUM CALCULATED FOR"'//
     $          ',I4," LINES")',newBGC
      ENDIF

   99 CONTINUE

      close (6)

      call system("echo ' '$(date +%s) >> wall_time.etl"); call cpu_time(finish)

      call open_to_append(4315, 'cpu_time.etl'); write(4315, '(F6.3)') finish - start; close(4315)

      return

1001  continue
      write (6,*) ' ETL: error exit 1001'
	call error('etl: error exit 1001')

10231 FORMAT(2x,'NL',7x,'JP',9x,'K',8x,'ID',14x,
     $ 'TAL',20x,'TBL',20x,'TCL',16x,'LambdaOperDiag')

!10233 FORMAT('LN',14x,'IND',13x,'XLAM',13x,'ID',8x,'HEIGHT',8x,
!     $ 'OpacLine',8x,'EmisLine',8x,'OptDepLine',8x,'LamOpDiagMean')

!10234 FORMAT(I2,5x,I3,5x,E15.7,5x,I2,5x,E15.7,5x,E15.7,5x,E15.7,5x,E15.7,5x,E23.15)

      END SUBROUTINE

      FUNCTION EXTRAP_LO_B_VAL(LO, LO_SIZE, PD, UD, BD) RESULT(LO_B_VAL)

!     LINEARLY EXTRAPOLATES THE LOCAL OPERATOR ELEMENT BOUNDARY VALUE FROM THE TWO PRECEDING VALUES

      USE COMMON_BLOCK

      IMPLICIT NONE

      INTEGER, INTENT(IN) ::                    LO_SIZE

      REAL*8, DIMENSION(LO_SIZE), INTENT(IN) :: LO

      INTEGER, INTENT(IN) ::                    BD, UD, PD

      REAL*8 ::                                 C1, C2

      REAL*8 ::                                 LO_B_VAL

      C1 = (LO(PD) - LO(UD)) / (HEIGHT(PD) - HEIGHT(UD))

      C2 = LO(UD) - C1 * HEIGHT(UD)

      LO_B_VAL = C1 * HEIGHT(BD) + C2

      RETURN

      END FUNCTION EXTRAP_LO_B_VAL

      END MODULE

ext: for

max_stars_repo_name: rtagirov/nessy

max_issues_repo_name: rtagirov/nessy

max_forks_repo_name: rtagirov/nessy-src


text:
      subroutine mcritk (npat, ipat, ri, beta, indbet,
     1      ipot, nncrit, fbetac, xlamc, ckspc, xout, xcalcx)

      include '../HEADERS/const.h'
      include '../HEADERS/dim.h'
      dimension ipat(npatx)
      dimension ri(npatx+1), beta(npatx+1), indbet(npatx+1)
      dimension ipot(0:natx)
      parameter (necrit=9, nbeta=40)
      dimension fbetac(-nbeta:nbeta,0:nphx,necrit), ckspc(necrit)
      dimension xlamc(necrit)

cc    xcalcx is max xcalc encountered so far.  Set to -1 to reset it --
cc    otherwise it gets passed in and out as mcritk gets called.
c     calculation of xcalcx changed by ala. It is calculated only
c     a first call, i.e. for the NN SS path, and is not recalculated

c     We may want path in heap so that other paths built from this
c     path will be considered, but do not want this path to be
c     written out for itself.  Decide that now and save the flag
c     in the heap, so we won't have to re-calculate the mpprm
c     path parameters later.

c     Do not want it for output if last atom is central atom,
c     use xout = -1 as flag for undefined, don't keep it.
      if (ipat(npat) .eq. 0)  then
         xout = -1
         return
      endif

c     Make xout, output inportance factor.  This is sum over p of
c     (product of f(beta)/rho for the scatterers) *
c                                 (cos(beta0)/rho(npat+1).
c     Compare this to xoutx, max xout encountered so far.
c     Use mean free path factor, exp(-rtot/xlam)
c     Multiply by 100 so we can think in percent.

      xcalc = 0
      rtot = 0
      do 410  i = 1, npat+1
         rtot = rtot + ri(i)
  410 continue
      do 460  icrit = 1, nncrit
         rho = ri(npat+1) * ckspc(icrit)
c        when beta(0)=90 degrees, get zero, so fudge with cos=.2
         x = max (abs(beta(npat+1)), 0.3) / rho
         do 420  iat = 1, npat
            rho = ri(iat) * ckspc(icrit)
            ipot0 = ipot(ipat(iat))
            x = x * fbetac(indbet(iat),ipot0,icrit) / rho
  420    continue
         x = x * exp (-rtot/xlamc(icrit))
         xcalc = xcalc + x
  460 continue
      if (xcalcx.le.0)  xcalcx = xcalc
      xout = 100 * xcalc / xcalcx
      return
      end


text:
C           SUBROUTINE INSTG
      SUBROUTINE INSTG
C     INTERSTAGE OUTPUT
C      NUMBER OF SECTORS IS THREE OR LESS,HUB AND CASING VALUES ARE
C         CALCULATED AND PRINTED
C     NUMBER OF SECTORS IS MORE THAN THREE,ONLY SECTOR PITCHLINE
C         VALUES ARE PRINTED
C
      REAL MFSTOP
      LOGICAL PREVER
      COMMON /SNTCP/G,AJ,PRPC,ICASE,PREVER,MFSTOP,JUMP,LOPIN,ISCASE,
     1KN,GAMF,IP,SCRIT,PTRN,ISECT,KSTG,WTOL,RHOTOL,PRTOL,TRLOOP,LSTG,
     2LBRC,IBRC,ICHOKE,ISORR,CHOKE,PT0PS1(6,8),PTRS2(6,8),TRDIAG,SC,RC,
     3DELPR,PASS,IPC,LOPC,ISS
C
      COMMON/GEBE/DRBARR,DRBARS,E1,E2,E3,E4,E5,E6,HBRRH,HBRSH,IAFE
     1,IALF,IBT2,ICPR,ICPS,ISR2,ISTR,ISTS,L,R1,R3,R4,R5,
     2TALF,WGT0(8),WT(7),HBARS,HBARR,I
C
      COMMON /SINIT/H1(6,8),H2(6,8),DP0(6,8),DP1(6,8),DP1A(6,8),DP2(6,8)
     1,DP2A(6,8),CSALF1(6,8),ALF1(6,8),CSBET2(6,8),BET2(6,8),RADSD(6,8),
     2RADRD(6,8),ANN1(6,8),ANN2(6,8),ANN2A(6,8),ANN1A(6,8),U1A(6,8),
     3U2(6,8),ANN0(6,8),PT0(6,8),TT0(6,8),ALPHA0(6,8),PTP(6,8)
C
      COMMON /SINPUT/
     1PTPS,PTIN,TTIN,WAIR,FAIR,DELC,DELL,DELA,AACS,VCTD,STG,SECT,EXPN,
     2EXPP,EXPRE,RG,RPM,PAF,SLI,STGCH,ENDJOB,XNAME(20),TITLE(20),
     3PCNH(6),GAM(6,8),DR(6,8),DT(6,8),RWG(6,8),ALPHAS(6,8),ALPHA1(6,8),
     4ETARS(6,8),ETAS(6,8),CFS(6,8),ANDO(6,8),BETA1(6,8),BETA2(6,8),ETAR
     5R(6,8),ETAR(6,8),CFR(6,8),TFR(6,8),ANDOR(6,8),OMEGAS(6,8),AS0(6,8)
     6,ASMP0(6,8),ACMN0(6,8),A1(6,8),A2(6,8),A3(6,8),A4(6,8),A5(6,8),A6(
     76,8),OMEGAR(6,8),BSIA(6,8),BSMPIA(6,8),BCMNIA(6,8),B1(6,8),B2(6,8)
     8,B3(6,8),B4(6,8),B5(6,8),B6(6,8),SESTHI(8),RERTHI(8)
     9,fairx(5,8),wairx(5,8),rg1(8),rg1a(8),rg2(8),rg2a(8)
C
      REAL M0
      COMMON /SSTA01/CP0(8),w0(6),               PS0(6,8),V0(6,8),TS0(6,
     18),VU0(6,8),VZ0(6,8),RHOS0(6,8),PS1(6,8),WGT1(8),TA1(8),WG1(6,8),
     2            DPDR1(6,8),SI(6,8),  CP1(8),PHI1(6,8),TS1(6,8),V1(6,8)
     3,RHOS1(6,8),ALF1E(6,8),VU1(6,8),VZ1(6,8),M0(6,8)
C
      REAL MR1A
      COMMON /SSTA1A/VU1A(6,8),WG1A(6,8),WGT1A(8),VZ1A(6,8),  CP1A(8),
     1PS1A(6,8),RU1A(6,8),R1A(6,8),BET1A(6,8),RI(6,8),TTR1A(6,8),PTR1A(6
     2,8),MR1A(6,8)
C
      COMMON /SSTA2/V2(6,8),TTR2(6,8),PTR2(6,8),WG2(6,8),WGT2(8),TA2(8),
     1           PS2(6,8),PHI2(6,8)
C
      REAL MR2,M2     ,MF2
      COMMON /SFLOW2/TS2(6,8),CP2(8),R2(6,8),RHOS2(6,8),BET2E(6,8),RU2(6
     1,8),VU2(6,8),DPDR2(6,8),VZ2(6,8),MR2(6,8),MF2(6,8),M2(6,8)
C
      REAL M2A,MF2A
      COMMON /SSTA2A/WG2A(6,8),WGT2A(8),VU2A(6,8),VZ2A(6,8),PS2A(6,8),
     1ALF2A(6,8),TT2A(6,8),PT2A(6,8),TTBAR(8),PTBAR(8),STT0(8),SPT0(8),
     2M2A(6,8),MF2A(6,8),CP2A(8),V2A(6,8),TS2A(6,8),TAS(8),PAS(8),GAMS(8
     3),CPO(8),DELHVD(6,8)
C
      COMMON /SOVRAL/DELHT(6,8),DELHTI(6,8),DELHSI(6,8),DEHATI(6,8),
     1ETATT(6,8),ETATS(6,8),ETATAT(6,8),delhtu(6,8)
C
      COMMON /C1FIT1/ STDP0(7),STTT0(7),STPT0(7),STALF(7)
     1,STSI(7),STV0(7),STVU0(7),STVZ0(7),STTS0(7),
     2STPS0(7),STDEN0(7),STM0(7),STDP1(7),STTT1(7),
     3STALFE(7),STDELA(7),STV1(7),STVU1(7),STVZ1(7),
     4STTS1(7),STPS1(7),STDEN1(7),STM1(7),ZWIINC(7),
     5CPS(7),STDP1A(7),STTTR1(7),STPTR1(7),STBET1(7),
     6STRI(7),STR1A(7),STRU1A(7),STMR1A(7),STU1A(7),
     7STDP2(7),STBET2(7),SDBETA(7),SR2(7),SRU2(7),
     8SMR2(7),SU2(7),RX(7),STDELH(7),STPSI(7),
     9SETATT(7),SETATS(7),SETAAT(7),RZWINC(7),CPR(7),
     1STDP2A(7),STPT2(7),STTT2(7),STV2(7),STVU2(7),
     2STALF2(7),STMF2(7),STVZ2(7),STTS2(7),STPS2(7),
     3STDEN2(7),STM2(7),LJ,JJ,K
      COMMON /C2FIT1/  DBARS(7),FTANS(7),FAXS(7),DBARR(7),
     1FTANR(7),FAXR(7)
      COMMON RES(8),DALF(6),DSTS(6),DALFE(6),DCPS(6),DSTR(6),
     *DBT2(6),DCPR(6),DSR2(6)
      COMMON/TPT1/PT1(6),TT1(6,8)
      COMMON/DESOPT/RVU1(6,8),RVU2(6,8),WG,EPR
      dimension tangms(6,8),tangmr(6,8),tangm1(6,8),tangm2(6,8),tang0(6)
      common/slope/tangms,tangmr,tangm1,tangm2,tang0,iar,icyl
      K=1
      ETAO1=1.
1     CONTINUE
      E1=(GAMS(K)-1.)/GAMS(K)
      E2=GAM(1,K)/(GAM(1,K)-1.)
      E3=GAM(2,K)/(GAM(2,K)-1.)
      E4=GAM(3,K)/(GAM(3,K)-1.)
      E5=GAM(4,K)/(GAM(4,K)-1.)
      E6=GAM(5,K)/(GAM(5,K)-1.)
C     RELOCATE PITCHLINE VALUES
      HBARS= (DT(1,K)-DR(1,K)+DT(2,K)-DR(2,K))/4.
      WGT0(K)= WGT1(K)/RWG(2,K)*RWG(1,K)
      DW0= WGT0(K)/(G*HBARS)
      DW0D0= DW0/DP0(IP,K)
      DW0D1= DW0/DP1(IP,K)
      HBARR= (DT(3,K)-DR(3,K)+DT(4,K)-DR(4,K))/4.
      DW1A= WGT1A(K)/(G*HBARR)
      DW1AD1= DW1A/DP1A(IP,K)
      DW1AD2= DW1A/DP2(IP,K)
      DRBARS=(DR(1,K)+DR(2,K))/2.
      DRBARR=(DR(3,K)+DR(4,K))/2.
      HBRSH=HBARS/(DT(2,K)-DR(2,K))
      HBRRH=HBARR/(DT(4,K)-DR(4,K))
      GO TO(21,22,23,24,25,26),ISECT
21    KS1=1
      KS=4
      KF=7
c     ks=2
c     kf=2
      KSD=4
      GO TO 97
22    KS=2
      KF=4
      KSD=2
      GO TO 97
23    KS=2
      KF=4
      KSD=1
      GO TO 97
24    KS=2
      KF=6
      KSD=1
      GO TO 97
25    KS=2
      KF=6
      KSD=1
      GO TO 97
26    KS=1
      KF=7
      KSD=1
      GO TO 97
97    GO TO(91,92,93,94,95,96),ISECT
91    KS1=1
      GO TO 27
92    KS1=KS/2
      GO TO 27
93    KS1=KS-1
      GO TO 27
C94    IF(KS-4)32,5,29
C     replaced by ............
94    IF((KS-4).LT.0) THEN
         GO TO 32
      ELSEIF((KS-4).EQ.0) THEN
         GO TO 5
      ELSEIF((KS-4).GT.0) THEN
         GO TO 29
      ENDIF
32    KS1=KS-1
      GO TO 27
29    KS1=KS-2
      GO TO 27
95    KS1=KS-1
      GO TO 27
C96    IF(KS-4)30,5,31
C     replaced by ............
96    IF((KS-4).LT.0) THEN
         GO TO 30
      ELSEIF((KS-4).EQ.0) THEN
         GO TO 5
      ELSEIF((KS-4).GT.0) THEN
         GO TO 31
      ENDIF
30    KS1=KS
      GO TO 27
31    KS1=KS-1
      GO TO 27
27    STTT0(KS)=TT0(KS1,K)
      STDP0(KS)=DP0(KS1,K)
      STPT0(KS)=PTP(KS1,K)
      STALF(KS)=ALPHA0(KS1,K)*57.2958
      STSI(KS)=SI(KS1,K)*57.2958
      STV0(KS)=V0(KS1,K)
      STVU0(KS)=VU0(KS1,K)
      STVZ0(KS)=VZ0(KS1,K)
      STTS0(KS)=TS0(KS1,K)
      STPS0(KS)=PS0(KS1,K)
      rg0=rg
      if (k.gt.1) rg0=rg2a(k-1)
      STDEN0(KS)=144.*STPS0(KS)/STTS0(KS)/RG0
      STM0(KS)=M0(KS1,K)
      STDP1(KS)=DP1(KS1,K)
      STTT1(KS)=TT1(KS1,K)
      STALFE(KS)=ALF1E(KS1,K)*57.2958
      STDELA(KS)=(ALPHA0(KS1,K)+ALF1E(KS1,K))*57.2958
      STV1(KS)=V1(KS1,K)
      STVU1(KS)=VU1(KS1,K)
      STVZ1(KS)=VZ1(KS1,K)
      STTS1(KS)=TS1(KS1,K)
      STPS1(KS)=PS1(KS1,K)
      STDEN1(KS)=RHOS1(KS1,K)
      STM1(KS)=V1(KS1,K)/(SQRT(GAM(2,K)*G*rg1(k)*TS1(KS1,K)))
      ZS=-2.*ALF1E(KS1,K)-1.570796
      ZWIINC(KS)=-2.*COS(ZS)/(1.0+ANN0(KS1,K)/ANN1(KS1,K))
     1*(SIN(ALPHA0(KS1,K))/COS(ALPHA0(KS1,K))*COS(ALF1E(KS1,K))
     2/SIN(ALF1E(KS1,K))*ANN1(KS1,K)/ANN0(KS1,K)+1.)
      IF(EPR.GT.0.)
     *CALL ETAPR(PT0PS1(KS1,K),etaO1)
      CPS(KS)=ETAO1*ETAS(KS1,K)
      STDP1A(KS)=DP1A(KS1,K)
      STPTR1(KS)=PTR1A(KS1,K)
      STTTR1(KS)=TTR1A(KS1,K)
      STBET1(KS)=BET1A(KS1,K)*57.2958
      STRI(KS)=RI(KS1,K)*57.2958
      STR1A(KS)=R1A(KS1,K)
      STRU1A(KS)=RU1A(KS1,K)
      STMR1A(KS)=MR1A(KS1,K)
      STU1A(KS)=U1A(KS1,K)
      STDP2(KS)=DP2(KS1,K)
      STBET2(KS)=BET2E(KS1,K)*57.2958
      SDBETA(KS)=(BET1A(KS1,K)+BET2E(KS1,K))*57.2958
      SR2(KS)=R2(KS1,K)
      SRU2(KS)=RU2(KS1,K)
      SMR2(KS)=MR2(KS1,K)
      SU2(KS)=U2(KS1,K)
      RX(KS)=1.-(1.-(PS1(KS1,K)/PTP(KS1,K))**E1)/(1.-(PS2(KS1,K)
     1/PTP(KS1,K))**E1)
      STDELH(KS)=DELHTu(KS1,K)
      STPSI(KS)=   G*AJ*DELHT(KS1,K)/(U1A(KS1,K)*U1A(KS1,K)
     1+U2(KS1,K)*U2(KS1,K))
      SETATT(KS)=ETATT(KS1,K)
      SETATS(KS)=ETATS(KS1,K)
      SETAAT(KS)=ETATAT(KS1,K)
      ZR=-2.*BET2E(KS1,K)-1.570796
      RZWINC(KS)=-2.*COS(ZR)/(1.+ANN1A(KS1,K)/ANN2(KS1,K))
     1*(SIN(BET1A(KS1,K))/COS(BET1A(KS1,K))*COS(BET2E(KS1,K))
     2/SIN(BET2E(KS1,K))*ANN2(KS1,K)/ANN1A(KS1,K)+1.)
      IF(EPR.GT.0.)
     *CALL ETAPR(PTRS2 (KS1,K),etaO1)
      CPR(KS)=ETAO1*ETAR(KS1,K)
      STDP2A(KS)=DP2A(KS1,K)
      STPT2(KS)=PT2A(KS1,K)
      STTT2(KS)=TT2A(KS1,K)
      STV2(KS)=V2A(KS1,K)
      STVU2(KS)=VU2A(KS1,K)
      STALF2(KS)=ALF2A(KS1,K)*57.2958
      STMF2(KS)=MF2A(KS1,K)
      STVZ2(KS)=VZ2A(KS1,K)
      STPS2(KS)=PS2A(KS1,K)
      STTS2(KS)=TS2A(KS1,K)
      STM2(KS)=M2A(KS1,K)
      STDEN2(KS)=144.*STPS2(KS)/STTS2(KS)/rg2(k)
      DBARS(KS)=DRBARS+HBRSH*(STDP1(KS)-DR(2,K))*2.0
      HBRS=H1(KS1,K)*HBRSH*2.
      HBRR=H2(KS1,K)*HBRRH*2.
      FTANS(KS)=-WG1(KS1,K)*(STDP1(KS)*STVU1(KS)+STDP0(KS)
     1*STVU0(KS))/DBARS(KS)/G/HBRS
      if (k.eq.1) then
        cat0=cos(atan(tang0(ks1)))
      else
        cat0=cos(atan(tangm2(ks1,k-1)))
      end if
      cat1=cos(atan(tangm1(ks1,k)))
      cat2=cos(atan(tangm2(ks1,k)))
      FAXS(KS)=((STPS0(KS)-STPS1(KS))*(ANN1(KS1,K) +ANN0(KS1,K))*72.
     1+WG1(KS1,K)/G*(STVZ0(KS)*cat0-STVZ1(KS)*cat1))/HBRS
      DBARR(KS)=DRBARR+HBRRH*(STDP2(KS)-DR(4,K))*2.0
      FTANR(KS)=WG2(KS1,K)*(STDP2A(KS)*STVU2(KS)+STDP1(KS)*STVU1(KS))
     1/DBARR(KS)/G/HBRR*TFR(KS1,K)
      FAXR(KS)=((PS1A(KS1,K)-PS2(KS1,K))*(ANN1A(KS1,K)+ANN2(KS1,K))*72.
     1+WG2(KS1,K)/G*(VZ1A(KS1,K)*cat1-VZ2(KS1,K)*cat2))/HBRR
5     KS=KS+KSD
      IF(KS.GT.KF) GO TO 28
      GO TO 97
28    CALL INST2
      IF(K.LE.KSTG) GO TO 1
      RETURN
      END

max_stars_repo_name: mjfwest/OpenMDAO-Framework

max_issues_repo_name: jcchin/OpenMDAO-Framework

max_forks_repo_name: jcchin/OpenMDAO-Framework


text:
      PROGRAM xrzextr
C     driver for routine rzextr
      INTEGER NV
      PARAMETER(NV=4)
      INTEGER i,iest,j
      REAL dum,xest,yest(NV),yz(NV),dy(NV)
      do 12 i=1,10
        iest=i
        xest=1.0/float(i)
        dum=1.0-xest+xest**3
        do 11 j=1,NV
          dum=dum/(xest+1.0)
          yest(j)=dum
11      continue
        call rzextr(iest,xest,yest,yz,dy,NV)
        write(*,'(/1x,a,i2,a,f8.4)') 'IEST = ',i,'   XEST =',xest
        write(*,'(1x,a,4f12.6)') 'Extrap. Function: ',(yz(j),j=1,NV)
        write(*,'(1x,a,4f12.6)') 'Estimated Error:  ',(dy(j),j=1,NV)
12    continue
      write(*,'(/1x,a,4f12.6)') 'Actual Values:    ',1.0,1.0,1.0,1.0
      END

max_stars_repo_path: NR-Functions/Numerical Recipes- Example & Functions/Examples/xrzextr.for


text:
! { dg-do compile }
! { dg-shouldfail "Invalid Fortran 2003 code" }
! { dg-options "-std=f2003 -fall-intrinsics" }
! PR fortran/23994
!
! Test PROTECTED attribute. Within the module everything is allowed.
! Outside (use-associated): For pointers, their association status
! may not be changed. For nonpointers, their value may not be changed.
!
! Test of a invalid code

module good1
  implicit none
  integer              :: a
  integer              :: b,c
  protected            :: c
  equivalence (a,c) ! { dg-error "Either all or none of the objects in the EQUIVALENCE" }
end module good1

module bad1
  implicit none
  integer, protected   :: a
  integer              :: b,c
  protected            :: c
  equivalence (a,b) ! { dg-error "Either all or none of the objects in the EQUIVALENCE" }
end module bad1

module bad2
  implicit none
  integer, protected   :: a
  integer              :: b,c,d
  protected            :: c
  common /one/ a,b  ! { dg-error "PROTECTED attribute conflicts with COMMON" }
  common /two/ c,d  ! { dg-error "PROTECTED attribute conflicts with COMMON" }
end module bad2

module good2
  implicit none
  type myT
     integer :: j
     integer, pointer :: p
     real, allocatable, dimension(:) :: array
  end type myT
  type(myT), save :: t
  protected :: t
end module good2

program main
  use good2
  implicit none
  t%j = 15             ! { dg-error "Assigning to PROTECTED variable" }
  nullify(t%p)         ! { dg-error "Assigning to PROTECTED variable" }
  allocate(t%array(15))! { dg-error "Assigning to PROTECTED variable" }
end program main

! { dg-final { cleanup-modules "good1 good2 bad1 bad2" } }

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
      SUBROUTINE D02AGY(Y, X, H, N, N1, AUX, WSPACE, WSPAC1,            ABSH1727
     *     PARAM)                                                       ABSH1728
C                                                                       ABSH1729
C     USES THE TECHNIQUE OF NAG LIBRARY                                 ABSH1730
C     PROCEDURE D02AAF WITH THE                                         ABSH1731
C     SPECIFICATION OF AUX CHANGED                                      ABSH1732
C     ALL IMPLICITLY DECLARED REALS MAY                                 ABSH1733
C     BE DECLARED DOUBLE PRECISION                                      ABSH1734
C     NAG COPYRIGHT 1975                                                ABSH1735
C     EDITED BY JOYCE CLARKE OXFORD OEG NUCLEAR PHYSICS 11TH SEP 1976   ABSH1736
C                   FORTRAN MACRO VERSION FDIA24.TEC                    ABSH1737
C     MARK 4.5 REVISED                                                  ABSH1738
C                                                                       ABSH1739
C   INTEGRATES A SYSTEM OF ODE'S USING MERSON'S METH.                   ABSH1740
C   CF.  LAMBERT, J.D., COMPUTATIONAL METHODS IN ORDINARY DIFFERENTIAL  ABSH1741
C        EQUATIONS, PP. 130-135, WILEY, 1973.                           ABSH1742
C                                                                       ABSH1743
      INTEGER N, N1, I                                                  ABSH1744
      REAL Y(N), X, H, WSPACE(N,9), WSPAC1(N), PARAM(N1), C1,           ABSH1745
     *     C2, U, V, W, DUM                                             ABSH1746
      CALL AUX(WSPAC1, Y, X, PARAM)                                     ABSH1747
      C1 = 1.0/3.0                                                      ABSH1748
      C2 = 1.0/6.0                                                      ABSH1749
      DO 10 I=1,N                                                       ABSH1750
           WSPACE(I,3) = WSPAC1(I)                                      ABSH1751
   10 CONTINUE                                                          ABSH1752
      U = C1*H                                                          ABSH1753
      DO 20 I=1,N                                                       ABSH1754
           WSPACE(I,4) = Y(I)                                           ABSH1755
           Y(I) = Y(I) + U*WSPACE(I,3)                                  ABSH1756
   20 CONTINUE                                                          ABSH1757
      CALL AUX(WSPAC1, Y, U+X, PARAM)                                   ABSH1758
      DO 30 I=1,N                                                       ABSH1759
           WSPACE(I,5) = WSPAC1(I)                                      ABSH1760
   30 CONTINUE                                                          ABSH1761
      V = H*C2                                                          ABSH1762
      DO 40 I=1,N                                                       ABSH1763
           Y(I) = WSPACE(I,4) + V*(WSPACE(I,3)+WSPACE(I,5))             ABSH1764
   40 CONTINUE                                                          ABSH1765
      CALL AUX(WSPAC1, Y, U+X, PARAM)                                   ABSH1766
      DO 50 I=1,N                                                       ABSH1767
           WSPACE(I,5) = WSPAC1(I)                                      ABSH1768
   50 CONTINUE                                                          ABSH1769
      U = H*0.125                                                       ABSH1770
      V = H*0.375                                                       ABSH1771
      DO 60 I=1,N                                                       ABSH1772
           Y(I) = WSPACE(I,4) + WSPACE(I,3)*U + WSPACE(I,5)*V           ABSH1773
   60 CONTINUE                                                          ABSH1774
      U = 0.5*H                                                         ABSH1775
      V = 1.5*H                                                         ABSH1776
      W = 2.0*H                                                         ABSH1777
      CALL AUX(WSPAC1, Y, U+X, PARAM)                                   ABSH1778
      DO 70 I=1,N                                                       ABSH1779
           Y(I) = WSPACE(I,4) + WSPACE(I,3)*U - WSPACE(I,5)*V +         ABSH1780
     *          WSPAC1(I)*W                                             ABSH1781
           WSPACE(I,5) = WSPAC1(I)                                      ABSH1782
   70 CONTINUE                                                          ABSH1783
      X = X + H                                                         ABSH1784
      CALL AUX(WSPAC1, Y, X, PARAM)                                     ABSH1785
      U = H*C2                                                          ABSH1786
      V = 2.0*H*C1                                                      ABSH1787
      DO 80 I=1,N                                                       ABSH1788
           W = WSPACE(I,4) + U*(WSPACE(I,3)+WSPAC1(I)) +                ABSH1789
     *          WSPACE(I,5)*V                                           ABSH1790
           DUM = W - Y(I)                                               ABSH1791
           WSPACE(I,2) = 0.2*ABS(DUM)                                   ABSH1792
           Y(I) = W                                                     ABSH1793
   80 CONTINUE                                                          ABSH1794
      RETURN                                                            ABSH1795
      END                                                               ABSH1796

max_stars_repo_name: jonathanschilling/VMOMS

max_issues_repo_name: jonathanschilling/VMOMS

max_forks_repo_name: jonathanschilling/VMOMS


text:
subroutine nsc_RestarMaster(a,itask)
   use typre
   use def_parame
   use Mod_PhysicalProblem
   use Mod_NSCompressible
   implicit none
   class(NSCompressibleProblem) :: a
   integer(ip), intent(in)    :: itask

   interface
      !subroutine nsc_nsirestar(a)
      !   use typre
      !   use Mod_NSCompressible
      !   implicit none
      !   class(NSCompressibleProblem) :: a
      !end subroutine

      subroutine php_restar(a,itask)
         use typre
         use Mod_PhysicalProblem
         implicit none
         class(PhysicalProblem) :: a
         integer(ip), intent(in) :: itask
      end subroutine
   end interface

   select case (itask)

   case (1)

      if (a%kfl_nsirstar == 1) then
         if (a%kfl_inter == 0) then
            call runend ('Restart from incompressible flow requires using an interpolated restart')
         else
            !call nsc_nsirestar(a)
         endif
      else
         call php_restar(a,itask)
      endif

   case (2)

      call php_restar(a,itask)

   end select

end subroutine nsc_RestarMaster

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text:
      subroutine checkorder(order)
c--- checks the value of nproc and part against a list of processes that
c--- are calculable only at LO. If the calculation is not possible,
c--- writes an error message and aborts
      implicit none
      include 'frag.f'
      include 'part.f'
      include 'nproc.f'
      character*1 order

c--- special cases where there is no LO calculation
      if ((part .ne. 'real') .and. (order .eq. 'R')) then
        write(6,*)
        write(6,*)'This process can only be calculated with part=real,'
        write(6,*)'it is a subset of a NLO calculation only.'
      stop
      endif

c--- if we're calculating LO only, there's no problem
      if (part .eq. 'lord') return

c--- otherwise, we must be performing a NLO calculation, and this list of
c--- process numbers can't be calculated beyond LO
      if (order .eq. 'L') then
        write(6,*)
        write(6,*)'This process cannot be calculated beyond LO - please'
        write(6,*)'check the values of nproc and part then try again'
        stop
      endif

c--- check that fragmentation is not turned on for a non-fragmentation process
      if ((frag) .and. (order .ne. 'F')) then
        write(6,*)
        write(6,*) 'This process does not include photon fragmentation.'
        write(6,*) 'Please set frag=.false. in the input file.'
        stop
      endif

      return
      end

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text:
      SUBROUTINE RAND5 (NFREQ,NPSDL,NTAU,XYCB,LTAB,IFILE,PSDF,AUTO,
     1                  NFILE)
C
C     THIS ROUTINE COMPUTES RANDOM RESPONSE FOR UNCOUPLED POWER SPECTRAL
C     DENSITY COEFFICIENTS
C
      INTEGER IZ(1),SYSBUF,FILE,XYCB,PSDF,AUTO,IFILE(1),NAME(2),
     1        MCB1(7),MCB2(7),OLDLD
      REAL    Q(2),DATA(100)
C
      COMMON /SYSTEM/ SYSBUF
      COMMON /ZZZZZZ/ Z(1)
C
      EQUIVALENCE  (Z(1),IZ(1))
C
      DATA    NAME,MCB1,MCB2 /4HRAND,4H5   ,14*0/
      DATA    IPSDF,IAUTO    /  4001,4002       /
C *****
C     DEFINITION OF VARIABLES
C *****
C     NFREQ    NUMBER OF FREQUENCIES
C     NPSDL    NUMBER OF SUBCASES ON PSDL CARDS
C     NTAU     NUMBER OF TIMES
C     XYCB     DATA BLOCK CONTAINING XY USER REQUESTS
C     LTAB     LENGTH OF CORE  USED FOR TABLES BY PRETAB
C     IFILE    ARRY CONTAINING FILE NAMES FOR SORT 2 INPUT FILES
C     PSDF     OUTPUT FILE FOR POWER SPECTRAL DENSITY FUNCTIONS
C     AUTO     OUTPUT FILE FOR AUTOCORRELATION FUNCTIONS
C     NFILE    LENGTH OF IFILE ARRAY
C     MCB1     TRAILER FOR PSDF
C     MCB2     TRAILER FOR AUTO
C     IPSDF    OFP ID FOR  PSDF
C     IAUTO    OFP ID FOR  AUTO
C     LCORE    AVAIABLE CORE FOR ANY LIST
C     IBUF1    BUFFER POINTERS
C     IBUF2
C     IBUF3
C     ITAU     POINTER TO FIRST TAU -1
C     ISAA     POINTER TO FIRST S(AA) -1
C     TAU      TIMES FOR AUTTOCORRELATION
C     SAA      POWER SPECTRAL DENSITY FACTORS
C     ICORE    POINTER  TO FIRST REQUEST -1
C     SYSBUF   LENGTH OF ONE BUFFER
C     NPOINT   NUMBER OF REQUESTS
C     NZ       CORE AVAILABLE FOR STORING PSDF-S
C     IP       POINTER TO FIRST POINT OF CURRENT CORE LOAD
C     NDONE    NUMBER OF REQUESTS PROCESSED
C     OLDLD    LOAD ID OF OLD LOAD SET
C     NDO      NUMBER POSSIBLE TO DO IN CORE
C     ICS      POINTER TO FIRST PSDF VECTOR
C     NLOAD    NUMBER OF PSDL CARDS PROCESSED
C     ICDONE   NUMBER CURRENTLY DONE-- SEVERAL COMP FROM EACH VALUE
C     LOAD     SUBCASE ID FROM INPUT RECORD
C     IF       FORMAT FLAG  IF =0  DATA IS REA/IMAG IF.NE.0 MAG/PHASE
C     LEN      LENGTH OF DATA RECORD
C     Q        MEAN RESPONSE
C     R        AUTO CORRALATION FUNCTION AT TIME TAU
C     IP1      LOCAL POINT POINTER
C
C
C *****
C     CORE LAYOUT DURING EXECUTION
C *****
C     FREQUENCIES   NFREQ OF THEM
C     RANDPS DATA   NPSDL OF THEM  5 WORDS PER CARD
C                   LOAD ID   LOAD ID   X    Y=0. TABLE
C     TAUS          NTAU OF THEM
C     TABLE DATA    LTAB OF IT
C     S(AA)         NFREQ OF THEM  THESE ARE  REEVALUATED WHEN LOAD CHAG
C     REQUESTS      NPOINT OF THEM 5 WORDS PER REQUEST
C                   D.B. ID   COMP O.P. P/P
C     S(J,A)        NO  DO OF THEM      LENGTH = NFREQ
C
C
C     BUFFERS       3 NEEDED
C
C
C     INITALIZE GENERAL VARIABLES, ASSIGN BUFFERS  ETC
C
      MCB1(1) = PSDF
      MCB2(1) = AUTO
      LCORE = KORSZ(Z)
      IBUF1 = LCORE -SYSBUF+1
      IBUF2 = IBUF1 -SYSBUF
      IBUF3 = IBUF2 -SYSBUF
      ITAU  = NFREQ +5*NPSDL
      ISAA  = NTAU  +LTAB+ITAU
      ICORE = ISAA  +NFREQ
      LCORE = LCORE -ICORE-3*SYSBUF
      ICRQ  =-LCORE
      IF (LCORE .LE. 0) GO TO 980
C
C     OPEN OUTPUT FILES
C
      CALL GOPEN (PSDF,Z(IBUF2),1)
      CALL GOPEN (AUTO,Z(IBUF3),1)
C
C     BEGIN LOOP ON EACH FILE
C
      DO 1000 I = 1,NFILE
C
C     BUILD POINT LIST FOR FILE(I)
C
      CALL RAND6 (XYCB,Z(IBUF1),NPOINT,IZ(ICORE+1),IFILE(I),LCORE)
      IF (NPOINT .EQ. 0) GO TO 1000
      NZ   = LCORE -5*NPOINT
      ICRQ =-NZ
      IF (NZ .LE. 0) GO TO 980
C
C     OPEN INPUT FILE
C
      FILE  = IFILE(I)
      CALL OPEN (*1000,FILE,Z(IBUF1),0)
      IP    = ICORE +1
      NDONE = 0
      OLDLD = 0
      ICS   = ICORE +5*NPOINT +1
      LLIST = 5*NPOINT
      IPS   = IP
      LLISTS= LLIST
   13 NDO   = MIN0(NPOINT-NDONE,NZ/NFREQ)
      ICRQ  = MAX0(NPOINT-NDONE,NFREQ)
      IF (NDO .EQ. 0) GO TO 980
      NLOAD = 0
C
C     ZERO CORE
C
      JJ = ICS + NDO*NFREQ-1
      DO 16 K = ICS,JJ
      Z(K) = 0.0
   16 CONTINUE
      ICDONE = 0
C
C     GET READY TO OBTAIN FIRST VALUE
C
   15 CALL RAND2 (IFILE(I),IZ(IP),LOAD,IF,LEN,LLIST)
C
C     CHECK FOR NEW LOAD
C
      IF (LOAD .EQ. 0) IF (NLOAD-NPSDL) 111,100,111
      IF (LOAD .EQ. OLDLD) GO TO 50
C
C     NEW LOAD --EVALUATE S(AA) FUNCTIONS FOR THIS LOAD
C
      J  = NFREQ +1
      JJ = ITAU
      DO 10 K = J,JJ,5
      IF (IZ(K) .EQ. LOAD) GO TO 20
   10 CONTINUE
C
C     LOAD NOT NEEDED --REJECT
C
      GO TO 15
C
C     GOOD LOAD --EVALUATE
C
   20 OLDLD = LOAD
      NLOAD = NLOAD +1
      DO 30 J = 1,NFREQ
      JJ = ISAA +J
C
C                TAB      X    F(X)
      CALL TAB (IZ(K+4),Z(J),Z(JJ))
      IF (IZ(K+4) .EQ. 0) Z(JJ) = 1.0
      Z(JJ) = Z(JJ)*Z(K+2)
   30 CONTINUE
C
C     BRING IN DATA
C
   50 IF (LEN .GT. 100) GO TO 970
      DO 60 J = 1,NFREQ
C
C     ACCESS DATA FROM FILE INTO DATA ARRAY
C
      CALL RAND2A (DATA(1))
      IP1 = IP
      II  = ICDONE
      LL  = ISAA +J
C
C     COMPUTE  MAGNITUDE         OF CURRENT COMPONENT
C
   52 IF ((LEN-2)/2 .GE. IZ(IP1+2)) GO TO 53
C
C     REQUEST OUT OF RANGE
C
      CALL MESAGE (52,IZ(IP1),IZ(IP1+1))
      IZ(IP1+2) = (LEN-2)/2
   53 JJ = IZ(IP1+2) +2
      IF (IF .NE. 0) GO TO 51
C
C     REAL + IMAGINARY
C
      K  = JJ + LEN/2 -1
      DATA(JJ) = SQRT(DATA(JJ)*DATA(JJ) + DATA(K)*DATA(K))
C
C     COMPUTE POWER SPECTRAL DENSITY FUNCTION
C
   51 K = ICS + II*NFREQ-1 +J
      Z(K) = Z(K) + DATA(JJ)*Z(LL)*DATA(JJ)
      IF (II .EQ. NDO-1) GO TO 60
C
C     IS NEXT REQUEST FROM SAME POINT
C
      IF (IZ(IP1).NE.IZ(IP1+5) .OR. IZ(IP1+1).NE.IZ(IP1+6)) GO TO 60
      II = II +1
      IP1= IP1+ 5
      GO TO 52
   60 CONTINUE
      LLIST  = LLIST - 5*(II-ICDONE+1)
      ICDONE = II +1
      IP = IP1 +5
C     HAVE I DONE ALL REQUEST(IN CURRENT CORE)
C
      IF (ICDONE .NE. NDO) GO TO 15
C
C     HAVE I ADDED IN ALL LOADS
C
      IP = IPS
      IF (NLOAD .EQ. NPSDL) GO TO 100
C
C     START AGAIN ON NEXT LOAD
C
      LLIST  = LLISTS
      ICDONE =  0
      GO TO 15
C
C     ALL LOADS FOR CURRENT BUNCH DONE
C
  100 JJ = IP
      J  = NDO* 5 +JJ-1
      L  = ICS - NFREQ
      DO 110 K = JJ,J,5
      L = L+ NFREQ
C
C     COMPUTE MEAN RESPONSE   Q
C
      CALL RAND3 (Z(1),Z(L),Q,NFREQ)
      IF (IZ(K+3) .EQ. 2) GO TO 105
C
C     PSDF REQUESTED
C
C     PUT OUT ID RECORD
C
      MCB1(7) = MCB1(7) +1
      CALL RAND1 (PSDF,IPSDF,IZ(K),IZ(K+1),IZ(K+4),Q)
C
C     PUT OUT DATA RECORD
C
      DO 101 LL = 1,NFREQ
      KK = L +LL -1
      CALL WRITE (PSDF,Z(LL),1,0)
      CALL WRITE (PSDF,Z(KK),1,0)
  101 CONTINUE
      CALL WRITE (PSDF,0,0,1)
  105 IF (IZ(K+3) .EQ. 1) GO TO 110
C
C     AUTOCORRELATION REQUESTED
C
      IF (NTAU .EQ. 0) GO TO 110
      CALL RAND1 (AUTO,IAUTO,IZ(K),IZ(K+1),IZ(K+4),Q)
      MCB2(7) = MCB2(7)+1
C
C     PUT OUT DATA RECORD
C
      DO 106 LL = 1,NTAU
      KK = ITAU + LL
      CALL WRITE (AUTO,Z(KK),1,0)
C
C     COMPUTE AUTO
C
      CALL RAND4 (Z(1),Z(L),Z(KK),R,NFREQ)
      CALL WRITE (AUTO,R,1,0)
  106 CONTINUE
      CALL WRITE (AUTO,0,0,1)
  110 CONTINUE
      CALL REWIND (IFILE(I))
      NDONE = NDONE +NDO
      IF (NDONE .NE. NPOINT) GO TO 200
  111 CALL CLOSE (IFILE(I),1)
      GO TO 1000
C
C     SPILL ON POINT LISTS --GO AGAIN
C
  200 OLDLD = 0
      IP  = IP + 5*NDO
      IPS = IP
      LLISTS = LLISTS-5*NDO
      GO TO 13
 1000 CONTINUE
C
C     ALL STUFF DONE --GET OUT
C
      CALL CLOSE (PSDF,1)
      CALL CLOSE (AUTO,1)
      CALL WRTTRL (MCB1)
      CALL WRTTRL (MCB2)
      RETURN
C
C     FILE + MISC ERRORS
C
  901 CALL MESAGE (IP1,FILE,NAME)
      RETURN
  970 IP1 = -7
      GO TO 901
  980 IP1 = -8
      FILE= ICRQ
      GO TO 901
      END


! { dg-do compile }
!
! PR fortran/45170
! PR fortran/52158
!
! Contributed by Damian Rouson

module speaker_class
  type speaker
  contains
    procedure :: speak
  end type
contains
  function speak(this)
    class(speaker) ,intent(in) :: this
    character(:) ,allocatable :: speak
  end function
  subroutine say_something(somebody)
    class(speaker) :: somebody
    print *,somebody%speak()
  end subroutine
end module