text:
      SUBROUTINE ZLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
     $                   LDV, T, LDT, C, LDC, WORK, LDWORK )
*
*  -- LAPACK routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          DIRECT, SIDE, STOREV, TRANS
      INTEGER            K, L, LDC, LDT, LDV, LDWORK, M, N
*     ..
*     .. Array Arguments ..
      COMPLEX*16         C( LDC, * ), T( LDT, * ), V( LDV, * ),
     $                   WORK( LDWORK, * )
*     ..
*
*  Purpose
*  =======
*
*  ZLARZB applies a complex block reflector H or its transpose H**H
*  to a complex distributed M-by-N  C from the left or the right.
*
*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
*
*  Arguments
*  =========
*
*  SIDE    (input) CHARACTER*1
*          = 'L': apply H or H' from the Left
*          = 'R': apply H or H' from the Right
*
*  TRANS   (input) CHARACTER*1
*          = 'N': apply H (No transpose)
*          = 'C': apply H' (Conjugate transpose)
*
*  DIRECT  (input) CHARACTER*1
*          Indicates how H is formed from a product of elementary
*          reflectors
*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
*
*  STOREV  (input) CHARACTER*1
*          Indicates how the vectors which define the elementary
*          reflectors are stored:
*          = 'C': Columnwise                        (not supported yet)
*          = 'R': Rowwise
*
*  M       (input) INTEGER
*          The number of rows of the matrix C.
*
*  N       (input) INTEGER
*          The number of columns of the matrix C.
*
*  K       (input) INTEGER
*          The order of the matrix T (= the number of elementary
*          reflectors whose product defines the block reflector).
*
*  L       (input) INTEGER
*          The number of columns of the matrix V containing the
*          meaningful part of the Householder reflectors.
*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
*
*  V       (input) COMPLEX*16 array, dimension (LDV,NV).
*          If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.
*
*  LDV     (input) INTEGER
*          The leading dimension of the array V.
*          If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.
*
*  T       (input) COMPLEX*16 array, dimension (LDT,K)
*          The triangular K-by-K matrix T in the representation of the
*          block reflector.
*
*  LDT     (input) INTEGER
*          The leading dimension of the array T. LDT >= K.
*
*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
*          On entry, the M-by-N matrix C.
*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
*
*  LDC     (input) INTEGER
*          The leading dimension of the array C. LDC >= max(1,M).
*
*  WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,K)
*
*  LDWORK  (input) INTEGER
*          The leading dimension of the array WORK.
*          If SIDE = 'L', LDWORK >= max(1,N);
*          if SIDE = 'R', LDWORK >= max(1,M).
*
*  Further Details
*  ===============
*
*  Based on contributions by
*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      CHARACTER          TRANST
      INTEGER            I, INFO, J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZCOPY, ZGEMM, ZLACGV, ZTRMM
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
*
*     Check for currently supported options
*
      INFO = 0
      IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZLARZB', -INFO )
         RETURN
      END IF
*
      IF( LSAME( TRANS, 'N' ) ) THEN
         TRANST = 'C'
      ELSE
         TRANST = 'N'
      END IF
*
      IF( LSAME( SIDE, 'L' ) ) THEN
*
*        Form  H * C  or  H' * C
*
*        W( 1:n, 1:k ) = conjg( C( 1:k, 1:n )' )
*
         DO 10 J = 1, K
            CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
   10    CONTINUE
*
*        W( 1:n, 1:k ) = W( 1:n, 1:k ) + ...
*                        conjg( C( m-l+1:m, 1:n )' ) * V( 1:k, 1:l )'
*
         IF( L.GT.0 )
     $      CALL ZGEMM( 'Transpose', 'Conjugate transpose', N, K, L,
     $                  ONE, C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK,
     $                  LDWORK )
*
*        W( 1:n, 1:k ) = W( 1:n, 1:k ) * T'  or  W( 1:m, 1:k ) * T
*
         CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T,
     $               LDT, WORK, LDWORK )
*
*        C( 1:k, 1:n ) = C( 1:k, 1:n ) - conjg( W( 1:n, 1:k )' )
*
         DO 30 J = 1, N
            DO 20 I = 1, K
               C( I, J ) = C( I, J ) - WORK( J, I )
   20       CONTINUE
   30    CONTINUE
*
*        C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
*                    conjg( V( 1:k, 1:l )' ) * conjg( W( 1:n, 1:k )' )
*
         IF( L.GT.0 )
     $      CALL ZGEMM( 'Transpose', 'Transpose', L, N, K, -ONE, V, LDV,
     $                  WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC )
*
      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
*        Form  C * H  or  C * H'
*
*        W( 1:m, 1:k ) = C( 1:m, 1:k )
*
         DO 40 J = 1, K
            CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
   40    CONTINUE
*
*        W( 1:m, 1:k ) = W( 1:m, 1:k ) + ...
*                        C( 1:m, n-l+1:n ) * conjg( V( 1:k, 1:l )' )
*
         IF( L.GT.0 )
     $      CALL ZGEMM( 'No transpose', 'Transpose', M, K, L, ONE,
     $                  C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK )
*
*        W( 1:m, 1:k ) = W( 1:m, 1:k ) * conjg( T )  or
*                        W( 1:m, 1:k ) * conjg( T' )
*
         DO 50 J = 1, K
            CALL ZLACGV( K-J+1, T( J, J ), 1 )
   50    CONTINUE
         CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T,
     $               LDT, WORK, LDWORK )
         DO 60 J = 1, K
            CALL ZLACGV( K-J+1, T( J, J ), 1 )
   60    CONTINUE
*
*        C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k )
*
         DO 80 J = 1, K
            DO 70 I = 1, M
               C( I, J ) = C( I, J ) - WORK( I, J )
   70       CONTINUE
   80    CONTINUE
*
*        C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
*                            W( 1:m, 1:k ) * conjg( V( 1:k, 1:l ) )
*
         DO 90 J = 1, L
            CALL ZLACGV( K, V( 1, J ), 1 )
   90    CONTINUE
         IF( L.GT.0 )
     $      CALL ZGEMM( 'No transpose', 'No transpose', M, L, K, -ONE,
     $                  WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC )
         DO 100 J = 1, L
            CALL ZLACGV( K, V( 1, J ), 1 )
  100    CONTINUE
*
      END IF
*
      RETURN
*
*     End of ZLARZB
*
      END

max_stars_repo_name: IRFM/ALOHA

max_issues_repo_name: IRFM/ALOHA

max_forks_repo_name: IRFM/ALOHA


text:
*----------------------------------------------------------------------*
      subroutine expand_op_product(form_list,idx_res,
     &                             fac,nops,idx_op,
     &                             iblk_min_in, iblk_max_in,
     &                             connect,nconnect,force,
     &                             op_info)
*----------------------------------------------------------------------*
*     given a list of operator indices and a result operator generate
*     all contractions arising from
*
*        fac * <C_res|Op(1)Op(2) ....Op(n)|A_res>
*
*     idx_res: operator describing resulting "shape" of contraction
*     idx_op(nops): operators to be contracted
*     connect(2,nconnect): list of operator pairs that must be connected
*                          e.g. (1,3) if first and third operator should
*                          be connected.
*     force is set true if we want the connection of the first and last
*     vertices in a non-standard way. If this is so then the first
*     element of connect should be (1,nconnect).
*
*     andreas, june 2007
*
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'
      include 'opdim.h'
      include 'mdef_operator_info.h'
      include 'def_contraction.h'
      include 'def_formula_item.h'
      include 'ifc_operators.h'
      include 'ifc_baserout.h'

      integer, parameter ::
     &     ntest = 00

      type(formula_item), intent(inout), target ::
     &     form_list
      real(8), intent(in) ::
     &     fac
      integer, intent(in) ::
     &     nops, nconnect,
     &     idx_res, idx_op(nops), iblk_min_in(nops), iblk_max_in(nops),
     &     connect(2,nconnect)
      type(operator_info), intent(in) ::
     &     op_info
      logical, intent(in)::
     &     force

      type(formula_item), pointer ::
     &     form_pnt
      type(contraction) ::
     &     proto
      type(operator), pointer ::
     &     op_res, op
      logical ::
     &     fix_vtx(nops)
      logical ::
     &     ok
      integer ::
     &     nvtx, narc, iarc, iblk_res, iop, jop
      integer ::
     &     iblk_min(nops), iblk_max(nops), iblk_op(nops),
     &     occ_test(ngastp,2), occ_temp(ngastp,2),
     &     idx_op_vtx(nops+2), idx_sv_vtx(nops+2),
     &     iblk_min2(nops+2), iblk_max2(nops+2),
     &     connect2(2,nconnect)
      integer, pointer ::
     &     occ_vtx(:,:,:), neqv(:), idx_eqv(:,:), iop_typ(:)

      integer, external ::
     &     vtx_type

      ! passing arguments to expand_op_product2
      if (force) call quit(1,'obsolete "force" feature?')
      idx_op_vtx(2:nops+1) = idx_op(1:nops)
      idx_op_vtx(1) = idx_res
      idx_op_vtx(nops+2) = idx_res
      do iop = 1,nops+1
        idx_sv_vtx(iop) = iop
      end do
      idx_sv_vtx(nops+2) = 1
      iblk_min2(2:nops+1) = iblk_min_in(1:nops)
      iblk_max2(2:nops+1) = iblk_max_in(1:nops)
      if (iblk_min2(2).lt.0) then
        iblk_min2(1) = -1
      else
        iblk_min2(1) = 1
        iblk_min2(nops+2) = 1
      end if
      if (iblk_max2(2).lt.0) then
        iblk_max2(1) = -1
      else
        iblk_max2(1) = op_info%op_arr(idx_res)%op%n_occ_cls
        iblk_max2(nops+2) = op_info%op_arr(idx_res)%op%n_occ_cls
      end if
      connect2(1:2,1:nconnect) = connect(1:2,1:nconnect) + 1
      call expand_op_product2(form_list,idx_res,
     &       fac,nops+2,nops+1,
     &       idx_op_vtx,idx_sv_vtx,
     &       iblk_min2,iblk_max2,
     &       connect2,nconnect,
     &       0,0,
     &       0,0,
     &       .false.,op_info)

******OBSOLETE*********************************************************
*     obsolete part of subroutine
*     now deleted
***********************************************************************

      return
      end

ext: f

max_stars_repo_name: ak-ustutt/GeCCo-public

max_issues_repo_name: ak-ustutt/GeCCo-public

max_forks_repo_name: ak-ustutt/GeCCo-public


text:
      program imprimir_secuencia_pares
        integer :: i
        do i=2,10,2
            print *,i !Imprimimos números pares
       end do
      end program imprimir_secuencia_pares

max_stars_repo_name: Marc-xyz/InicioRapidoEnFortran

max_issues_repo_name: Marc-xyz/InicioRapidoEnFortran

max_forks_repo_name: Marc-xyz/InicioRapidoEnFortran


text:
! Test forall lowering

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

!*** Test forall with multiple assignment statements and mask
subroutine test3_forall_construct(a,b, mask)
  real :: a(100,400), b(200,200)
  logical :: mask(100,200)
  forall (i=1:100, j=1:200, mask(i,j))
     a(i,j) = b(i,j) + b(i+1,j)
     a(i,200+j) = 1.0 / b(j, i)
  end forall
end subroutine test3_forall_construct

! CHECK-LABEL: func @_QPtest3_forall_construct(
! CHECK-SAME:        %[[VAL_0:.*]]: !fir.ref<!fir.array<100x400xf32>>{{.*}}, %[[VAL_1:.*]]: !fir.ref<!fir.array<200x200xf32>>{{.*}}, %[[VAL_2:.*]]: !fir.ref<!fir.array<100x200x!fir.logical<4>>>{{.*}}) {
! CHECK:         %[[VAL_3:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "j"}
! CHECK:         %[[VAL_4:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"}
! CHECK:         %[[VAL_5:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "j"}
! CHECK:         %[[VAL_6:.*]] = fir.alloca i32 {adapt.valuebyref, bindc_name = "i"}
! CHECK:         %[[VAL_7:.*]] = arith.constant 100 : index
! CHECK:         %[[VAL_8:.*]] = arith.constant 400 : index
! CHECK:         %[[VAL_9:.*]] = arith.constant 200 : index
! CHECK:         %[[VAL_10:.*]] = arith.constant 200 : index
! CHECK:         %[[VAL_11:.*]] = arith.constant 1 : i32
! CHECK:         %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i32) -> index
! CHECK:         %[[VAL_13:.*]] = arith.constant 100 : i32
! CHECK:         %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (i32) -> index
! CHECK:         %[[VAL_15:.*]] = arith.constant 1 : index
! CHECK:         %[[VAL_16:.*]] = arith.constant 1 : i32
! CHECK:         %[[VAL_17:.*]] = fir.convert %[[VAL_16]] : (i32) -> index
! CHECK:         %[[VAL_18:.*]] = arith.constant 200 : i32
! CHECK:         %[[VAL_19:.*]] = fir.convert %[[VAL_18]] : (i32) -> index
! CHECK:         %[[VAL_20:.*]] = arith.constant 1 : index
! CHECK:         %[[VAL_21:.*]] = fir.shape %[[VAL_7]], %[[VAL_8]] : (index, index) -> !fir.shape<2>
! CHECK:         %[[VAL_22:.*]] = fir.array_load %[[VAL_0]](%[[VAL_21]]) : (!fir.ref<!fir.array<100x400xf32>>, !fir.shape<2>) -> !fir.array<100x400xf32>
! CHECK:         %[[VAL_23:.*]] = fir.shape %[[VAL_9]], %[[VAL_10]] : (index, index) -> !fir.shape<2>
! CHECK:         %[[VAL_24:.*]] = fir.array_load %[[VAL_1]](%[[VAL_23]]) : (!fir.ref<!fir.array<200x200xf32>>, !fir.shape<2>) -> !fir.array<200x200xf32>
! CHECK:         %[[VAL_25:.*]] = fir.shape %[[VAL_9]], %[[VAL_10]] : (index, index) -> !fir.shape<2>
! CHECK:         %[[VAL_26:.*]] = fir.array_load %[[VAL_1]](%[[VAL_25]]) : (!fir.ref<!fir.array<200x200xf32>>, !fir.shape<2>) -> !fir.array<200x200xf32>
! CHECK:         %[[VAL_27:.*]] = fir.do_loop %[[VAL_28:.*]] = %[[VAL_12]] to %[[VAL_14]] step %[[VAL_15]] unordered iter_args(%[[VAL_29:.*]] = %[[VAL_22]]) -> (!fir.array<100x400xf32>) {
! CHECK:           %[[VAL_30:.*]] = fir.convert %[[VAL_28]] : (index) -> i32
! CHECK:           fir.store %[[VAL_30]] to %[[VAL_6]] : !fir.ref<i32>
! CHECK:           %[[VAL_31:.*]] = fir.do_loop %[[VAL_32:.*]] = %[[VAL_17]] to %[[VAL_19]] step %[[VAL_20]] unordered iter_args(%[[VAL_33:.*]] = %[[VAL_29]]) -> (!fir.array<100x400xf32>) {
! CHECK:             %[[VAL_34:.*]] = fir.convert %[[VAL_32]] : (index) -> i32
! CHECK:             fir.store %[[VAL_34]] to %[[VAL_5]] : !fir.ref<i32>
! CHECK:             %[[VAL_35:.*]] = fir.load %[[VAL_6]] : !fir.ref<i32>
! CHECK:             %[[VAL_36:.*]] = fir.convert %[[VAL_35]] : (i32) -> i64
! CHECK:             %[[VAL_37:.*]] = arith.constant 1 : i64
! CHECK:             %[[VAL_38:.*]] = arith.subi %[[VAL_36]], %[[VAL_37]] : i64
! CHECK:             %[[VAL_39:.*]] = fir.load %[[VAL_5]] : !fir.ref<i32>
! CHECK:             %[[VAL_40:.*]] = fir.convert %[[VAL_39]] : (i32) -> i64
! CHECK:             %[[VAL_41:.*]] = arith.constant 1 : i64
! CHECK:             %[[VAL_42:.*]] = arith.subi %[[VAL_40]], %[[VAL_41]] : i64
! CHECK:             %[[VAL_43:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_38]], %[[VAL_42]] : (!fir.ref<!fir.array<100x200x!fir.logical<4>>>, i64, i64) -> !fir.ref<!fir.logical<4>>
! CHECK:             %[[VAL_44:.*]] = fir.load %[[VAL_43]] : !fir.ref<!fir.logical<4>>
! CHECK:             %[[VAL_45:.*]] = fir.convert %[[VAL_44]] : (!fir.logical<4>) -> i1
! CHECK:             %[[VAL_46:.*]] = fir.if %[[VAL_45]] -> (!fir.array<100x400xf32>) {
! CHECK:               %[[VAL_47:.*]] = arith.constant 1 : index
! CHECK:               %[[VAL_48:.*]] = fir.load %[[VAL_6]] : !fir.ref<i32>
! CHECK:               %[[VAL_49:.*]] = fir.convert %[[VAL_48]] : (i32) -> i64
! CHECK:               %[[VAL_50:.*]] = fir.convert %[[VAL_49]] : (i64) -> index
! CHECK:               %[[VAL_51:.*]] = arith.subi %[[VAL_50]], %[[VAL_47]] : index
! CHECK:               %[[VAL_52:.*]] = fir.load %[[VAL_5]] : !fir.ref<i32>
! CHECK:               %[[VAL_53:.*]] = fir.convert %[[VAL_52]] : (i32) -> i64
! CHECK:               %[[VAL_54:.*]] = fir.convert %[[VAL_53]] : (i64) -> index
! CHECK:               %[[VAL_55:.*]] = arith.subi %[[VAL_54]], %[[VAL_47]] : index
! CHECK:               %[[VAL_56:.*]] = arith.constant 1 : index
! CHECK-DAG:           %[[VAL_57:.*]] = fir.load %[[VAL_6]] : !fir.ref<i32>
! CHECK-DAG:           %[[VAL_58:.*]] = arith.constant 1 : i32
! CHECK:               %[[VAL_59:.*]] = arith.addi %[[VAL_57]], %[[VAL_58]] : i32
! CHECK:               %[[VAL_60:.*]] = fir.convert %[[VAL_59]] : (i32) -> i64
! CHECK:               %[[VAL_61:.*]] = fir.convert %[[VAL_60]] : (i64) -> index
! CHECK:               %[[VAL_62:.*]] = arith.subi %[[VAL_61]], %[[VAL_56]] : index
! CHECK:               %[[VAL_63:.*]] = fir.load %[[VAL_5]] : !fir.ref<i32>
! CHECK:               %[[VAL_64:.*]] = fir.convert %[[VAL_63]] : (i32) -> i64
! CHECK:               %[[VAL_65:.*]] = fir.convert %[[VAL_64]] : (i64) -> index
! CHECK:               %[[VAL_66:.*]] = arith.subi %[[VAL_65]], %[[VAL_56]] : index
! CHECK:               %[[VAL_67:.*]] = fir.array_fetch %[[VAL_24]], %[[VAL_51]], %[[VAL_55]] : (!fir.array<200x200xf32>, index, index) -> f32
! CHECK:               %[[VAL_68:.*]] = fir.array_fetch %[[VAL_26]], %[[VAL_62]], %[[VAL_66]] : (!fir.array<200x200xf32>, index, index) -> f32
! CHECK:               %[[VAL_69:.*]] = arith.addf %[[VAL_67]], %[[VAL_68]] : f32
! CHECK:               %[[VAL_70:.*]] = arith.constant 1 : index
! CHECK:               %[[VAL_71:.*]] = fir.load %[[VAL_6]] : !fir.ref<i32>
! CHECK:               %[[VAL_72:.*]] = fir.convert %[[VAL_71]] : (i32) -> i64
! CHECK:               %[[VAL_73:.*]] = fir.convert %[[VAL_72]] : (i64) -> index
! CHECK:               %[[VAL_74:.*]] = arith.subi %[[VAL_73]], %[[VAL_70]] : index
! CHECK:               %[[VAL_75:.*]] = fir.load %[[VAL_5]] : !fir.ref<i32>
! CHECK:               %[[VAL_76:.*]] = fir.convert %[[VAL_75]] : (i32) -> i64
! CHECK:               %[[VAL_77:.*]] = fir.convert %[[VAL_76]] : (i64) -> index
! CHECK:               %[[VAL_78:.*]] = arith.subi %[[VAL_77]], %[[VAL_70]] : index
! CHECK:               %[[VAL_79:.*]] = fir.array_update %[[VAL_33]], %[[VAL_69]], %[[VAL_74]], %[[VAL_78]] : (!fir.array<100x400xf32>, f32, index, index) -> !fir.array<100x400xf32>
! CHECK:               fir.result %[[VAL_79]] : !fir.array<100x400xf32>
! CHECK:             } else {
! CHECK:               fir.result %[[VAL_33]] : !fir.array<100x400xf32>
! CHECK:             }
! CHECK:             fir.result %[[VAL_80:.*]] : !fir.array<100x400xf32>
! CHECK:           }
! CHECK:           fir.result %[[VAL_81:.*]] : !fir.array<100x400xf32>
! CHECK:         }
! CHECK:         fir.array_merge_store %[[VAL_22]], %[[VAL_82:.*]] to %[[VAL_0]] : !fir.array<100x400xf32>, !fir.array<100x400xf32>, !fir.ref<!fir.array<100x400xf32>>
! CHECK:         %[[VAL_83:.*]] = fir.shape %[[VAL_7]], %[[VAL_8]] : (index, index) -> !fir.shape<2>
! CHECK:         %[[VAL_84:.*]] = fir.array_load %[[VAL_0]](%[[VAL_83]]) : (!fir.ref<!fir.array<100x400xf32>>, !fir.shape<2>) -> !fir.array<100x400xf32>
! CHECK:         %[[VAL_85:.*]] = fir.shape %[[VAL_9]], %[[VAL_10]] : (index, index) -> !fir.shape<2>
! CHECK:         %[[VAL_86:.*]] = fir.array_load %[[VAL_1]](%[[VAL_85]]) : (!fir.ref<!fir.array<200x200xf32>>, !fir.shape<2>) -> !fir.array<200x200xf32>
! CHECK:         %[[VAL_87:.*]] = fir.do_loop %[[VAL_88:.*]] = %[[VAL_12]] to %[[VAL_14]] step %[[VAL_15]] unordered iter_args(%[[VAL_89:.*]] = %[[VAL_84]]) -> (!fir.array<100x400xf32>) {
! CHECK:           %[[VAL_90:.*]] = fir.convert %[[VAL_88]] : (index) -> i32
! CHECK:           fir.store %[[VAL_90]] to %[[VAL_4]] : !fir.ref<i32>
! CHECK:           %[[VAL_91:.*]] = fir.do_loop %[[VAL_92:.*]] = %[[VAL_17]] to %[[VAL_19]] step %[[VAL_20]] unordered iter_args(%[[VAL_93:.*]] = %[[VAL_89]]) -> (!fir.array<100x400xf32>) {
! CHECK:             %[[VAL_94:.*]] = fir.convert %[[VAL_92]] : (index) -> i32
! CHECK:             fir.store %[[VAL_94]] to %[[VAL_3]] : !fir.ref<i32>
! CHECK:             %[[VAL_95:.*]] = fir.load %[[VAL_4]] : !fir.ref<i32>
! CHECK:             %[[VAL_96:.*]] = fir.convert %[[VAL_95]] : (i32) -> i64
! CHECK:             %[[VAL_97:.*]] = arith.constant 1 : i64
! CHECK:             %[[VAL_98:.*]] = arith.subi %[[VAL_96]], %[[VAL_97]] : i64
! CHECK:             %[[VAL_99:.*]] = fir.load %[[VAL_3]] : !fir.ref<i32>
! CHECK:             %[[VAL_100:.*]] = fir.convert %[[VAL_99]] : (i32) -> i64
! CHECK:             %[[VAL_101:.*]] = arith.constant 1 : i64
! CHECK:             %[[VAL_102:.*]] = arith.subi %[[VAL_100]], %[[VAL_101]] : i64
! CHECK:             %[[VAL_103:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_98]], %[[VAL_102]] : (!fir.ref<!fir.array<100x200x!fir.logical<4>>>, i64, i64) -> !fir.ref<!fir.logical<4>>
! CHECK:             %[[VAL_104:.*]] = fir.load %[[VAL_103]] : !fir.ref<!fir.logical<4>>
! CHECK:             %[[VAL_105:.*]] = fir.convert %[[VAL_104]] : (!fir.logical<4>) -> i1
! CHECK:             %[[VAL_106:.*]] = fir.if %[[VAL_105]] -> (!fir.array<100x400xf32>) {
! CHECK:               %[[VAL_107:.*]] = arith.constant 1.000000e+00 : f32
! CHECK:               %[[VAL_108:.*]] = arith.constant 1 : index
! CHECK:               %[[VAL_109:.*]] = fir.load %[[VAL_3]] : !fir.ref<i32>
! CHECK:               %[[VAL_110:.*]] = fir.convert %[[VAL_109]] : (i32) -> i64
! CHECK:               %[[VAL_111:.*]] = fir.convert %[[VAL_110]] : (i64) -> index
! CHECK:               %[[VAL_112:.*]] = arith.subi %[[VAL_111]], %[[VAL_108]] : index
! CHECK:               %[[VAL_113:.*]] = fir.load %[[VAL_4]] : !fir.ref<i32>
! CHECK:               %[[VAL_114:.*]] = fir.convert %[[VAL_113]] : (i32) -> i64
! CHECK:               %[[VAL_115:.*]] = fir.convert %[[VAL_114]] : (i64) -> index
! CHECK:               %[[VAL_116:.*]] = arith.subi %[[VAL_115]], %[[VAL_108]] : index
! CHECK:               %[[VAL_117:.*]] = fir.array_fetch %[[VAL_86]], %[[VAL_112]], %[[VAL_116]] : (!fir.array<200x200xf32>, index, index) -> f32
! CHECK:               %[[VAL_118:.*]] = arith.divf %[[VAL_107]], %[[VAL_117]] : f32
! CHECK:               %[[VAL_119:.*]] = arith.constant 1 : index
! CHECK:               %[[VAL_120:.*]] = fir.load %[[VAL_4]] : !fir.ref<i32>
! CHECK:               %[[VAL_121:.*]] = fir.convert %[[VAL_120]] : (i32) -> i64
! CHECK:               %[[VAL_122:.*]] = fir.convert %[[VAL_121]] : (i64) -> index
! CHECK:               %[[VAL_123:.*]] = arith.subi %[[VAL_122]], %[[VAL_119]] : index
! CHECK:               %[[VAL_124:.*]] = arith.constant 200 : i32
! CHECK:               %[[VAL_125:.*]] = fir.load %[[VAL_3]] : !fir.ref<i32>
! CHECK:               %[[VAL_126:.*]] = arith.addi %[[VAL_124]], %[[VAL_125]] : i32
! CHECK:               %[[VAL_127:.*]] = fir.convert %[[VAL_126]] : (i32) -> i64
! CHECK:               %[[VAL_128:.*]] = fir.convert %[[VAL_127]] : (i64) -> index
! CHECK:               %[[VAL_129:.*]] = arith.subi %[[VAL_128]], %[[VAL_119]] : index
! CHECK:               %[[VAL_130:.*]] = fir.array_update %[[VAL_93]], %[[VAL_118]], %[[VAL_123]], %[[VAL_129]] : (!fir.array<100x400xf32>, f32, index, index) -> !fir.array<100x400xf32>
! CHECK:               fir.result %[[VAL_130]] : !fir.array<100x400xf32>
! CHECK:             } else {
! CHECK:               fir.result %[[VAL_93]] : !fir.array<100x400xf32>
! CHECK:             }
! CHECK:             fir.result %[[VAL_131:.*]] : !fir.array<100x400xf32>
! CHECK:           }
! CHECK:           fir.result %[[VAL_132:.*]] : !fir.array<100x400xf32>
! CHECK:         }
! CHECK:         fir.array_merge_store %[[VAL_84]], %[[VAL_133:.*]] to %[[VAL_0]] : !fir.array<100x400xf32>, !fir.array<100x400xf32>, !fir.ref<!fir.array<100x400xf32>>
! CHECK:         return
! CHECK:       }

max_stars_repo_name: akashhansda/llvm-project

max_issues_repo_name: akashhansda/llvm-project

max_forks_repo_name: akashhansda/llvm-project


text: #redirect Emerson Junior High School

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


! { dg-do run }
! PR61640 KIND=4 Character Array Internal Unit Read Fail
program read_internal
  integer :: x(9),i
  integer :: y(9)
  character(kind=4,len=30), dimension(3) :: source

  y = reshape ((/ 1,1,-1,1,-1,1,-1,1,1 /), shape(x))
  source=[4_"  1   1  -1",4_"  1  -1   1",4_" -1   1   1"]
  !print *, (trim(source(i)), i=1,3)
  read(source,*) (x(i), i=1,9) ! This read fails for KIND=4 character
  if (any(x /= y )) call abort
end program read_internal


text:
      SUBROUTINE PHO_QELAST(Iproc,Jm1,Jm2,Irej)
C**********************************************************************
C
C     sampling of quasi elastic processes
C
C     input:   IPROC  2   purely elastic scattering
C              IPROC  3   q-ela. omega/omega/phi/pi+pi- production
C              IPROC  4   double pomeron scattering
C              IPROC  -1  initialization
C              IPROC  -2  output of statistics
C              JM1/2      index of initial particle 1/2
C
C     output:  initial and final particles in /POEVT1/ involving
C              polarized resonances in /POEVT1/ and decay
C              products
C
C              IREJ    0  successful
C                      1  failure
C                     50  user rejection
C
C**********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION am12 , am22 , anorf , DEPS , DT_RNDM , EPS ,
     &                 PHO_PMASS , PHO_XLAM , PIMASS , ptot1 , slwght ,
     &                 ss , tt , xi
      INTEGER i , i1 , i2 , icall , icpos , idpro , ifl , igen , ipos ,
     &        Iproc , Irej , isamel , isamqe , isamvm , isp , itry , j ,
     &        Jm1 , Jm2 , k
      INTEGER NTAB
      SAVE

      PARAMETER (NTAB=20,EPS=1.D-10,PIMASS=0.13D0,DEPS=1.D-10)

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  global event kinematics and particle IDs
      INCLUDE 'inc/pogcms'
C  c.m. kinematics of diffraction
      INCLUDE 'inc/podcms'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  some constants
      INCLUDE 'inc/pocons'
C  cross sections
      INCLUDE 'inc/pocsec'

C  standard particle data interface

      INCLUDE 'inc/poevt1'
C  extension to standard particle data interface (PHOJET specific)
      INCLUDE 'inc/poevt2'

      DOUBLE PRECISION p , pk1 , pk2 , pmi , rmass
      DIMENSION p(4,2) , pk1(5) , pk2(5) , pmi(2) , rmass(2)
      DIMENSION ifl(2) , idpro(4)
      CHARACTER*15 PHO_PNAME
      CHARACTER*8 vmesa(0:4) , vmesb(0:4)
      DIMENSION isamvm(4,4)
      DATA idpro/113 , 223 , 333 , 92/
      DATA vmesa/'vmeson  ' , 'rho     ' , 'omega   ' , 'phi     ' ,
     &     'pi+pi-  '/
      DATA vmesb/'vmeson  ' , 'rho     ' , 'omega   ' , 'phi     ' ,
     &     'pi+pi-  '/

C  sampling of elastic/quasi-elastic processes
      IF ( (Iproc.EQ.2) .OR. (Iproc.EQ.3) ) THEN
         Irej = 0
         NPOsd(1) = Jm1
         NPOsd(2) = Jm2
         DO i = 1 , 2
            pmi(i) = PHEp(5,NPOsd(i))
            IF ( pmi(i).LT.0.1D0 ) pmi(i) = 0.765D0
         END DO
C  get CM system
         pk1(1) = PHEp(1,Jm1) + PHEp(1,Jm2)
         pk1(2) = PHEp(2,Jm1) + PHEp(2,Jm2)
         pk1(3) = PHEp(3,Jm1) + PHEp(3,Jm2)
         pk1(4) = PHEp(4,Jm1) + PHEp(4,Jm2)
         ss = (pk1(4)+pk1(3))*(pk1(4)-pk1(3)) - pk1(1)**2 - pk1(2)**2
         ECMd = SQRT(ss)

         IF ( ECMd.LE.pmi(1)+pmi(2) ) THEN
            IF ( LPRi.GT.4 .AND. IDEb(34).GE.3 )
     &            WRITE (LO,'(1X,A,I12,3E12.4)')
     &            'PHO_QELAST: too small mass (EV,ECM,M1,M2)' , KEVent ,
     &           ECMd , pmi
            Irej = 5
            RETURN
         END IF

         DO i = 1 , 4
            GAMbed(i) = pk1(i)/ECMd
         END DO
         CALL PHO_ALTRA(GAMbed(4),-GAMbed(1),-GAMbed(2),-GAMbed(3),
     &                  PHEp(1,NPOsd(1)),PHEp(2,NPOsd(1)),
     &                  PHEp(3,NPOsd(1)),PHEp(4,NPOsd(1)),ptot1,pk1(1),
     &                  pk1(2),pk1(3),pk1(4))
C  rotation angles
         CODd = pk1(3)/ptot1
         SIDd = SQRT(pk1(1)**2+pk1(2)**2)/ptot1
         COFd = 1.D0
         SIFd = 0.D0
         IF ( ptot1*SIDd.GT.1.D-5 ) THEN
            COFd = pk1(1)/(SIDd*ptot1)
            SIFd = pk1(2)/(SIDd*ptot1)
            anorf = SQRT(COFd*COFd+SIFd*SIFd)
            COFd = COFd/anorf
            SIFd = SIFd/anorf
         END IF
C  get CM momentum
         am12 = pmi(1)**2
         am22 = pmi(2)**2
         PCMd = PHO_XLAM(ss,am12,am22)/(2.D0*ECMd)

C  production process of mother particles
         igen = IPHist(2,NPOsd(1))
         IF ( igen.EQ.0 ) igen = Iproc

         icall = icall + 1
C  main rejection label
C  determine process and final particles
 50      ifl(1) = IDHep(NPOsd(1))
         ifl(2) = IDHep(NPOsd(2))
         IF ( Iproc.EQ.3 ) THEN
            itry = 0
 60         itry = itry + 1
            IF ( itry.GT.50 ) THEN
               IF ( LPRi.GT.4 .AND. IDEb(34).GE.3 )
     &               WRITE (LO,'(1X,A,I12,I5,E12.4)')
     &               'PHO_QELAST: mass rejection (EV,ITRY,ECM)' ,
     &              KEVent , itry , ECMd
               Irej = 5
               RETURN
            END IF
            xi = DT_RNDM(PCMd)*SIGvm(0,0) - DEPS
            DO i = 1 , 4
               DO j = 1 , 4
                  xi = xi - SIGvm(i,j)
                  IF ( xi.LE.0.D0 ) GOTO 80
               END DO
            END DO
 80         IF ( ifl(1).EQ.22 ) ifl(1) = idpro(i)
            IF ( ifl(2).EQ.22 ) ifl(2) = idpro(j)
            isamvm(i,j) = isamvm(i,j) + 1
            isamqe = isamqe + 1
C  sample new masses
            CALL PHO_SAMASS(ifl(1),rmass(1))
            CALL PHO_SAMASS(ifl(2),rmass(2))
            IF ( rmass(1)+rmass(2).GE.ECMd ) GOTO 60
         ELSE IF ( Iproc.EQ.2 ) THEN
            i = 0
            j = 0
            isamel = isamel + 1
            rmass(1) = PHO_PMASS(NPOsd(1),2)
            rmass(2) = PHO_PMASS(NPOsd(2),2)
         ELSE
            IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,I6)')
     &            'PHO_QELAST:ERROR: invalid IPROC' , Iproc
            CALL PHO_ABORT
         END IF
C  sample momentum transfer
         CALL PHO_DIFSLP(0,0,i,j,rmass(1),rmass(2),rmass(1),tt,slwght,
     &                   Irej)
C  calculate new momenta
         IF ( LPRi.GT.4 .AND. IDEb(34).GE.5 )
     &         WRITE (LO,'(1X,A,2I6,I3,3E11.3)')
     &         'PHO_QELAST: IF1,2,T,RM1,RM2' , ifl , Iproc , tt , rmass
         CALL PHO_DIFKIN(rmass(1),rmass(2),tt,pk1,pk2,Irej)
         IF ( Irej.NE.0 ) GOTO 50
         DO k = 1 , 4
            p(k,1) = pk1(k)
            p(k,2) = pk2(k)
         END DO
C  comment line for elastic/quasi-elastic scattering
         CALL PHO_REGPAR(35,Iproc,0,NPOsd(1),NPOsd(2),rmass(1),rmass(2),
     &                   tt,ECMd,ifl(1),ifl(2),IDHep(NPOsd(1)),
     &                   IDHep(NPOsd(2)),icpos,1)

         i1 = NHEp + 1
C  fill /POEVT1/
         DO i = 1 , 2
            k = 3 - i
            IF ( (ifl(i).EQ.92) .OR. (ifl(i).EQ.91) ) THEN
C  pi+/pi- isotropic background
               igen = 3
               CALL PHO_REGPAR(1,113,0,NPOsd(i),NPOsd(k),p(1,i),p(2,i),
     &            p(3,i),p(4,i),0,igen,0,0,ipos,1)
               ICOlor(i,icpos) = ipos
               CALL PHO_SDECAY(ipos,0,-2)
            ELSE
C  registration
               igen = 2
               IF ( ifl(i).NE.IDHep(NPOsd(i)) ) igen = 3
               CALL PHO_REGPAR(1,ifl(i),0,NPOsd(i),NPOsd(k),p(1,i),
     &            p(2,i),p(3,i),p(4,i),0,igen,0,0,ipos,1)
               ICOlor(i,icpos) = ipos
            END IF
         END DO
         i2 = NHEp
C  search for vector mesons
         DO i = i1 , i2
C  decay according to polarization
            IF ( (IDHep(JMOhep(1,i)).EQ.22) .AND. (ISWmdl(21).GE.0) )
     &           THEN
               isp = IPAmdl(3)
               IF ( ISWmdl(21).GE.1 ) isp = IPAmdl(4)
               CALL PHO_SDECAY(i,isp,2)
            END IF
         END DO
         i2 = NHEp
C  back transformation
         CALL PHO_LTRHEP(i1,i2,CODd,SIDd,COFd,SIFd,GAMbed(4),GAMbed(1),
     &                   GAMbed(2),GAMbed(3))

C  initialization of tables
      ELSE IF ( Iproc.EQ.-1 ) THEN
         DO i = 1 , 4
            DO j = 1 , 4
               isamvm(i,j) = 0
            END DO
         END DO
         isamel = 0
         isamqe = 0
         IF ( IFPap(1).NE.22 ) vmesa(1) = PHO_PNAME(IFPap(1),1)
         IF ( IFPap(2).NE.22 ) vmesb(1) = PHO_PNAME(IFPap(2),1)
         CALL PHO_SAMASS(-1,rmass(1))
         icall = 0

C  output of statistics
      ELSE IF ( Iproc.EQ.-2 ) THEN
         IF ( icall.LT.10 ) RETURN
         IF ( LPRi.GT.4 ) WRITE (LO,'(/,1X,A,I10/,1X,A)')
     &         'PHO_QELAST: statistics of (quasi-)elastic processes' ,
     &        icall ,
     &        '---------------------------------------------------'
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I10)')
     &         'sampled elastic processes:' , isamel
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I10)')
     &         'sampled quasi-elastic vectormeson production:' , isamqe
         IF ( LPRi.GT.4 ) WRITE (LO,'(15X,4(4X,A))') (vmesb(i),i=1,4)
         DO i = 1 , 4
            IF ( LPRi.GT.4 ) WRITE (LO,'(5X,A,4I12)') vmesa(i) ,
     &           (isamvm(i,k),k=1,4)
         END DO
         CALL PHO_SAMASS(-2,rmass(1))
      ELSE
         IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,2A,I3)')
     &        'PHO_QELAST:ERROR: ' , 'unknown process ID' , Iproc
         CALL PHO_ABORT
      END IF

      END SUBROUTINE

max_stars_repo_name: pzhristov/DPMJET

max_issues_repo_name: pzhristov/DPMJET

max_forks_repo_name: pzhristov/DPMJET


text:
        subroutine read_data(indmail,nx,ny,nz)
        integer indmail(nx,ny,nz)
        OPEN(UNIT=1,FILE='avs/model.val',FORM='UNFORMATTED')
        READ(1)INDMAIL
        CLOSE(1)
        END
        subroutine write_file_data(xi,yi,zi,indmail,nx,ny,nz)
        integer indmail(nx,ny,nz)
        real xi(nx),yi(ny),zi(nz)
        OPEN(UNIT=1,FILE='verif.val',FORM='UNFORMATTED')
        WRITE(1)XI
        WRITE(1)YI
        WRITE(1)ZI
        WRITE(1)INDMAIL
        CLOSE(1)
        END
        subroutine read_data_2(indmail,nx,ny,nz)
        integer indmail(nx,ny,nz)
        real xi(nx),yi(ny),zi(nz)
        OPEN(UNIT=1,FILE='verif.val',FORM='UNFORMATTED')
        READ(1)XI
        READ(1)YI
        READ(1)ZI
        READ(1)INDMAIL
        CLOSE(1)
        END
        subroutine write_file_data_2(xi,yi,zi,indmail,nx,ny,nz)
        integer indmail(nx,ny,nz)
        real xi(nx),yi(ny),zi(nz)
        OPEN(UNIT=1,FILE='verif2.val',FORM='UNFORMATTED')
        WRITE(1)XI
        WRITE(1)YI
        WRITE(1)ZI
        WRITE(1)INDMAIL
        CLOSE(1)
        END

max_stars_repo_name: cea-trust-platform/trust-code

max_issues_repo_name: pledac/trust-code

max_forks_repo_name: pledac/trust-code


text:
!
! Copyright (C) 2001-2009 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!=---------------------------------------------------------------------==!
!
!
!     Parallel 3D FFT high level Driver
!     ( Charge density and Wave Functions )
!
!     Written and maintained by Carlo Cavazzoni
!     Last update Apr. 2009
!
!=---------------------------------------------------------------------==!
!
MODULE fft_parallel
!
   IMPLICIT NONE
   SAVE
!
CONTAINS
!
!  General purpose driver, including Task groups parallelization
!
!----------------------------------------------------------------------------
SUBROUTINE tg_cft3s( f, dfft, isgn, use_task_groups )
  !----------------------------------------------------------------------------
  !
  ! ... isgn = +-1 : parallel 3d fft for rho and for the potential
  !                  NOT IMPLEMENTED WITH TASK GROUPS
  ! ... isgn = +-2 : parallel 3d fft for wavefunctions
  !
  ! ... isgn = +   : G-space to R-space, output = \sum_G f(G)exp(+iG*R)
  ! ...              fft along z using pencils        (cft_1z)
  ! ...              transpose across nodes           (fft_scatter)
  ! ...                 and reorder
  ! ...              fft along y (using planes) and x (cft_2xy)
  ! ... isgn = -   : R-space to G-space, output = \int_R f(R)exp(-iG*R)/Omega
  ! ...              fft along x and y(using planes)  (cft_2xy)
  ! ...              transpose across nodes           (fft_scatter)
  ! ...                 and reorder
  ! ...              fft along z using pencils        (cft_1z)
  !
  ! ...  The array "planes" signals whether a fft is needed along y :
  ! ...    planes(i)=0 : column f(i,*,*) empty , don't do fft along y
  ! ...    planes(i)=1 : column f(i,*,*) filled, fft along y needed
  ! ...  "empty" = no active components are present in f(i,*,*)
  ! ...            after (isgn>0) or before (isgn<0) the fft on z direction
  !
  ! ...  Note that if isgn=+/-1 (fft on rho and pot.) all fft's are needed
  ! ...  and all planes(i) are set to 1
  !
  ! This driver is based on code written by Stefano de Gironcoli for PWSCF.
  ! Task Group added by Costas Bekas, Oct. 2005, adapted from the CPMD code
  ! (Alessandro Curioni) and revised by Carlo Cavazzoni 2007.
  !
  USE fft_scalar, ONLY : cft_1z, cft_2xy
  USE fft_base,   ONLY : fft_scatter
  USE kinds,      ONLY : DP
  USE fft_types,  ONLY : fft_dlay_descriptor
  USE parallel_include

  !
  IMPLICIT NONE
  !
  COMPLEX(DP), INTENT(inout)    :: f( : )  ! array containing data to be transformed
  TYPE (fft_dlay_descriptor), INTENT(in) :: dfft
                                           ! descriptor of fft data layout
  INTEGER, INTENT(in)           :: isgn    ! fft direction
  LOGICAL, OPTIONAL, INTENT(in) :: use_task_groups
                                           ! specify if you want to use task groups parallelization
  !
  INTEGER                    :: me_p
  INTEGER                    :: n1, n2, n3, nx1, nx2, nx3
  COMPLEX(DP), ALLOCATABLE   :: yf(:), aux (:)
  INTEGER                    :: planes( dfft%nr1x )
  LOGICAL                    :: use_tg
  !
  !
  IF( present( use_task_groups ) ) THEN
     use_tg = use_task_groups
  ELSE
     use_tg = .false.
  ENDIF
  !
  IF( use_tg .and. .not. dfft%have_task_groups ) &
     CALL errore( ' tg_cft3s ', ' call requiring task groups for a descriptor without task groups ', 1 )
  !
  n1  = dfft%nr1
  n2  = dfft%nr2
  n3  = dfft%nr3
  nx1 = dfft%nr1x
  nx2 = dfft%nr2x
  nx3 = dfft%nr3x
  !
  IF( use_tg ) THEN
     ALLOCATE( aux( dfft%nogrp * dfft%tg_nnr ) )
     ALLOCATE( YF ( dfft%nogrp * dfft%tg_nnr ) )
  ELSE
     ALLOCATE( aux( dfft%tg_nnr ) )
  ENDIF
  !
  me_p = dfft%mype + 1
  !
  IF ( isgn > 0 ) THEN
     !
     IF ( isgn /= 2 ) THEN
        !
        IF( use_tg ) &
           CALL errore( ' tg_cfft ', ' task groups on large mesh not implemented ', 1 )
        !
        CALL cft_1z( f, dfft%nsp( me_p ), n3, nx3, isgn, aux )
        !
        planes = dfft%iplp
        !
     ELSE
        !
        CALL pack_group_sticks()
        !
        IF( use_tg ) THEN
           CALL cft_1z( yf, dfft%tg_nsw( me_p ), n3, nx3, isgn, aux )
        ELSE
           CALL cft_1z( f, dfft%nsw( me_p ), n3, nx3, isgn, aux )
        ENDIF
        !
        planes = dfft%iplw
        !
     ENDIF
     !
     CALL fw_scatter( isgn ) ! forwart scatter from stick to planes
     !
     IF( use_tg ) THEN
        CALL cft_2xy( f, dfft%tg_npp( me_p ), n1, n2, nx1, nx2, isgn, planes )
     ELSE
        CALL cft_2xy( f, dfft%npp( me_p ), n1, n2, nx1, nx2, isgn, planes )
     ENDIF
     !
  ELSE
     !
     IF ( isgn /= -2 ) THEN
        !
        IF( use_tg ) &
           CALL errore( ' tg_cfft ', ' task groups on large mesh not implemented ', 1 )
        !
        planes = dfft%iplp
        !
     ELSE
        !
        planes = dfft%iplw
        !
     ENDIF

     IF( use_tg ) THEN
        CALL cft_2xy( f, dfft%tg_npp( me_p ), n1, n2, nx1, nx2, isgn, planes )
     ELSE
        CALL cft_2xy( f, dfft%npp( me_p ), n1, n2, nx1, nx2, isgn, planes)
     ENDIF
     !
     CALL bw_scatter( isgn )
     !
     IF ( isgn /= -2 ) THEN
        !
        CALL cft_1z( aux, dfft%nsp( me_p ), n3, nx3, isgn, f )
         !
     ELSE
        !
        IF( use_tg ) THEN
           CALL cft_1z( aux, dfft%tg_nsw( me_p ), n3, nx3, isgn, yf )
        ELSE
           CALL cft_1z( aux, dfft%nsw( me_p ), n3, nx3, isgn, f )
        ENDIF
        !
        CALL unpack_group_sticks()
        !
     ENDIF
     !
  ENDIF
  !
  DEALLOCATE( aux )
  !
  IF( use_tg ) THEN
     DEALLOCATE( yf )
  ENDIF
  !
  RETURN
  !
CONTAINS
  !

  SUBROUTINE pack_group_sticks()

     INTEGER                     :: ierr
     !
     IF( .not. use_tg ) RETURN
     !
     IF( dfft%tg_rdsp(dfft%nogrp) + dfft%tg_rcv(dfft%nogrp) > size( yf ) ) THEN
        CALL errore( ' tg_cfft ', ' inconsistent size ', 1 )
     ENDIF
     IF( dfft%tg_psdsp(dfft%nogrp) + dfft%tg_snd(dfft%nogrp) > size( f ) ) THEN
        CALL errore( ' tg_cfft ', ' inconsistent size ', 2 )
     ENDIF

     CALL start_clock( 'ALLTOALL' )
     !
     !  Collect all the sticks of the different states,
     !  in "yf" processors will have all the sticks of the OGRP

     CALL MPI_ALLTOALLV( f(1), dfft%tg_snd, dfft%tg_psdsp, MPI_DOUBLE_COMPLEX, yf(1), dfft%tg_rcv, &
      &                     dfft%tg_rdsp, MPI_DOUBLE_COMPLEX, dfft%ogrp_comm, IERR)
     IF( ierr /= 0 ) THEN
        CALL errore( ' tg_cfft ', ' alltoall error 1 ', abs(ierr) )
     ENDIF

     CALL stop_clock( 'ALLTOALL' )
     !
     !YF Contains all ( ~ NOGRP*dfft%nsw(me) ) Z-sticks
     !
     RETURN
  END SUBROUTINE pack_group_sticks

  !

  SUBROUTINE unpack_group_sticks()
     !
     !  Bring pencils back to their original distribution
     !
     INTEGER                     :: ierr
     !
     IF( .not. use_tg ) RETURN
     !
     IF( dfft%tg_usdsp(dfft%nogrp) + dfft%tg_snd(dfft%nogrp) > size( f ) ) THEN
        CALL errore( ' tg_cfft ', ' inconsistent size ', 3 )
     ENDIF
     IF( dfft%tg_rdsp(dfft%nogrp) + dfft%tg_rcv(dfft%nogrp) > size( yf ) ) THEN
        CALL errore( ' tg_cfft ', ' inconsistent size ', 4 )
     ENDIF

     CALL start_clock( 'ALLTOALL' )

     CALL MPI_Alltoallv( yf(1), &
          dfft%tg_rcv, dfft%tg_rdsp, MPI_DOUBLE_COMPLEX, f(1), &
          dfft%tg_snd, dfft%tg_usdsp, MPI_DOUBLE_COMPLEX, dfft%ogrp_comm, IERR)
     IF( ierr /= 0 ) THEN
        CALL errore( ' tg_cfft ', ' alltoall error 2 ', abs(ierr) )
     ENDIF

     CALL stop_clock( 'ALLTOALL' )

     RETURN
  END SUBROUTINE unpack_group_sticks

  !

  SUBROUTINE fw_scatter( iopt )

        !Transpose data for the 2-D FFT on the x-y plane
        !
        !NOGRP*dfft%nnr: The length of aux and f
        !nr3x: The length of each Z-stick
        !aux: input - output
        !f: working space
        !isgn: type of scatter
        !dfft%nsw(me) holds the number of Z-sticks proc. me has.
        !dfft%npp: number of planes per processor
        !
     !
     USE fft_base, ONLY: fft_scatter
     !
     INTEGER, INTENT(in) :: iopt
     !
     IF( iopt == 2 ) THEN
        !
        IF( use_tg ) THEN
           !
           CALL fft_scatter( dfft, aux, nx3, dfft%nogrp*dfft%tg_nnr, f, dfft%tg_nsw, dfft%tg_npp, iopt, use_tg )
           !
        ELSE
           !
           CALL fft_scatter( dfft, aux, nx3, dfft%nnr, f, dfft%nsw, dfft%npp, iopt )
           !
        ENDIF
        !
     ELSEIF( iopt == 1 ) THEN
        !
        CALL fft_scatter( dfft, aux, nx3, dfft%nnr, f, dfft%nsp, dfft%npp, iopt )
        !
     ENDIF
     !
     RETURN
  END SUBROUTINE fw_scatter

  !

  SUBROUTINE bw_scatter( iopt )
     !
     USE fft_base, ONLY: fft_scatter
     !
     INTEGER, INTENT(in) :: iopt
     !
     IF( iopt == -2 ) THEN
        !
        IF( use_tg ) THEN
           !
           CALL fft_scatter( dfft, aux, nx3, dfft%nogrp*dfft%tg_nnr, f, dfft%tg_nsw, dfft%tg_npp, iopt, use_tg )
           !
        ELSE
           !
           CALL fft_scatter( dfft, aux, nx3, dfft%nnr, f, dfft%nsw, dfft%npp, iopt )
           !
        ENDIF
        !
     ELSEIF( iopt == -1 ) THEN
        !
        CALL fft_scatter( dfft, aux, nx3, dfft%nnr, f, dfft%nsp, dfft%npp, iopt )
        !
     ENDIF
     !
     RETURN
  END SUBROUTINE bw_scatter
  !
END SUBROUTINE tg_cft3s
!
END MODULE fft_parallel

max_stars_repo_name: utdsimmons/ohpc

max_issues_repo_name: utdsimmons/ohpc

max_forks_repo_name: utdsimmons/ohpc


text: The Bathtub Experiment was performed on The Quad on May 18, 2007 from 1 p.m. sharp until 3 p.m. as a project piece for Professor Jon Rossinis Drama 159 Experimental Theatre class. Involved was a porcelain bathtub weighing 300 lbs. independently of the approximate 7580 gallons of water it held. Users/EliseKane conceived of and performed in the piece with her friend and classmate RebeccaGeorge.


text:
program facbench
  use fmzm
  implicit none

  integer :: i
  type(im) :: res
  character(10000) :: out

  res = 0
  do i = 1, 3000
     res = res + fac(i)
  end do

  call im_form('i10000', res, out)
  print '(a)', trim(adjustl(out))

contains

  type(im) function fac(n)
    integer, intent(in) :: n
    integer :: i

    fac = 1
    do i = 1, n
       fac = fac * i
    end do
  end function fac

end program facbench

max_stars_repo_name: robindaumann/fac-bench

max_issues_repo_name: robindaumann/fac-bench

max_forks_repo_name: robindaumann/fac-bench


text:
MODULE m_vxcepbe
!.....-----------------------------------------------------------------
!.....epbe(easy_pbe) exchange-correlation potential in hartree.
!     vxcepbe - easypbe
!.....------------------------------------------------------------------
CONTAINS
   SUBROUTINE vxcepbe( &
      xcpot,jspins,mirm,irmx, &
      rh,agr,agru,agrd, &
      g2ru,g2rd,gggr,gggru,gggrd, &
      vx,vxc)

      Use m_easypbe
      USE m_types_xcpot_data

      IMPLICIT NONE

! .. Arguments ..
      TYPE(t_xcpot_data),INTENT(IN)::xcpot
      INTEGER, INTENT (IN) :: irmx,jspins,mirm
      REAL,    INTENT (IN) :: rh(mirm,jspins)
      REAL,    INTENT (IN) :: agr(mirm),agru(mirm),agrd(mirm)
      REAL,    INTENT (IN) :: g2ru(mirm),g2rd(mirm),gggr(mirm)
      REAL,    INTENT (IN) :: gggru(mirm),gggrd(mirm)
      REAL,    INTENT (OUT):: vx(mirm,jspins),vxc(mirm,jspins)

! .. local variables ..
      INTEGER :: lcor,lpot,i
      REAL :: ro,rou,rod,xcptu,xcptd, &
              vxlu,vclu,vxld,vcld,vxgu,vcgu,vxgd,vcgd
      REAL :: up,agrup,delgrup,uplap,dn,agrdn,delgrdn,dnlap, &
              agrt,delgrt, &
              exlsd,vxuplsd,vxdnlsd,eclsd,vcuplsd,vcdnlsd, &
              expbe,vxuppbe,vxdnpbe,ecpbe,vcuppbe,vcdnpbe, &
              vxupsr,vxdnsr

      REAL, PARAMETER :: sml = 1.e-14
      REAL, PARAMETER :: smlc = 2.01e-14
      LOGICAL         :: l_hse
      l_hse=(xcpot%is_hse)

!$OMP PARALLEL DO DEFAULT(none) &
!$OMP SHARED(irmx,rh,xcpot,jspins,l_hse) &
!$OMP SHARED(agr,agru,agrd,g2ru,g2rd,gggr,gggru,gggrd) &
!$OMP SHARED(vx,vxc) &
!$OMP PRIVATE(rou,rod,vxlu,vclu,vxld,vcld,vxgu,vcgu,vxgd,vcgd) &
!$OMP PRIVATE(vxupsr,vxdnsr,ro,lcor,lpot,up,agrup,delgrup) &
!$OMP PRIVATE(uplap,dn,agrdn,delgrdn,dnlap,agrt,delgrt) &
!$OMP PRIVATE(exlsd,vxuplsd,vxdnlsd,eclsd,vcuplsd,vcdnlsd) &
!$OMP PRIVATE(expbe,vxuppbe,vxdnpbe,ecpbe,vcuppbe,vcdnpbe) &
!$OMP PRIVATE(xcptu,xcptd)
      DO i = 1,irmx

         IF (jspins == 1) THEN
            rou=rh(i,1)/2
            rou=max(rou,sml)
            rod=rou
         ELSE
            rou=rh(i,1)
            rod=rh(i,jspins)
            rou=max(rou,sml)
            rod=max(rod,sml)
         ENDIF

         !.....
         !       vxlu,vxld,vxgu,vxgd: exchange potential in ry.(local,grad),
         !c        (up,dw).
         !       vclu,vcld,vcgu,vcgd: correl. potential in ry.(local,grad),
         !c        (up,dw).
         !       all later in hartree.
         !.....
         vxlu   = 0.0e0
         vclu   = 0.0e0
         vxld   = 0.0e0
         vcld   = 0.0e0
         vxgu   = 0.0e0
         vcgu   = 0.0e0
         vxgd   = 0.0e0
         vcgd   = 0.0e0
         vxupsr = 0.0e0
         vxdnsr = 0.0e0

         !.....
         ro=rou+rod

         IF (ro > smlc) THEN

            lcor    = 1
            lpot    = 1
            up      = rou
            agrup   = agru(i)
            delgrup = gggru(i)
            uplap   = g2ru(i)
            dn      = rod
            agrdn   = agrd(i)
            delgrdn = gggrd(i)
            dnlap   = g2rd(i)
            agrt    = agr(i)
            delgrt  = gggr(i)

            CALL easypbe(xcpot, &
                         up,agrup,delgrup,uplap,dn,agrdn,delgrdn,dnlap, &
                         agrt,delgrt,lcor,lpot, &
                         exlsd,vxuplsd,vxdnlsd,eclsd,vcuplsd,vcdnlsd, &
                         expbe,vxuppbe,vxdnpbe,ecpbe,vcuppbe,vcdnpbe, &
                         vxupsr,vxdnsr)

            vxlu=vxuplsd
            vclu=vcuplsd
            vxgu=vxuppbe-vxuplsd
            vcgu=vcuppbe-vcuplsd

            vxld=vxdnlsd
            vcld=vcdnlsd
            vxgd=vxdnpbe-vxdnlsd
            vcgd=vcdnpbe-vcdnlsd

         END IF ! ro > smlc

         xcptu = vxlu + vclu + vxgu + vcgu
         xcptd = vxld + vcld + vxgd + vcgd

         IF (l_hse)then
            vx(i,1)       = vxupsr * 2
            vx(i,jspins)  = vxdnsr * 2
         ELSE
            vx(i,1)       = (vxlu + vxgu)*2
            vx(i,jspins)  = (vxld + vxgd)*2
         END IF

         vxc(i,1)      = xcptu*2    ! transform to Ry, will be converted
         vxc(i,jspins) = xcptd*2    ! back to htr in calling routine

      END DO
!$OMP END PARALLEL DO

   END SUBROUTINE vxcepbe
END MODULE m_vxcepbe

max_stars_repo_name: MRedies/FLEUR

max_issues_repo_name: MRedies/FLEUR

max_forks_repo_name: MRedies/FLEUR


text:
      subroutine vgcap_fit3(iflg,slr,slm,slcut,smcut,fac,alpha
     &                     ,alamda,c1,c2,c3,c4,hmin)
!*************************************************************************
! Copyright  2015.   Los Alamos National Security, LLC.  This material was
! produced under U.S. Government contract DE-AC52-06NA25396 for Los Alamos
! National  Laboratory  (LANL),  which is operated by  Los Alamos National
! Security, LLC  for the U. S. Department of Energy.  The U. S. Government
! has rights to use, reproduce, and distribute this software.  Neither the
! U. S. Government nor Los Alamos National Security, LLC or persons acting
! on their behalf,  make any warranty,  express or implied, or assumes any
! liability for the accuracy, completeness, or usefulness of the software,
! any information pertaining to the software,  or  represents that its use
! would not infringe privately owned rights.

! The  software  being licensed  may  be Export Controlled.  It may not be
! distributed  or  used by individuals  or entities prohibited from having
! access to the software package, pursuant to United States export control
! laws and regulations. An export control review and determination must be
! completed before LANS will provide access to the identified Software.
!*************************************************************************

      implicit none

      integer iflg,ncut
      real*8 slr,slm,slcut,alpha,alamda,c1,c2,c3,c4
      real*8 hmax,hmin,hcut,smcut,alpi,ds,dhp,slope
      real*8 fac,fac_min,fac_use,hcut2,smcut2,ancut
      parameter(fac_min=2.0,ncut = 1)
		c1=0.;c2=0.;c3=0.;c4=0.
      if(iflg.eq.0) then
       if(fac.eq.0.0) then
c zero slope, zero curvature at sl=0
c h = a*x**3 + d
c this is most common fehm way
            alpi = 1.0/alamda
            hcut = 1.0/alpha*(1.0/smcut**alpi-1.0)**(1.0-alamda)
            ds = 1.0/(slm-slr)
            dhp = 1.0/alpha*(1.0-alamda)/
     *              (1.0/smcut**alpi-1.0)**alamda
     *              *(-alpi/smcut**(alpi+1.0))*ds
            fac=1.0/3.0
       		hmax=hcut-fac*dhp*slcut
       		c1=dhp/(3.0*slcut**2)
       		c2=0.0
       		c3=0.0
       		c4=hmax
       else if(fac.gt.0.0) then
c linear fit from slcut to sl=0.0
c with hmax=fac*hcut
            fac_use=max(fac,fac_min)
            alpi = 1.0/alamda
            hcut = 1.0/alpha*(1.0/smcut**alpi-1.0)**(1.0-alamda)
       		hmax=fac_use*hcut
       		slope=-(hmax-hcut)/slcut
       		c3=slope
       		c4=hmax

       else
c linear fit from slcut to sl=0.0
c with hmax: linear extension of slope at slcut
            alpi = 1.0/alamda
            hcut = 1.0/alpha*(1.0/smcut**alpi-1.0)**(1.0-alamda)
            ds = 1.0/(slm-slr)
            dhp = 1.0/alpha*(1.0-alamda)/
     *              (1.0/smcut**alpi-1.0)**alamda
     *              *(-alpi/smcut**(alpi+1.0))*ds
       		hmax=hcut-dhp*slcut
       		slope=-(hmax-hcut)/slcut
       		c3=slope
       		c4=hmax
      endif
      elseif(iflg.eq.4) then
c linear fit from smcut to star= 1.00
c with hmax: linear extension of slope at slcut
            alpi = 1.0/alamda
            hcut = 1.0/alpha*(1.0/smcut**alpi-1.0)**(1.0-alamda)
       slope=(hcut-hmin)/(1.0-slcut)
       c3=-slope
       c4=slope+hmin
       ancut = (1./slcut**ncut-1.0)
       c3 = hcut/ancut
       c4 = -c3 + hmin
      continue
      endif
      return
      end

max_stars_repo_name: satkarra/FEHM

max_issues_repo_name: satkarra/FEHM

max_forks_repo_name: satkarra/FEHM


text:
*> \brief \b ZGEQRT
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEQRT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER INFO, LDA, LDT, M, N, NB
*       ..
*       .. Array Arguments ..
*       COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZGEQRT computes a blocked QR factorization of a complex M-by-N matrix A
*> using the compact WY representation of Q.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*>          NB is INTEGER
*>          The block size to be used in the blocked QR.  MIN(M,N) >= NB >= 1.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,N)
*>          On entry, the M-by-N matrix A.
*>          On exit, the elements on and above the diagonal of the array
*>          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
*>          upper triangular if M >= N); the elements below the diagonal
*>          are the columns of V.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*>          T is COMPLEX*16 array, dimension (LDT,MIN(M,N))
*>          The upper triangular block reflectors stored in compact form
*>          as a sequence of upper triangular blocks.  See below
*>          for further details.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*>          LDT is INTEGER
*>          The leading dimension of the array T.  LDT >= NB.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension (NB*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The matrix V stores the elementary reflectors H(i) in the i-th column
*>  below the diagonal. For example, if M=5 and N=3, the matrix V is
*>
*>               V = (  1       )
*>                   ( v1  1    )
*>                   ( v1 v2  1 )
*>                   ( v1 v2 v3 )
*>                   ( v1 v2 v3 )
*>
*>  where the vi's represent the vectors which define H(i), which are returned
*>  in the matrix A.  The 1's along the diagonal of V are not stored in A.
*>
*>  Let K=MIN(M,N).  The number of blocks is B = ceiling(K/NB), where each
*>  block is of order NB except for the last block, which is of order
*>  IB = K - (B-1)*NB.  For each of the B blocks, a upper triangular block
*>  reflector factor is computed: T1, T2, ..., TB.  The NB-by-NB (and IB-by-IB
*>  for the last block) T's are stored in the NB-by-K matrix T as
*>
*>               T = (T1 T2 ... TB).
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE ZGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER INFO, LDA, LDT, M, N, NB
*     ..
*     .. Array Arguments ..
      COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * )
*     ..
*
* =====================================================================
*
*     ..
*     .. Local Scalars ..
      INTEGER    I, IB, IINFO, K
      LOGICAL    USE_RECURSIVE_QR
      PARAMETER( USE_RECURSIVE_QR=.TRUE. )
*     ..
*     .. External Subroutines ..
      EXTERNAL   ZGEQRT2, ZGEQRT3, ZLARFB, XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDT.LT.NB ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGEQRT', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      K = MIN( M, N )
      IF( K.EQ.0 ) RETURN
*
*     Blocked loop of length K
*
      DO I = 1, K,  NB
         IB = MIN( K-I+1, NB )
*
*     Compute the QR factorization of the current block A(I:M,I:I+IB-1)
*
         IF( USE_RECURSIVE_QR ) THEN
            CALL ZGEQRT3( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO )
         ELSE
            CALL ZGEQRT2( M-I+1, IB, A(I,I), LDA, T(1,I), LDT, IINFO )
         END IF
         IF( I+IB.LE.N ) THEN
*
*     Update by applying H**H to A(I:M,I+IB:N) from the left
*
            CALL ZLARFB( 'L', 'C', 'F', 'C', M-I+1, N-I-IB+1, IB,
     $                   A( I, I ), LDA, T( 1, I ), LDT,
     $                   A( I, I+IB ), LDA, WORK , N-I-IB+1 )
         END IF
      END DO
      RETURN
*
*     End of ZGEQRT
*
      END

max_stars_repo_name: sergey-v-kuznetsov/lapack

max_issues_repo_name: sergey-v-kuznetsov/lapack

max_forks_repo_name: sergey-v-kuznetsov/lapack


text:
c###setluf.for
      SUBROUTINE SETLUF
C--------------------------------
C.....THIS SUBROUTINE SETS THE LUF USING THE FREQUENCY COMPLEMENT AND
C.....COMPUTED RELIABILITIES. THESE VALUES ARE CHANGED IN SUBROUTINE
C.....GETLUF IF THE LUF IS ACTUALLY COMPUTED
C
      COMMON/FRQ/FREA(13),FREL(29),FREQ,JMODE,ITXRCP(2)
      COMMON / ION / IHRE, IHRO, IHRS, LUFP, METHOD, NOISE, NPSL
      COMMON / MUFS / EMUF(24), F1MUF(24), F2MUF(24), ESMUF(24),
     A ALLMUF(24), FOT(24), XLUF(24), HPF(24), ANGMUF(24), MODMUF,
     B SIGL(4), SIGU(4), DELMUF(4), HPMUF(4), HTMUF(4), FVMUF(4),
     C AFMUF(4), NHOPMF(4), YFOT(4), YHPF(4), YMUF(4)
      COMMON / SON / ANGLE(13), ANGLER(13), CPROB(13), DBLOS(13),
     A DBLOSL(13), DBLOSU(13), DBU(13), DELAY(13), DBW(13), NHP(13),
     B XNYNOIS(13), PROBMP(13), RELIAB(13), SNDB(13), SNPR(13),
     C SNRLW(13), SNRUP(13), SPROB(13), VHIGH(13), RNEFF(13),MDL(13)
       CHARACTER MDL*1
      COMMON / TIME / IT, GMT, UTIME(24), GMTR, XLMT(24), ITIM, JTX
C
      RF = FREL(1)
      REL = RELIAB(1)
      PLUF = LUFP
      PLUF = 0.01 * PLUF
      DO 200 IF = 1,11
      IF(FREL(IF)) 200, 200, 105
  105 IF(RELIAB(IF) - PLUF) 115, 110, 110
  110 XLUF(IT) = FREL(IF)
      FREL(13) = FREL(IF)
      GO TO 205
  115 IF(RELIAB(IF) - REL) 200, 200, 120
  120 REL = RELIAB(IF)
      RF = FREL(IF)
  200 CONTINUE
      XLUF(IT) = - RF
      FREL(13) = RF
  205 CONTINUE
      RETURN
      END
C--------------------------------

ext: for

max_stars_repo_name: jawatson/voacapl

max_issues_repo_name: jawatson/voacapl

max_forks_repo_name: jawatson/voacapl


           program demo_get_args_fixed_size
           use M_CLI2,  only : set_args, get_args_fixed_size
           implicit none
           integer,parameter   :: dp=kind(0.0d0)
           ! DEFINE ARGS
           real                :: x(2)
           real(kind=dp)       :: y(2)
           integer             :: p(3)
           character(len=80)   :: title(1)
           logical             :: l(4), lbig(4)
           complex             :: cmp(2)
           ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
           !   o only quote strings
           !   o set all logical values to F or T.
           call set_args(' &
              & -x 10.0,20.0 &
              & -y 11.0,22.0 &
              & -p -1,-2,-3 &
              & -title "my title" &
              & -l F,T,F,T -L T,F,T,F  &
              & --cmp 111,222.0,333.0e0,4444 &
              & ')
           ! ASSIGN VALUES TO ELEMENTS
              call get_args_fixed_size('x',x)
              call get_args_fixed_size('y',y)
              call get_args_fixed_size('p',p)
              call get_args_fixed_size('title',title)
              call get_args_fixed_size('l',l)
              call get_args_fixed_size('L',lbig)
              call get_args_fixed_size('cmp',cmp)
           ! USE VALUES
              write(*,*)'x=',x
              write(*,*)'p=',p
              write(*,*)'title=',title
              write(*,*)'l=',l
              write(*,*)'L=',lbig
              write(*,*)'cmp=',cmp
           end program demo_get_args_fixed_size


        !COMPILER-GENERATED INTERFACE MODULE: Fri May 22 16:58:51 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE INVERT_MASS_MATRIX__genmod
          INTERFACE
            SUBROUTINE INVERT_MASS_MATRIX
            END SUBROUTINE INVERT_MASS_MATRIX
          END INTERFACE
        END MODULE INVERT_MASS_MATRIX__genmod


text:
c*************************************************************************
c                            SYMBA4_NBODM.F
c*************************************************************************
c Returns the location of the last massive body in the list
c
c             Input:
c                 nbod          ==>  number of massive bodies (int scalar)
c                 mass          ==>  mass of bodies (real array)
c                 mtiny         ==>  Small mass  (real array)
c             Output:
c                 nbodm         ==>  location of the last massive body
c                                    (int scalar)
c
c Remarks:  If all the objects are massive, then nbodm=nbod-1 so that
c           the do loops will have the correct limits.
c Authors:  Hal Levison
c Date:    3/20/97
c Last revision: 11/27/97

      subroutine  symba4_nbodm(nbod,mass,mtiny,nbodm)

      include '../swift.inc'
      include 'symba4.inc'

c...  Inputs Only:
      integer nbod
      real*8 mass(nbod),mtiny

c...  Outputs only
      integer nbodm

c...  Internals
      integer i

c----
c...  Executable code

      if(mass(nbod).gt.mtiny) then
         nbodm = nbod - 1
         write(*,*) '    Of ',nbod,' objects, all are massive. '
      else
         do i=2,nbod-1
            if(mass(i).gt.mtiny) then
               nbodm = i
            endif
         enddo
         write(*,*) '    Of ',nbod,' objects, ',nbodm,' are massive. '
      endif

      return
      end             ! symba4_nbodm.f
c--------------------------------------------------------

max_stars_repo_name: Simske/exostriker


text:
      SUBROUTINE GENCOS
C
C     GENCOS  GENERATES DIRECTION COSINE MATRIX, UP TO NX3, FOR DDAM.
C     THE SHOCK DIRECTIONS ARE GIVEN BY A COORDINATE SYSTEM (PROBABLY
C     RECTANGULAR, BUT NOT NECESSARILY) DEFINED ON A CORDIJ CARD.
C     THE ID OF THAT SYSTEM MUST BE SPECIFIED BY PARAM SHOCK ID.
C     THE DIRECTIONS OF INTEREST MUST BE SPECIFIED ON A PARAM DIRECT DIR
C     CARD WHERE DIR=1,2,3,12,13,23,OR 123 GIVING THE SHOCK DIRECTIONS
C     DESIRED IN THE SHOCK COORDINATE SYSTEM.  (DEFAULT IS 123)  WE WILL
C     BE CONVERTING A ROW VECTOR IN THE GLOBAL SYSTEM TO A ROW VECTOR IN
C     THE SHOCK SYSTEM.  TO CONVERT A COLUMN VECTOR FROM GLOBAL TO SHOCK
C     FIRST CONVERT TO BASIC.  THEN TRANSFORM FROM BASIC TO SHOCK, I.E.
C     (VECTOR-SHOCK) = (TRANSPOSE(T-SHOCK TO BASIC))*
C                      (T-GLOBAL TO BASIC)*(VECTOR-GLOBAL)
C     BUT BECAUSE WE ARE TRANSFORMING ROW VECTORS, THE EQUATION IS
C     TRANSPOSED . NSCALE =1 MEANS THERE ARE SCALAR POINTS,=0 MEANS NO
C
C     GENCOS    BGPDT,CSTM/DIRCOS/C,Y,SHOCK=0/C,Y,DIRECT=123/
C               V,N,LUSET/V,N,NSCALE $
C
      LOGICAL         REC,ALL
      INTEGER         BGPDT,CSTM,DIRCOS,BUF1,FILE,SHOCK,DIRECT,OTPE
      DIMENSION       NAM(2),MCB(7),IZ(1),TSHOCK(9),COORD(4),ICOORD(4),
     1                TPOINT(9),TFINAL(9),IDIR(3),ISUB(3)
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /BLANK / SHOCK,DIRECT,LUSET,NSCALE
      COMMON /SYSTEM/ IBUF,OTPE
      COMMON /PACKX / IN,IOUT,II,NN,INCR
      COMMON /ZZZZZZ/ Z(1)
      EQUIVALENCE     (Z(1),IZ(1)), (COORD(1),ICOORD(1))
      DATA    BGPDT , CSTM,DIRCOS   / 101,102,201 /
      DATA    NAM   / 4HGENC,4HOS   /
C
C     OPEN CORE AND BUFFERS
C
      LCORE = KORSZ(Z)
      BUF1  = LCORE - IBUF + 1
      LCORE = BUF1  - 1
      IF (LCORE .LE. 0) GO TO 1008
C
C     CHECK FOR SCALAR POINTS AND SET NSCALE
C
      MCB(1) = BGPDT
      CALL RDTRL (MCB)
      NPTS = MCB(2)
      CALL GOPEN (BGPDT,Z(BUF1),0)
      DO 1 I = 1,NPTS
      CALL FREAD (BGPDT,COORD,4,0)
      IF (ICOORD(1) .EQ. -1) GO TO 2
    1 CONTINUE
      NSCALE = 0
      GO TO 3
    2 NSCALE = 1
    3 CALL CLOSE (BGPDT,1)
C
      IF (DIRECT.GE.1  .AND. DIRECT.LE.3) GO TO 5
      IF (DIRECT.NE.12 .AND. DIRECT.NE.13 .AND. DIRECT.NE.23 .AND.
     1    DIRECT.NE.123) GO TO 500
    5 IF (SHOCK .LT.  0) GO TO 500
      NCSTM  = 0
      NCOUNT = 0
      ALL    = .FALSE.
      REC    = .FALSE.
      NDIR   = 2
      IF (DIRECT .LE. 3) NDIR = 1
      IF (DIRECT .EQ. 123)  NDIR = 3
      IF (LUSET*NDIR .GT. LCORE) GO TO 1008
C
      GO TO (6,7,8), NDIR
C
    6 IDIR(1) = DIRECT
      GO TO 9
C
    7 IF (DIRECT .EQ. 23) GO TO 175
      IDIR(1) = 1
      IDIR(2) = 2
      IF (DIRECT .EQ. 13) IDIR(2) = 3
      GO TO 9
  175 IDIR(1) = 2
      IDIR(2) = 3
      GO TO 9
C
    8 IDIR(1) = 1
      IDIR(2) = 2
      IDIR(3) = 3
    9 CONTINUE
C
C
C     READ CSTM FOR FETCHING TRANSFORMATION MATRICES
C
      CALL OPEN (*10,CSTM,Z(BUF1),0)
      GO TO 30
C
C     CSTM IS PURGED.  SO, GLOBAL SYSTEM IS BASIC AND SHOCK SYSTEM MUST
C     BE ALSO.  IF SHOCK SYSTEM IS NOT 0, FATAL MESSAGE.  IF IT IS 0,
C     THEN NEED ONLY IDENTITIES.
C
   10 IF (SHOCK .EQ. 0) GO TO 25
      WRITE  (OTPE,20) UFM
   20 FORMAT (A23,', IN GENCOS, CSTM IS PURGED AND SHOCK COORDINATE ',
     1       'SYSTEM IS NOT BASIC')
      CALL MESAGE (-61,0,0)
C
C     EVERYTHING IS BASIC - CHECK FOR SCALAR POINTS - IF THEY EXIST,
C     WE MUST READ BGPDT
C
   25 IF (NSCALE .EQ. 1) GO TO 55
      ALL  = .TRUE.
      ISYS = 0
      GO TO 130
C
   30 FILE = CSTM
      CALL FWDREC (*1002,CSTM)
      CALL READ (*1002,*40,CSTM,Z,LCORE,0,NCSTM)
      GO TO 1008
   40 CALL CLOSE (CSTM,1)
C
C     CHECK FOR ENOUGH OPEN CORE
C
      IF (NCSTM+LUSET*NDIR .GT. LCORE) GO TO 1008
      CALL PRETRS (Z(1),NCSTM)
C
C     IF SHOCK COORDINATE SYSTEM IS RECTANGULAR, LET'S GET THE TRANS-
C     FORMATION MATRIX ONCE SINCE IT WILL NOT BE POINT-DEPENDENT.
C
      IF (SHOCK .EQ. 0) GO TO 55
      DO 50 I = 1,NCSTM,14
      IF (SHOCK .NE. IZ(I)) GO TO 50
      IF (IZ(I+1) .NE. 1) GO TO 60
C
C     RECTANGULAR
C
      REC = .TRUE.
      DO 45 J = 1,9
   45 TSHOCK(J) = Z(I+J+4)
      GO TO 60
   50 CONTINUE
C
C     CAN'T FIND SHOCK COORDINATE SYSTEM
C
      CALL MESAGE (-30,25,SHOCK)
C
C     SHOCK IS BASIC
C
   55 REC = .TRUE.
      DO 56 I = 1,9
   56 TSHOCK(I) = 0.
      TSHOCK(1) = 1.
      TSHOCK(5) = 1.
      TSHOCK(9) = 1.
C
C     OPEN BGPDT TO GET GRID POINT OUTPUT COORDINATE SYSTEMS AND
C     BASIC COORDINATES
C
   60 CALL GOPEN (BGPDT,Z(BUF1),0)
      FILE = BGPDT
   70 CALL READ (*1002,*210,BGPDT,COORD,4,0,IWORDS)
      ISYS = ICOORD(1)
      IF (ICOORD(1) .EQ. -1) GO TO 150
      IF (ICOORD(1) .NE.  0) GO TO 80
C
C     IDENTITY - BASIC SYSTEM
C
      DO 75 I = 1,9
   75 TPOINT(I) = 0.
      TPOINT(1) = 1.
      TPOINT(5) = 1.
      TPOINT(9) = 1.
      GO TO 85
C
C     FETCH GLOBAL-TO-BASIC MATRIX FOR THIS POINT
C
   80 CALL TRANSS (COORD,TPOINT)
C
C     IF SHOCK IS NOT RECTANGULAR, FETCH SHOCK-TO-BASIC FOR THIS POINT
C
   85 IF (REC) GO TO 90
      ICOORD(1) = SHOCK
      CALL TRANSS (COORD,TSHOCK)
C
C     THE MATRIX WE NEED IS (TRANSPOSE(TPOINT))*(TSHOCK)
C
   90 IF (SHOCK .EQ. 0) GO TO 100
      IF (ISYS  .EQ. 0) GO TO 110
C
C     NEITHER MATRIX IS NECESSARILY IDENTITY
C
      CALL GMMATS (TPOINT,3,3,1,TSHOCK,3,3,0,TFINAL)
      GO TO 150
C
C     TSHOCK IS IDENTITY
C
  100 IF (ISYS .EQ. 0) GO TO 130
C
C     BUT TPOINT IS NOT
C
      TFINAL(1) = TPOINT(1)
      TFINAL(2) = TPOINT(4)
      TFINAL(3) = TPOINT(7)
      TFINAL(4) = TPOINT(2)
      TFINAL(5) = TPOINT(5)
      TFINAL(6) = TPOINT(8)
      TFINAL(7) = TPOINT(3)
      TFINAL(8) = TPOINT(6)
      TFINAL(9) = TPOINT(9)
      GO TO 150
C
C     TPOINT IS IDENTITY, BUT TSHOCK IS NOT
C
  110 DO 120 I = 1,9
  120 TFINAL(I) = TSHOCK(I)
      GO TO 150
C
C     BOTH ARE IDENTITY
C
  130 DO 140 I = 1,9
  140 TFINAL(I) = 0.
      TFINAL(1) = 1.
      TFINAL(5) = 1.
      TFINAL(9) = 1.
C
C     STORE TFINAL BY INTERNAL ORDERING AND DIRECTIONS REQUESTED START-
C     ING AT Z(NCSTM+1) - MAKE UP TO 3 COLUMNS OF LUSET EACH
C
  150 ISUB(1) = NCSTM   + NCOUNT
      ISUB(2) = ISUB(1) + LUSET
      ISUB(3) = ISUB(2) + LUSET
C
      DO 200 I = 1,NDIR
      IP   = IDIR(I)
      JSUB = ISUB(I)
      IF (ISYS .EQ. -1) GO TO 195
      Z(JSUB+1) = TFINAL(IP  )
      Z(JSUB+2) = TFINAL(IP+3)
      Z(JSUB+3) = TFINAL(IP+6)
      Z(JSUB+4) = 0.
      Z(JSUB+5) = 0.
      Z(JSUB+6) = 0.
      GO TO 200
C
C     SCALAR
C
  195 Z(JSUB+1) = 1.
  200 CONTINUE
C
C     GO BACK FOR ANOTHER POINT
C
      NCOUNT = NCOUNT + 6
      IF (ISYS .EQ. -1)  NCOUNT = NCOUNT - 5
      IF (.NOT.ALL) GO TO 70
      IF (NCOUNT .EQ. LUSET) GO TO 210
      GO TO 150
C
C     DONE WITH ALL POINTS - PACK RESULTS
C
  210 IF (.NOT.ALL) CALL CLOSE (BGPDT,1)
      CALL GOPEN (DIRCOS,Z(BUF1),1)
      IN   = 1
      IOUT = 1
      II   = 1
      NN   = LUSET
      INCR = 1
      MCB(1) = DIRCOS
      MCB(2) = 0
      MCB(3) = LUSET
      MCB(4) = 2
      MCB(5) = 1
      MCB(6) = 0
      MCB(7) = 0
      DO 220 I = 1,NDIR
      JSUB = NCSTM + LUSET*(I-1)
      CALL PACK (Z(JSUB+1),DIRCOS,MCB)
  220 CONTINUE
C
      CALL CLOSE (DIRCOS,1)
      CALL WRTTRL (MCB)
      RETURN
C
  500 WRITE  (OTPE,510) UFM,SHOCK,DIRECT
  510 FORMAT (A23,', SHOCK AND DIRECT ARE',2I10, /10X,'RESPECTIVELY. ',
     1       'SHOCK MUST BE NONNEGATIVE AND DIRECT MUST BE EITHER 1,2',
     2       ',3,12,13,23, OR 123')
      CALL MESAGE (-61,0,0)
C
 1002 N = -2
      GO TO 1010
 1008 N = -8
      FILE = 0
 1010 CALL MESAGE (N,FILE,NAM)
      RETURN
      END


text:
      SUBROUTINE TQL2(NM,N,D,E,Z,IERR,EPS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C               ===== PROCESSED BY AUGMENT, VERSION 4N =====
C     APPROVED FOR VAX 11/780 ON MAY 6,1980.  J.D.NEECE
C               ----- LOCAL VARIABLES -----
C               ----- GLOBAL VARIABLES -----
      DIMENSION D(N), E(N), Z(NM,N)
C               ----- SUPPORTING PACKAGE FUNCTIONS -----
C               ===== TRANSLATED PROGRAM =====
C
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2,
C     NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND
C     WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD.
C     THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
C     BE FOUND IF  TRED2  HAS BEEN USED TO REDUCE THIS
C     FULL MATRIX TO TRIDIAGONAL FORM.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY,
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY  TRED2, IF PERFORMED.  IF THE EIGENVECTORS
C          OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
C          THE IDENTITY MATRIX.
C
C      ON OUTPUT-
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C          UNORDERED FOR INDICES 1,2,...,IERR-1,
C
C        E HAS BEEN DESTROYED,
C
C        Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
C          TRIDIAGONAL (OR FULL) MATRIX.  IF AN ERROR EXIT IS MADE,
C          Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C          EIGENVALUES,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
C
      IERR = 0
      IF (N .EQ. 1) GO TO 160
C
      DO 10   I = 2, N
   10 E(I-1) = E(I)
C
      F=0.0D0
      B=0.0D0
      E(N)=0.0D0
C
      DO 110   L = 1, N
         J = 0
         H=EPS*(ABS (D(L))+ABS (E(L)))
         IF (B .LT. H) B=H
C     ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT **********
         DO 20   M = L, N
            IF (ABS (E(M)).LE.B)  GO TO 30
C     ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
   20    CONTINUE
C
   30    IF (M .EQ. L) GO TO 100
   40    IF (J .EQ. 30) GO TO 150
         J = J + 1
C     ********** FORM SHIFT **********
         L1 = L + 1
         G = D(L)
         P=(D(L1)-G)/(2.0D0*E(L))
         R=SQRT (P*P+1.0D0)
         D(L)=E(L)/(P+SIGN (R,P))
         H = G - D(L)
C
         DO 50   I = L1, N
   50    D(I) = D(I) - H
C
         F = F + H
C     ********** QL TRANSFORMATION **********
         P = D(M)
         C=1.0D0
         S=0.0D0
         MML = M - L
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
         DO 90   II = 1, MML
            I = M - II
            G = C * E(I)
            H = C * P
            IF (ABS (P).LT.ABS (E(I)))  GO TO 60
            C = E(I) / P
            R=SQRT (C*C+1.0D0)
            E(I+1) = S * P * R
            S = C / R
            C=1.0D0/R
            GO TO 70
   60       C = P / E(I)
            R=SQRT (C*C+1.0D0)
            E(I+1) = S * E(I) * R
            S=1.0D0/R
            C = C * S
   70       P = C * D(I) - S * G
            D(I+1) = H + S * (C * G + S * D(I))
C     ********** FORM VECTOR **********
            DO 80   K = 1, N
               H = Z(K,I+1)
               Z(K,I+1) = S * Z(K,I) + C * H
               Z(K,I) = C * Z(K,I) - S * H
   80       CONTINUE
C
   90    CONTINUE
C
         E(L) = S * P
         D(L) = C * P
         IF (ABS (E(L)).GT.B)  GO TO 40
  100    D(L) = D(L) + F
  110 CONTINUE
C     ********** ORDER EIGENVALUES AND EIGENVECTORS **********
      DO 140   II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 120   J = II, N
            IF (D(J) .GE. P) GO TO 120
            K = J
            P = D(J)
  120    CONTINUE
C
         IF (K .EQ. I) GO TO 140
         D(K) = D(I)
         D(I) = P
C
         DO 130   J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  130    CONTINUE
C
  140 CONTINUE
C
      GO TO 160
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
  150 IERR = L
  160 RETURN
C     ********** LAST CARD OF TQL2 **********
      END

max_stars_repo_name: openmopac/MOPAC-archive

max_issues_repo_name: openmopac/MOPAC-archive

max_forks_repo_name: openmopac/MOPAC-archive


text:
c -------------------------------------------------------------------
      SUBROUTINE DLINMSG(X,NPTS,XMSG,MFLAG,MPTCRT)
c     implicit none

c NCL: xnew = linmsg(x,mflag)

c given a series x of length npts : this routine will linearly
c .   interpolate to fill in the missing pts. missing values at the
c .   beginning and end of the series will be be determined
c .   by the sign of mprcrt.
c
c nomenclature :
c .   x         - input series which may or may not contain msg values
c .   npts      - length of the series
c .   xmsg      - missing code
c .   mflag     - note: if mflag.lt.0 then the missing values at the
c .               beginning and end of the series will be set to the
c .               value of the nearest non-msg value. if mflag.ge.0
c .               then set these values to missing.
c .   mptcrt    - if more than "mptcrt" consecutive values are
c .               encountered, the routine will not interpolate across
c .               that segment. If mptcrt=npts [most common option],
c .               then the routine will interpolate as many values as
c .               it can.
c .
c OTHER variables
c .   ncode     - code number
c .               ncode = -1  : whole series is missing
c .               ncode =  0  : series has no missing points upon return
c .                             to the calling routine. either the serie
c .                             had no missing points or this routine
c .                             has filled them with interpolated values
c .               ncode = nn  : series still has missing values. this
c .                             occurs when iabs(mptcrt) is exceeded.
c .                             nn is the number of missing values
c .                             still present.
c .   nitp      - No. of InTerpolated Points : user shouldcheck
c .               the ratio (nitp/npts)

      INTEGER NPTS,MPTCRT,NCODE,NITP,N,NEND,NSTRT
      DOUBLE PRECISION X(1:NPTS),XMSG
      INTEGER NPTCRT,NN,NBASE
      DOUBLE PRECISION SLOPE
C
C This do loop was added later to check for the special
C case were all values in X are missing.
C
      DO 5 N=1,NPTS
         IF (X(N).NE.XMSG) GO TO 10
 5    END DO
      RETURN

c c c MPTCRT = NPTS   ! updated version

 10   NSTRT = 0
      NEND = 0
      NCODE = 0
      NITP = 0
      NPTCRT = IABS(MPTCRT)
      DO 40 N = 1,NPTS
          IF (X(N).EQ.XMSG) THEN
C must be a msg pt : set indices
              IF (NSTRT.EQ.0) NSTRT = N
              NEND = N
          ELSE

c must be a valid pt : check for prior missing values
c        (1) if nstrt=0 then there are no msg prior values : skip out
c        (2) if (nend-nstrt+1).gt.nptcrt the set ncode : skip out
c        (3) if nstrt=1 then initial series values are msg : set to
c            first non-msg value
c        ... else
c            perform the linear interpolation

              IF (NSTRT.NE.0) THEN
                  IF ((NEND-NSTRT+1).GT.NPTCRT) THEN
                      GO TO 30
                  END IF

                  IF (NSTRT.EQ.1) THEN
                      NITP = NITP + (NEND-NSTRT+1)
                      IF (MFLAG.LT.0) THEN
                          DO 15 NN = NSTRT,NEND
   15                     X(NN) = X(N)
                      ELSE
                          DO 16 NN = NSTRT,NEND
   16                     X(NN) = XMSG
                      END IF
                  ELSE
                      NBASE = NSTRT - 1
                      SLOPE = (X(N)-X(NBASE))/DBLE(N-NBASE)
                      NITP = NITP + (NEND-NSTRT+1)
                      DO 20 NN = NSTRT,NEND
   20                 X(NN) = X(NBASE) + SLOPE*DBLE(NN-NBASE)
                  END IF

   30             NSTRT = 0
                  NEND = 0
              END IF
          END IF
   40 CONTINUE

c check the end points

      IF (NEND.EQ.NPTS) THEN
          NITP = NITP + (NEND-NSTRT+1)
          IF (MFLAG.LT.0) THEN
              DO 49 NN = NSTRT,NPTS
   49         X(NN) = X(NSTRT-1)
          ELSE
              DO 50 NN = NSTRT,NPTS
   50         X(NN) = XMSG
          END IF
      END IF

c     nn = 0
c     do 60 n=1,npts
c     if (x(n).eq.xmsg) then
c         nn = nn+1
c     endif
c  60 continue

c     ncode = nn
c     if (nn.eq.npts) then
C for historical reasons
c         ncode = -1
c     endif

      RETURN
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
    implicit none

    type VARYING_STRING
        character(len=1), allocatable :: characters(:)
    end type

    interface operator(==)
        procedure character_EQ_String
    end interface

    print *, stringToChar(var_str("Hello")) == var_str("World") ! causes ice

contains
    logical function character_EQ_String(lhs, rhs)
        character(len=*), intent(in) :: lhs
        type(VARYING_STRING), intent(in) :: rhs
        character_EQ_String = lhs == stringToChar(rhs)
    end function

    function stringToChar(string)
        type(VARYING_STRING) string
        character(len=size(string%characters)) :: stringToChar
        stringToChar = ""
    end function

    type(VARYING_STRING) function VAR_STR(char)
        character(len=*) char
        integer i
        VAR_STR%characters = [(char(i:i), i = 1, len(char))]
    end function
end

max_stars_repo_name: rouson/bug-reports

max_issues_repo_name: rouson/bug-reports

max_forks_repo_name: rouson/bug-reports


! RUN: %S/test_errors.sh %s %t %flang_fc1 -fimplicit-none-type-never
! REQUIRES: shell
subroutine s1
  implicit none
  i = j + k  ! would be error without -fimplicit-none-type-never
end

subroutine s2(a, n)
  implicit none
  real :: a(n)  ! would be error without -fimplicit-none-type-never
  integer :: n
end


text:
C=================================================================
#include "fintrf.h"
#if 0
C
C     mexlockf.F
C     .F file needs to be preprocessed to generate .for equivalent
C
#endif
C     mexlockf.f
C
C     This example demonstrates how to use mexLock, mexUnlock, and
C     mexIsLocked.
C
C     You must call mexlock with one argument.  If you pass in a 1, it
C     will lock the MEX-file. If you pass in a -1, it will unlock the
C     MEX-file. If you pass in 0, it will report lock status.   It uses
C     mexIsLocked to check the status of the MEX-file. If the file is
C     already in the state you requested, the MEX-file errors out.
C
C     This is a MEX-file for MATLAB.
C     Copyright 1984-2011 The MathWorks, Inc.
C     All rights reserved.
C
C=================================================================

      subroutine mexFunction(nlhs, plhs, nrhs, prhs)

C     Declarations
      implicit none

      mwPointer plhs(*), prhs(*)
      integer nlhs, nrhs
      integer mexIsLocked
      real*8  lock

C     Function declarations:
      mwPointer mxGetM, mxGetN
      real*8  mxGetScalar
      integer*4 mxIsComplex, mxIsDouble

C     Check for proper number of input and output arguments
      if (nrhs .ne. 1) then
 	    call mexErrMsgIdAndTxt( 'MATLAB:mexlockf:invalidNumInput',
     +   'One input arguments required.')
      else if ((mxIsDouble(prhs(1)) .ne. 1) .or.
     +    (mxGetN(prhs(1))*mxGetM(prhs(1)) .ne. 1)  .or.
     +    (mxIsComplex(prhs(1)) .eq. 1)) then
	    call mexErrMsgIdAndTxt( 'MATLAB:mexlockf:inputNotRealScalar',
     +   'Input argument must be a real scalar double')
      end if
      if (nlhs .gt. 0) then
	    call mexErrMsgIdAndTxt( 'MATLAB:mexlockf:maxlhs',
     + 'No output arguments expected.')
      end if

      lock = mxGetScalar(prhs(1))

      if ((lock .ne. 0.0) .and. (lock .ne. 1.0) .and.
     +    (lock .ne. -1.0)) then
	    call mexErrMsgIdAndTxt( 'MATLAB:mexlockf:invalidInputValue',
     +      'Input argument must be either 1 to lock or
     +      -1 to unlock or 0 for lock status.')
      end if

      if (mexIsLocked() .eq. 1) then
	    if (lock .gt. 0.0) then
	      call mexErrMsgIdAndTxt( 'MATLAB:mexlockf:invalidLockState',
     +      'MEX-file is already locked')
	    else if (lock .lt. 0.0) then
	      call mexUnlock()
	      call mexPrintf('MEX-file is unlocked')
	    else
	      call mexPrintf('MEX-file is locked')
	    end if
      else
	    if (lock .lt. 0.0) then
	      call mexErrMsgIdAndTxt('MATLAB:mexlockf:invalidUnlockState',
     +      'MEX-file is already unlocked')
	    else if (lock .gt. 0.0) then
	      call mexLock()
	      call mexPrintf('MEX-file is locked')
	    else
	      call mexPrintf('MEX-file is unlocked')
	    end if
      end if
       return
       end


text:
 SUBROUTINE projq4(y,x,xi,eta,shape,flag)
 !
 ! proyects a point over a quadrilateral
 ! first order approach
 ! initial guess is assumed good enough
 !
 IMPLICIT NONE
 ! dummy arguments
 REAL(kind=8), INTENT(IN) :: y(3), & !point coordinates
                             x(3,4)  !quad nodal coordinates
 REAL(kind=8), INTENT(IN OUT) :: xi,eta, & !guess
                                 shape(4)  !shape functions at the guess
 LOGICAL, INTENT(IN) :: flag         !to recompute shape functions
 ! local variables
 REAL(kind=8) :: deriv(4,2), &
                 xx(3,2),xy(3,2),t(3),mx,xc(3)

 ! compute shape functions and derivatives at the point
 CALL shape1 (4 ,deriv ,shape ,xi,eta )
 ! distance from point to initial guress
 xc = y - MATMUL(x,shape)
 ! jacobian matrix at the guess
 xx = MATMUL(x,deriv)
 ! compute inverse jacobian matrix (dual base)
 CALL vecpro(xx(1,1),xx(1,2),t(1))   !normal vector
 CALL vecuni(3,t,mx)                 !unit normal vector and Jacobian
 CALL vecpro(xx(1,2),t(1),xy(1,1))   !first vector of the dual base
 CALL vecpro(t(1),xx(1,1),xy(1,2))   !second vector of the dual base
 xi = xi + DOT_PRODUCT(xc,xy(:,1))/mx   !compute improved position
 eta= eta+ DOT_PRODUCT(xc,xy(:,2))/mx
 IF( flag )THEN
   mx = xi*eta
   shape(1) = (1d0-xi-eta+mx)/4d0
   shape(2) = (1d0+xi-eta-mx)/4d0
   shape(3) = (1d0+xi+eta+mx)/4d0
   shape(4) = (1d0-xi+eta-mx)/4d0
 END IF

 RETURN
 END SUBROUTINE projq4

max_stars_repo_name: jerebenitez/IFE-simpact-openfoam

max_issues_repo_name: jerebenitez/IFE-simpact-openfoam

max_forks_repo_name: jerebenitez/IFE-simpact-openfoam


text:
Zack Frederick is a fourthyear English major at UC Davis. He used to work at Freeborn Hall, but traded lifting tables for writing articles and now slaves away for the Arts section of the California Aggie.

He lives in West Davis amongst the trees and fancies himself a sunset aficionado. He bought a big stereo earlier this year and uses it to annoy his neighbors (who watch endless amounts of TV and appear to be quite depressed).

Somewhat musically inclined, he is a member of the band http://www.myspace.com/BabyChampion Baby Champion


text:
This editor can edit this entry and tell us a bit about themselves by clicking the Edit icon.

20090706 21:32:50 nbsp Hi Shayna  welcome to the wiki!  I saw your comment on the Nina and Tom page.  Nina and Tom may not check their page very often, so if youd really like to work there, youre probably better off stopping by their store and talking to them, or at least calling them. Users/CovertProfessor


text:
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! test pointer, allocatable allocated with zero, negative size

	real,dimension(:),pointer::a
	real,dimension(:,:),pointer::b
	real,dimension(:),allocatable::c

	integer,dimension(9) :: expect,result
	data expect/1,1,1,0,0,0,0,0,0/

	n = 1
	allocate(a(n))
	allocate(b(n,n))
	allocate(c(n))
	!print 5,n
	!print 10,'a',lbound(a,1),ubound(a,1),size(a)
	!print 20,'b',lbound(b,1),ubound(b,1),lbound(b,2),ubound(b,2),size(b)
	!print 10,'c',lbound(c,1),ubound(c,1),size(c)
	result(1) = size(a)
	result(2) = size(b)
	result(3) = size(c)
	deallocate (c)     !4/16/2000 - can't allocate if already allocated.
	n = 0
	allocate(a(n))
	allocate(b(n,n))
	allocate(c(n))
	!print 5,n
	!print 10,'a',lbound(a,1),ubound(a,1),size(a)
	!print 20,'b',lbound(b,1),ubound(b,1),lbound(b,2),ubound(b,2),size(b)
	!print 10,'c',lbound(c,1),ubound(c,1),size(c)
	result(4) = size(a)
	result(5) = size(b)
	result(6) = size(c)
	deallocate (c)     !4/16/2000 - can't allocate if already allocated.
	n = -1
	allocate(a(n))
	allocate(b(n,n))
	allocate(c(n))
	!print 5,n
	!print 10,'a',lbound(a,1),ubound(a,1),size(a)
	!print 20,'b',lbound(b,1),ubound(b,1),lbound(b,2),ubound(b,2),size(b)
	!print 10,'c',lbound(c,1),ubound(c,1),size(c)
	result(7) = size(a)
	result(8) = size(b)
	result(9) = size(c)
	deallocate (c)     !4/16/2000 - can't allocate if already allocated.
	call check(result,expect,size(expect))
5	format( 'n=',i2 )
10	format( a,'(',i2,':',i2,'), size=',i2)
20	format( a,'(',i2,':',i2,',',i2,':',i2,', size=)',i3)
	end

max_stars_repo_name: abrahamtovarmob/flang

max_issues_repo_name: abrahamtovarmob/flang

max_forks_repo_name: abrahamtovarmob/flang


text:
! { dg-do compile }
! Tests the fix for 25083, in which the compiler failed to detect that
! data variables in BLOCK DATA were not in COMMON.
!
! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
!
 BLOCK DATA D
  INTEGER I ! { dg-error "must be in COMMON" }
  DATA I /1/
 END BLOCK DATA
END

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
program test_momday
  use simsphere_mod, only: ud, vd, ugd, vgd, ustar, awind, cf, dqdt2, zi,   &
                           hgt, ntrp, km, qd, evap, td, aptemp, q_fine,     &
                           u_fine, t_fine, v_fine, deltaz, eq
  use mod_testing, only: assert, initialize_tests, report_tests
  implicit none

  logical, dimension(:), allocatable :: tests
  logical :: test_failed
  integer :: n, ntests

  ! Check value of qd(1), awind, u_fine, v_fine, t_fine, q_fine
  ! Expected values

  real, parameter :: awind_exp = 1.41421354
  real, parameter :: awind_thick_exp = 1.40946424
  real, dimension(51), parameter :: v_fine_exp = (/1.0,-16.7999992,          &
      -34.5999985,-52.4000015,-70.1999969,-88.0,-105.800003,-123.599998,     &
      -141.399994,-159.199997,-177.0,-194.800003,-212.600006,-230.399994,    &
      -248.199997,-266.0,-283.799988,-301.600006,-319.399994,-337.200012,    &
      -355.0,-372.799988,-390.600006,-408.399994,-426.200012,-444.0,         &
      -461.799988,-479.600006,-497.399994,-515.200012,-533.0,-550.799988,    &
      -568.599976,-586.400024,-604.200012,-622.0,-639.799988,-657.599976,    &
      -675.400024,-693.200012,-711.0,-728.799988,-746.599976,-764.400024,    &
      -782.200012,-800.0,0.0,0.0,0.0,0.0,0.0/)
  real, dimension(51), parameter :: t_fine_exp = (/1.0,267.0,267.0,267.0,    &
      267.0,267.0,267.0,267.0,267.0,267.0,267.0,267.0,267.0,267.0,267.0,     &
      267.0,267.0,267.0,267.0,267.0,267.0,5.19999981,5.40000010,5.59999990,  &
      5.80000019,6.0,6.19999981,6.40000010,6.59999990,6.80000019,7.0,        &
      7.19999981,7.40000010,7.59999990,7.80000019,8.0,8.19999981,8.39999962, &
      8.60000038,8.80000019,9.0,9.19999981,9.39999962,9.60000038,9.80000019, &
      10.00,0.0,0.0,0.0,0.0,0.0/)
  real, dimension(51), parameter :: q_fine_exp = (/1.0,1.20000005,1.39999998,&
      1.60000002,1.79999995,2.0,2.20000005,2.40000010,2.59999990,2.79999995, &
      3.0,3.20000005,3.40000010,3.59999990,3.79999995,4.0,4.19999981,        &
      4.40000010,4.59999990,4.80000019,5.0,5.19999981,5.40000010,5.59999990, &
      5.80000019,6.0,6.19999981,6.40000010,6.59999990,6.80000019,7.0,        &
      7.19999981,7.40000010,7.59999990,7.80000019,8.0,8.19999981,8.39999962, &
      8.60000038,8.80000019,9.0,9.19999981,9.39999962,9.60000038,9.80000019, &
      10.0,0.0,0.0,0.0,0.0,0.0/)

  real, dimension(51), parameter :: v_fine_thick_exp = (/1.04643059,         &
      -421.750214,-844.546814,-1267.34351,-1690.14014,-2112.93677,           &
      -2112.94312,-2112.94946,-2112.95581,-2112.96216,-2112.96851,           &
      -2112.96851,-2112.96851,-2112.96851,-2112.96851,-2112.96851,           &
      -2112.96851,-2112.96851,-2112.96851,-2112.96851,-2112.96851,           &
      -2112.96851,-2112.96851,-2112.96851,-2112.96851,-2112.96851,           &
      -2112.96851,-2112.96851,-2112.96851,-2112.96851,-2112.96851,           &
      -2112.96851,-2112.96851,-2112.96851,-2112.96851,-2112.96851,           &
      -2112.96851,-2112.96851,-2112.96851,-2112.96851,-2112.96851,           &
      -2112.96851,-2112.96851,-2112.96851,-2112.96851,-2112.96851,0.0,0.0,   &
      0.0,0.0,0.0/)
  real, dimension(51), parameter :: t_fine_thick_exp = (/1.0,267.0,267.0,    &
      267.0,267.0,267.0,267.0,267.0,267.0,267.0,267.0,267.0,267.0,267.0,     &
      267.0,267.0,267.0,267.0,267.0,267.0,267.0,5.19999981,5.40000010,       &
      5.59999990,5.80000019,6.0,6.19999981,6.40000010,6.59999990,6.80000019, &
      7.0,7.19999981,7.40000010,7.59999990,7.80000019,8.0,8.19999981,        &
      8.39999962,8.60000038,8.80000019,9.0,9.19999981,9.39999962,9.60000038, &
      9.80000019,10.0,0.0,0.0,0.0,0.0,0.0/)
  real, dimension(51), parameter :: q_fine_thick_exp = (/1.00239599,         &
      1.20162904,1.40086222,1.60009527,1.79932833,1.99856138,2.19884920,     &
      2.39913678,2.59942460,2.79971218,3.0,3.20000005,3.40000010,3.59999990, &
      3.79999995,4.0,4.19999981,4.40000010,4.59999990,4.80000019,5.0,        &
      5.19999981,5.40000010,5.59999990,5.80000019,6.0,6.19999981,6.40000010, &
      6.59999990,6.80000019,7.0,7.19999981,7.40000010,7.59999990,7.80000019, &
      8.0,8.19999981,8.39999962,8.60000038,8.80000019,9.0,9.19999981,        &
      9.39999962,9.60000038,9.80000019,10.0000000,0.0,0.0,0.0,0.0,0.0/)

  n = 1
  ntests = 8
  call initialize_tests(tests,ntests)

  ! CASE I: thick == 0
  call momday_init
  call momday(0.0)
  tests(n) = assert(eq(awind,awind_exp), 'awind thick == 0.0')
  n = n + 1
  tests(n) = assert(eq(v_fine,v_fine_exp), 'v_fine thick == 0.0')
  n = n + 1
  tests(n) = assert(eq(t_fine,t_fine_exp), 't_fine thick == 0.0')
  n = n + 1
  tests(n) = assert(eq(q_fine,q_fine_exp), 'q_fine thick == 0.0')
  n = n + 1

  ! CASE II: thick > 0
  call momday_init
  call momday(1.0)
  tests(n) = assert(eq(awind,awind_thick_exp), 'awind thick > 0.0')
  n = n + 1
  tests(n) = assert(eq(v_fine,v_fine_thick_exp), 'v_fine thick > 0.0')
  n = n + 1
  tests(n) = assert(eq(t_fine,t_fine_thick_exp), 't_fine thick > 0.0')
  n = n + 1
  tests(n) = assert(eq(q_fine,q_fine_thick_exp), 'q_fine thick > 0.0')
  n = n + 1

  test_failed = .false.
  call report_tests(tests,test_failed)
  if (test_failed) stop 1

contains
  subroutine momday_init
    integer :: i

    awind = 1.0
    ugd = 1.0
    vgd = 1.0
    ustar = 1.0
    evap = 1.0
    cf = 1.0
    hgt = 1000.0
    aptemp = 267.0
    km = 1.0
    ntrp = 11
    dqdt2 = 1.0
    deltaz = 250.0
    zi = 1.0
    do i = 1,50
      u_fine = 0.0
      v_fine = 0.0
      t_fine = 0.0
      q_fine = 0.0
      vd(i) = i
      ud(i) = i
      td(i) = i
      qd(i) = i
    end do
    return
  end subroutine momday_init

end program test_momday

max_stars_repo_name: derekmorr/simsphere

max_issues_repo_name: derekmorr/simsphere

max_forks_repo_name: derekmorr/simsphere


text:
	SUBROUTINE DM_EFRE  ( iflno, nblk, iret )
C************************************************************************
C* DM_EFRE								*
C*									*
C* This subroutine eliminates a free block from the free block list.	*
C*									*
C* DM_EFRE  ( IFLNO, NBLK, IRET )					*
C*									*
C* Input parameters:							*
C*	IFLNO		INTEGER		File number			*
C*	NBLK		INTEGER		Block to eliminate		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 4/87						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'dmcmn.cmn'
C-----------------------------------------------------------------------
	iret = 0
C
C*	Check that the block is in the proper range.
C
	IF ( ( nblk .le. 0 ) .or. ( nblk .gt. knfree ( iflno ))) RETURN
C
C*	Eliminate block by moving blocks down.
C
	DO  i = nblk + 1, knfree ( iflno )
	    kfreew ( 1, i-1, iflno ) = kfreew ( 1, i, iflno )
	    kfreew ( 2, i-1, iflno ) = kfreew ( 2, i, iflno )
	END DO
C
C*	Decrement free block counter.
C
	knfree ( iflno ) = knfree ( iflno ) - 1
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: sgdecker/pygempak