text:
C ###########################################################
C #                                                         #
C #             THE TWOSTREAM LIDORT MODEL                  #
C #                                                         #
C #      (LInearized Discrete Ordinate Radiative Transfer)  #
C #       --         -        -        -         -          #
C #                                                         #
C ###########################################################

C ###########################################################
C #                                                         #
C #  Authors :      Robert. J. D. Spurr (1)                 #
C #                 Vijay Natraj        (2)                 #
C #                                                         #
C #  Address (1) :     RT Solutions, Inc.                   #
C #                    9 Channing Street                    #
C #                    Cambridge, MA 02138, USA             #
C #  Tel:             (617) 492 1183                        #
C #  Email :           rtsolutions@verizon.net              #
C #                                                         #
C #  Address (2) :     CalTech                              #
C #                    Department of Planetary Sciences     #
C #                    1200 East California Boulevard       #
C #                    Pasadena, CA 91125                   #
C #  Tel:             (626) 395 6962                        #
C #  Email :           vijay@gps.caltech.edu                #
C #                                                         #
C ###########################################################

C    #####################################################
C    #                                                   #
C    #   This Version of LIDORT comes with a GNU-style   #
C    #   license. Please read the license carefully.     #
C    #                                                   #
C    #####################################################

C ###############################################################
C #                                                             #
C # Regular BVP: Subroutines in this Module                     #
C #                                                             #
C #            TWOSTREAM_BVP_L_SOLUTION_MASTER      (master)    #
C #            TWOSTREAM_L_BVP_P_COLUMN_SETUP                   #
C #            TWOSTREAM_L_BVP_C_COLUMN_SETUP                   #
C #                                                             #
C #            TWOSTREAM_BVP_LS_SOLUTION_MASTER      (master)   #
C #            TWOSTREAM_LS_BVP_COLUMN_SETUP                    #
C #                                                             #
C ###############################################################

      SUBROUTINE TWOSTREAM_BVP_L_SOLUTION_MASTER
     I       ( DO_INCLUDE_DIRECTBEAM, DO_PLANE_PARALLEL,
     I         DO_PROFILE_LINEARIZATION, DO_COLUMN_LINEARIZATION,
     I         FOURIER_COMPONENT, IPARTIC,
     I         NBEAMS, NLAYERS, NTOTAL, NPARS,
     I         VARIATION_INDEX, N_WEIGHTFUNCS,
     I         DO_INCLUDE_SURFACE, SURFTYPE, SURFACE_FACTOR,
     I         ALBEDO, STREAM_VALUE, DIRECT_BEAM, CHAPMAN_FACTORS,
     I         INITIAL_TRANS, T_DELT_MUBAR, WVEC, WUPPER, WLOWER,
     I         EIGENTRANS, XPOS, XNEG, BANDMAT2, SMAT2, IPIVOT,
     I         LCON, MCON, L_DELTAU_VERT,
     I         L_INITIAL_TRANS, L_T_DELT_MUBAR,
     I         L_EIGENTRANS, L_XPOS, L_XNEG, L_WVEC,
     O         L_WUPPER, L_WLOWER, COL2_WF, SCOL2_WF,
     O         NCON, PCON, NCON_XVEC, PCON_XVEC,
     O         STATUS )

C  input arguments
C  ---------------

C  inclusion flags

      LOGICAL          DO_INCLUDE_DIRECTBEAM
      LOGICAL          DO_PLANE_PARALLEL

C  LInearization flags

      LOGICAL          DO_COLUMN_LINEARIZATION
      LOGICAL          DO_PROFILE_LINEARIZATION

C  Surface control

      INTEGER          SURFTYPE
      LOGICAL          DO_INCLUDE_SURFACE
      DOUBLE PRECISION SURFACE_FACTOR
      DOUBLE PRECISION ALBEDO

C  Numbers

      INTEGER          NBEAMS, NLAYERS, NTOTAL, NPARS

C  Stream

      DOUBLE PRECISION STREAM_VALUE

C  Fourier component and beam number

      INTEGER          FOURIER_COMPONENT, IPARTIC

C  Linearization control

      INTEGER          VARIATION_INDEX
      INTEGER          N_WEIGHTFUNCS

C  tramsittance factors for solar beams.

      DOUBLE PRECISION
     &     INITIAL_TRANS  ( NLAYERS, NBEAMS ),
     &     T_DELT_MUBAR   ( NLAYERS, NBEAMS )

C  Eigenvector solutions

      DOUBLE PRECISION EIGENTRANS(NLAYERS)
      DOUBLE PRECISION XPOS(2,NLAYERS)
      DOUBLE PRECISION XNEG(2,NLAYERS)

C  particular solutions

      DOUBLE PRECISION WVEC   ( 2, NLAYERS )
      DOUBLE PRECISION WLOWER ( 2, NLAYERS )
      DOUBLE PRECISION WUPPER ( 2, NLAYERS )

C  Direct beam

      DOUBLE PRECISION DIRECT_BEAM ( NBEAMS )

C  Matrix, Band-matrix

      DOUBLE PRECISION SMAT2   (2,2)
      DOUBLE PRECISION BANDMAT2(7,NTOTAL)

C  Pivot matrices

      INTEGER          IPIVOT  (NTOTAL)

C  Solution constants of integration, and related quantities

      DOUBLE PRECISION LCON(NLAYERS)
      DOUBLE PRECISION MCON(NLAYERS)

C  Linearized tramsittance factors for solar beams.

      DOUBLE PRECISION
     &     L_INITIAL_TRANS  ( NLAYERS, NBEAMS,0:NLAYERS,NPARS ),
     &     L_T_DELT_MUBAR   ( NLAYERS, NBEAMS,0:NLAYERS,NPARS )

C  Linearized Beam solutions

      DOUBLE PRECISION L_WVEC(2,NLAYERS,0:NLAYERS,NPARS)

C  Linearized up and down solutions to the homogeneous RT equations

      DOUBLE PRECISION L_EIGENTRANS(NLAYERS,NPARS)
      DOUBLE PRECISION L_XPOS(2,NLAYERS,NPARS)
      DOUBLE PRECISION L_XNEG(2,NLAYERS,NPARS)

C  Direct beam linearizations

      DOUBLE PRECISION L_DELTAU_VERT   ( NLAYERS, NPARS )
      DOUBLE PRECISION CHAPMAN_FACTORS ( NLAYERS, NLAYERS, NBEAMS )

C  output
C  ------

C  Linearized boundary conditions

      DOUBLE PRECISION L_WLOWER ( 2, NLAYERS, NPARS )
      DOUBLE PRECISION L_WUPPER ( 2, NLAYERS, NPARS )

C  Weighting function column matrices

      DOUBLE PRECISION COL2_WF  ( NTOTAL,NPARS)
      DOUBLE PRECISION SCOL2_WF ( 2,     NPARS)

C  Linearized Solution constants of integration, and related quantities

      DOUBLE PRECISION NCON(NLAYERS,NPARS)
      DOUBLE PRECISION PCON(NLAYERS,NPARS)

      DOUBLE PRECISION NCON_XVEC(2,NLAYERS,NPARS)
      DOUBLE PRECISION PCON_XVEC(2,NLAYERS,NPARS)

C  status

      INTEGER          STATUS

C  Local variables
C  ---------------

      INTEGER          N, I, C0, Q
      DOUBLE PRECISION A, B

C  boundary condition flags

      LOGICAL          MODIFIED_BCL3, MODIFIED_BCL4

C  error tracing variables

      INTEGER          INFO
      CHARACTER*3      CN, CI
      CHARACTER*70     MAIL, TRACE

C  Linearization of the regular BVP case
C  =====================================

C  set status

      STATUS = 0

C  Set up the column vectors for Bulk/profile linearizations
C  ---------------------------------------------------------

C  Bulk: Compute the main column B' where AX = B'

      IF ( DO_COLUMN_LINEARIZATION ) THEN

        CALL TWOSTREAM_L_BVP_C_COLUMN_SETUP
     I       ( DO_INCLUDE_DIRECTBEAM, DO_PLANE_PARALLEL,
     I         FOURIER_COMPONENT, IPARTIC, N_WEIGHTFUNCS,
     I         NBEAMS, NLAYERS, NTOTAL, NPARS,
     I         DO_INCLUDE_SURFACE, SURFTYPE, SURFACE_FACTOR,
     I         ALBEDO, STREAM_VALUE, DIRECT_BEAM,
     I         INITIAL_TRANS, T_DELT_MUBAR, WVEC, WUPPER, WLOWER,
     I         EIGENTRANS, XPOS, XNEG,
     I         BANDMAT2, SMAT2, IPIVOT, LCON, MCON,
     I         L_INITIAL_TRANS, L_T_DELT_MUBAR, L_WVEC,
     I         L_EIGENTRANS, L_XPOS, L_XNEG,
     I         L_DELTAU_VERT, CHAPMAN_FACTORS,
     O         L_WUPPER, L_WLOWER, COL2_WF, SCOL2_WF )

C  Profile: Boundary condition flags for special cases
C  Profile: Compute the main column B' where AX = B'

      ELSE IF ( DO_PROFILE_LINEARIZATION ) THEN

C  Boundary condition flags for special cases

        MODIFIED_BCL3 = ( VARIATION_INDEX .EQ. 1 )
        MODIFIED_BCL4 = ( VARIATION_INDEX .EQ. NLAYERS )

        CALL TWOSTREAM_L_BVP_P_COLUMN_SETUP
     I       ( DO_INCLUDE_DIRECTBEAM, DO_PLANE_PARALLEL,
     I         MODIFIED_BCL3,      MODIFIED_BCL4,
     I         VARIATION_INDEX,    N_WEIGHTFUNCS,
     I         FOURIER_COMPONENT, IPARTIC,
     I         NBEAMS, NLAYERS, NTOTAL, NPARS,
     I         DO_INCLUDE_SURFACE, SURFTYPE, SURFACE_FACTOR,
     I         ALBEDO, STREAM_VALUE, DIRECT_BEAM,
     I         INITIAL_TRANS, T_DELT_MUBAR, WVEC, WUPPER, WLOWER,
     I         EIGENTRANS, XPOS, XNEG,
     I         BANDMAT2, SMAT2, IPIVOT, LCON, MCON,
     I         L_INITIAL_TRANS, L_T_DELT_MUBAR, L_WVEC,
     I         L_EIGENTRANS, L_XPOS, L_XNEG,
     I         L_DELTAU_VERT, CHAPMAN_FACTORS,
     O         L_WUPPER, L_WLOWER, COL2_WF, SCOL2_WF )

      ENDIF

C  BVP back-substitution: With compression (multilayers)
C  -----------------------------------------------------

      IF ( NLAYERS .GT. 1 ) THEN

C  LAPACK substitution (DGBTRS) using RHS column vector COL2_WF
C  BV solution for perturbed integration constants
C    ( call to LAPACK solver routine for back substitution )

        CALL DGBTRS
     &     ( 'n', NTOTAL, 2, 2, N_WEIGHTFUNCS,
     &        BANDMAT2, 7, IPIVOT,
     &        COL2_WF, NTOTAL, INFO )

C  Error tracing

        IF ( INFO .LT. 0 ) THEN
          WRITE(CI, '(I3)' ) INFO
          WRITE(CN, '(I3)' ) VARIATION_INDEX
          MAIL  = 'argument i illegal value, for i = '//CI
          TRACE = 'Atmos_Wfs for layer '//CN//
     *         '; (multilayer) DGBTRS call in L_BVP_SOLUTION_MASTER'
          STATUS = 1
          CALL TWOSTREAM_ERROR_TRACE ( MAIL, TRACE, STATUS )
          RETURN
         ENDIF

C  Set integration constants NCON and PCON for +/- eigensolutions

        DO N = 1, NLAYERS
          C0 = (N-1)*2
          DO Q = 1, N_WEIGHTFUNCS
            NCON(N,Q) = COL2_WF(C0+1,Q)
            PCON(N,Q) = COL2_WF(C0+2,Q)
          ENDDO
        ENDDO

C  debug
c      if ( fourier_component.eq.0 ) then
c        do n = 1, nlayers
c          write(*,'(i3,1p2e24.12)')n,NCON(N,1),PCON(N,1)
c        enddo
c      endif

C  Solve the boundary problem: No compression, Single Layer only
C  -------------------------------------------------------------

      ELSE IF ( NLAYERS .EQ. 1 ) THEN
        DO Q = 1, N_WEIGHTFUNCS
          A = SCOL2_WF(1,Q)
          B = SCOL2_WF(2,Q)
          SCOL2_WF(1,Q) = SMAT2(1,1) * A + smat2(1,2) * B
          SCOL2_WF(2,Q) = SMAT2(2,1) * A + smat2(2,2) * B
          NCON(1,Q) = SCOL2_WF(1,Q)
          PCON(1,Q) = SCOL2_WF(2,Q)
        ENDDO
      ENDIF

C  Associated quantities
C  ---------------------

      DO N = 1, NLAYERS
        DO Q = 1, N_WEIGHTFUNCS
          DO I = 1, 2
            NCON_XVEC(I,N,Q) = NCON(N,Q)*XPOS(I,N)
            PCON_XVEC(I,N,Q) = PCON(N,Q)*XNEG(I,N)
          ENDDO
        ENDDO
      ENDDO

C  Finish

      RETURN
      END

C

      SUBROUTINE TWOSTREAM_L_BVP_P_COLUMN_SETUP
     I       ( DO_INCLUDE_DIRECTBEAM, DO_PLANE_PARALLEL,
     I         MODIFIED_BCL3,      MODIFIED_BCL4,
     I         LAYER_TO_VARY,      N_LAYER_WFS,
     I         FOURIER_COMPONENT,  IPARTIC,
     I         NBEAMS, NLAYERS, NTOTAL, NPARS,
     I         DO_INCLUDE_SURFACE, SURFTYPE, SURFACE_FACTOR,
     I         ALBEDO, STREAM_VALUE, DIRECT_BEAM,
     I         INITIAL_TRANS, T_DELT_MUBAR, WVEC, WUPPER, WLOWER,
     I         EIGENTRANS, XPOS, XNEG,
     I         BANDMAT2, SMAT2, IPIVOT, LCON, MCON,
     I         L_INITIAL_TRANS, L_T_DELT_MUBAR, L_WVEC,
     I         L_EIGENTRANS, L_XPOS, L_XNEG,
     I         L_DELTAU_VERT, CHAPMAN_FACTORS,
     O         L_WUPPER, L_WLOWER, COL2_WF, SCOL2_WF )

C  input arguments
C  ---------------

C  inclusion flags

      LOGICAL          DO_INCLUDE_DIRECTBEAM
      LOGICAL          DO_PLANE_PARALLEL

C  boundary condition flags

      LOGICAL          MODIFIED_BCL3, MODIFIED_BCL4

C  Fourier component and beam number

      INTEGER          FOURIER_COMPONENT, IPARTIC

C  Linearization control

      INTEGER          LAYER_TO_VARY
      INTEGER          N_LAYER_WFS

C  Surface control, surface factor = 1+delta(m,0)

      INTEGER          SURFTYPE
      LOGICAL          DO_INCLUDE_SURFACE
      DOUBLE PRECISION SURFACE_FACTOR
      DOUBLE PRECISION ALBEDO

C  Numbers

      INTEGER          NBEAMS, NLAYERS, NTOTAL, NPARS

C  Stream

      DOUBLE PRECISION STREAM_VALUE

C  tramsittance factors for solar beams.

      DOUBLE PRECISION
     &     INITIAL_TRANS  ( NLAYERS, NBEAMS ),
     &     T_DELT_MUBAR   ( NLAYERS, NBEAMS )

C  Eigenvector solutions

      DOUBLE PRECISION EIGENTRANS(NLAYERS)
      DOUBLE PRECISION XPOS(2,NLAYERS)
      DOUBLE PRECISION XNEG(2,NLAYERS)

C  particular solutions

      DOUBLE PRECISION WVEC   ( 2, NLAYERS )
      DOUBLE PRECISION WLOWER ( 2, NLAYERS )
      DOUBLE PRECISION WUPPER ( 2, NLAYERS )

C  Direct beam

      DOUBLE PRECISION DIRECT_BEAM ( NBEAMS )

C  Matrix, Band-matrix

      DOUBLE PRECISION SMAT2   (2,2)
      DOUBLE PRECISION BANDMAT2(7,NTOTAL)

C  Pivot matrices

      INTEGER          IPIVOT  (NTOTAL)

C  Solution constants of integration, and related quantities

      DOUBLE PRECISION LCON(NLAYERS)
      DOUBLE PRECISION MCON(NLAYERS)

C  Linearized tramsittance factors for solar beams.

      DOUBLE PRECISION
     &     L_INITIAL_TRANS  ( NLAYERS, NBEAMS,0:NLAYERS,NPARS ),
     &     L_T_DELT_MUBAR   ( NLAYERS, NBEAMS,0:NLAYERS,NPARS )

C  Linearized Beam solutions

      DOUBLE PRECISION L_WVEC(2,NLAYERS,0:NLAYERS,NPARS)

C  Linearized up and down solutions to the homogeneous RT equations

      DOUBLE PRECISION L_EIGENTRANS(NLAYERS,NPARS)
      DOUBLE PRECISION L_XPOS(2,NLAYERS,NPARS)
      DOUBLE PRECISION L_XNEG(2,NLAYERS,NPARS)

C  Direct beam linearizations

      DOUBLE PRECISION L_DELTAU_VERT ( NLAYERS, NPARS )
      DOUBLE PRECISION CHAPMAN_FACTORS ( NLAYERS, NLAYERS, NBEAMS )

C  Outputs
C  -------

C  Linearized Beam solutions at boundaries

      DOUBLE PRECISION L_WUPPER(2,NLAYERS,NPARS)
      DOUBLE PRECISION L_WLOWER(2,NLAYERS,NPARS)

C  Weighting function column matrices

      DOUBLE PRECISION COL2_WF  ( NTOTAL,NPARS)
      DOUBLE PRECISION SCOL2_WF ( 2,     NPARS)

C  local variables
C  ---------------

      INTEGER          Q, N, N1, I, CM, C0, K
      DOUBLE PRECISION CPOS, CNEG, L_HOM, L_BEAM, FAC, L_PAR
      DOUBLE PRECISION HSP_U, HSM_U, CONST, WDEL
      DOUBLE PRECISION VAR1, VAR2, VAR_U, TRANS2, FACTOR
      LOGICAL          REGULAR_BCL3, REGULAR_BCL4

C  initialise
C  ----------

C  zero the results vectors

      DO I = 1, NTOTAL
        DO Q = 1, NPARS
          COL2_WF(I,Q) = 0.0d0
        ENDDO
      ENDDO

C  Layer to vary

      K = LAYER_TO_VARY

C    This is a very important zeroing.................!!!!!

      DO I = 1, 2
        DO Q = 1, N_LAYER_WFS
          DO N = 1, NLAYERS
            L_WUPPER(I,N,Q) = 0.0d0
            L_WLOWER(I,N,Q) = 0.0d0
          ENDDO
        ENDDO
      ENDDO

C  Get the linearized beam solution for the varying layer

      N = K
      CONST   = INITIAL_TRANS(N,IPARTIC)
      WDEL    = T_DELT_MUBAR(N,IPARTIC)
      DO Q = 1, N_LAYER_WFS
        VAR1 = L_T_DELT_MUBAR(N,IPARTIC,N,Q) * CONST
        DO I = 1, 2
          L_WUPPER(I,N,Q) = CONST * L_WVEC(I,N,N,Q)
          L_WLOWER(I,N,Q) = WDEL  * L_WUPPER(I,N,Q) + VAR1*WVEC(I,N)
        ENDDO
      ENDDO

C  complete boundary condition flags

      REGULAR_BCL3 = .NOT.MODIFIED_BCL3
      REGULAR_BCL4 = .NOT.MODIFIED_BCL4

C  BCL1 or BCL3M - top of first layer (TOA), UPPER boundary condition
C  ------------------------------------------------------------------

      N = 1

C    If this layer is the one that is varied, use MODIFIED_BCL3 (BCL3M)
C       .. contribution L_PARTIC from beam  solution variations
C       .. contribution L_HOM    from eigen solution variations
C    Otherwise, entry is zero

      IF ( MODIFIED_BCL3 ) THEN
       DO Q = 1, N_LAYER_WFS
         L_PAR = - L_WUPPER(1,N,Q)
         CPOS  = L_XPOS(1,N,Q)
         CNEG  = EIGENTRANS(N)   * L_XNEG(1,N,Q) +
     &         L_EIGENTRANS(N,Q) *   XNEG(1,N)
         L_HOM = LCON(N) * CPOS + MCON(N) * CNEG
         COL2_WF(1,Q) = L_PAR - L_HOM
        ENDDO
      ELSE
        DO Q = 1, N_LAYER_WFS
          COL2_WF(1,Q) = 0.0d0
        ENDDO
      ENDIF

C  BCL2 Intermediate levels between top layer and varying layer
C  ------------------------------------------------------------

C  [not required if top layer is varying, case MODIFIED_BCL3 above]

      IF ( REGULAR_BCL3 ) THEN
        DO N = 2, LAYER_TO_VARY - 1
          N1 = N - 1
          C0  = 2*N1 - 1
          DO I = 1, 2
            CM = C0 + I
            DO Q = 1, N_LAYER_WFS
              COL2_WF(CM,Q) = 0.0d0
            ENDDO
          ENDDO
        ENDDO
      ENDIF

C  BCL3 - regular upper boundary condition for layer that is varying
C  -----------------------------------------------------------------

      IF ( REGULAR_BCL3 ) THEN
        N = LAYER_TO_VARY
        N1  = N - 1
        C0  = N1*2 - 1
        DO I = 1, 2
          CM = C0 + I
          DO Q = 1, N_LAYER_WFS
            L_PAR = + L_WUPPER(I,N,Q)
            CPOS  = L_XPOS(I,N,Q)
            CNEG  = EIGENTRANS(N)   * L_XNEG(I,N,Q) +
     &            L_EIGENTRANS(N,Q) *   XNEG(I,N)
            L_HOM = LCON(N) * CPOS + MCON(N) * CNEG
            COL2_WF(CM,Q) = L_PAR + L_HOM
          ENDDO
        ENDDO
      ENDIF

C  BCL4 - LOWER boundary condition for varying layer
C  -------------------------------------------------

C   special case when layer-to-vary = last (albedo) layer is treated
C   separately below under MODIFIED BCL4.

      IF ( REGULAR_BCL4 ) THEN
        N  = LAYER_TO_VARY
        N1 = N + 1
        C0 = N*2 - 1

C  Get the linearized beam solution for the next layer
C  Distinguish two cases
C  ..(a) quasi-spherical for n > 1 (only gets done for this case anyway)
C  ..(b) plane-parallel and qs for n = 1
C     Consistent logarithmic linearization of INITIAL_TRANS

        CONST   = INITIAL_TRANS(N1,IPARTIC)
        WDEL    = T_DELT_MUBAR(N1,IPARTIC)
        TRANS2  = CONST * WDEL
        IF ( .NOT. DO_PLANE_PARALLEL  ) THEN
          DO Q = 1, N_LAYER_WFS
            VAR1 = L_T_DELT_MUBAR(N1,IPARTIC,K,Q) * CONST
            VAR2 = L_INITIAL_TRANS(N1,IPARTIC,K,Q)
            DO I = 1, 2
              VAR_U = VAR2 * WVEC(I,N1) + L_WVEC(I,N1,K,Q)
              L_WUPPER(I,N1,Q) = CONST  * VAR_U
              L_WLOWER(I,N1,Q) = TRANS2 * VAR_U + VAR1 * WVEC(I,N1)
            ENDDO
          ENDDO
        ELSE
          DO Q = 1, N_LAYER_WFS
            VAR1 = L_INITIAL_TRANS(N1,IPARTIC,K,Q) * CONST
            DO I = 1, 2
              L_WUPPER(I,N1,Q) = VAR1 * WVEC(I,N1)
              L_WLOWER(I,N1,Q) = L_WUPPER(I,N1,Q) * WDEL
            ENDDO
          ENDDO
        ENDIF

C  .. 2 contributions to WVAR from beam solution variations BEAM_V and BEAM_U
C  .. contribution HVAR homogeneous (eigenvalue) solution variations

        DO I = 1, 2
          CM = C0 + I
          DO Q = 1, N_LAYER_WFS
            L_PAR = L_WUPPER(I,N1,Q) - L_WLOWER(I,N,Q)
            CNEG  = L_XNEG(I,N,Q)
            CPOS  = EIGENTRANS(N)   * L_XPOS(I,N,Q) +
     &            L_EIGENTRANS(N,Q) *   XPOS(I,N)
            L_HOM = LCON(N)*CPOS + MCON(N)*CNEG
            COL2_WF(CM,Q) = L_PAR - L_HOM
          ENDDO
        ENDDO

C  End Modified BCL4

      ENDIF

C  BCL5 - Intermediate boundary conditions between varying layer & final layer
C  ---------------------------------------------------------------------------

      IF ( REGULAR_BCL4 ) THEN

        DO N = LAYER_TO_VARY + 1, NLAYERS - 1

          N1 = N + 1
          C0  = N*2 - 1

C  Get the linearized beam solution for the next layer
C  Distinguish two cases
C  ..(a) quasi-spherical for n > 1 (only gets done for this case anyway)
C  ..(b) plane-parallel and qs for n1 = 1
C     Consistent logarithmic linearization of INITIAL_TRANS

          CONST   = INITIAL_TRANS(N1,IPARTIC)
          WDEL    = T_DELT_MUBAR(N1,IPARTIC)
          TRANS2  = CONST * WDEL
          IF ( .NOT. DO_PLANE_PARALLEL  ) THEN
            DO Q = 1, N_LAYER_WFS
              VAR1 = L_T_DELT_MUBAR(N1,IPARTIC,K,Q) * CONST
              VAR2 = L_INITIAL_TRANS(N1,IPARTIC,K,Q)
              DO I = 1, 2
                VAR_U = VAR2 * WVEC(I,N1) + L_WVEC(I,N1,K,Q)
                L_WUPPER(I,N1,Q) = CONST  * VAR_U
                L_WLOWER(I,N1,Q) = TRANS2 * VAR_U + VAR1 * WVEC(I,N1)
              ENDDO
            ENDDO
          ELSE
            DO Q = 1, N_LAYER_WFS
              VAR1 = L_INITIAL_TRANS(N1,IPARTIC,K,Q) * CONST
              DO I = 1, 2
                L_WUPPER(I,N1,Q) = VAR1 * WVEC(I,N1)
                L_WLOWER(I,N1,Q) = L_WUPPER(I,N1,Q) * WDEL
              ENDDO
            ENDDO
          ENDIF

C  .. contributions from beam solution (direct assign). No homog. variation

          DO I = 1, 2
            CM = C0 + I
            DO Q = 1, N_LAYER_WFS
              COL2_WF(CM,Q) = L_WUPPER(I,N1,Q) - L_WLOWER(I,N,Q)
            ENDDO
          ENDDO

C  end layer loop

        ENDDO

C  end BCL5 boundary conditions

      ENDIF

C  Final layer - use BCL6 or BCL4M (last layer is varying)
C  -------------------------------------------------------

      N = NLAYERS
      C0 = (N-1)*2 + 1
      CM = C0 + 1
      FACTOR = SURFACE_FACTOR * ALBEDO * STREAM_VALUE

C  Modified BCL4M Component loop

      IF ( MODIFIED_BCL4 ) THEN
       IF ( DO_INCLUDE_SURFACE ) THEN
        DO Q = 1, N_LAYER_WFS
          HSP_U = L_XPOS(1,N,Q) *   EIGENTRANS(N) +
     &              XPOS(1,N)   * L_EIGENTRANS(N,Q)
          HSM_U = L_XNEG(1,N,Q)
          L_PAR = L_WLOWER(2,N,Q) - L_WLOWER(1,N,Q)* FACTOR
          CPOS  =   EIGENTRANS(N)   * L_XPOS(2,N,Q) +
     &            L_EIGENTRANS(N,Q) *   XPOS(2,N)
          CPOS  = CPOS          - HSP_U * FACTOR
          CNEG  = L_XNEG(2,N,Q) - HSM_U * FACTOR
          L_HOM = LCON(N)*CPOS + MCON(N)*CNEG
          COL2_WF(CM,Q) = - L_PAR - L_HOM
        ENDDO
       ELSE
        DO Q = 1, N_LAYER_WFS
          L_PAR = L_WLOWER(2,N,Q)
          CPOS  =   EIGENTRANS(N)   * L_XPOS(2,N,Q) +
     &            L_EIGENTRANS(N,Q) *   XPOS(2,N)
          CNEG  = L_XNEG(2,N,Q)
          L_HOM = LCON(N)*CPOS + MCON(N)*CNEG
          COL2_WF(CM,Q) = - L_PAR - L_HOM
        ENDDO
       ENDIF
      ENDIF

C  ordinary BCL6 Component loop

      IF ( .NOT. MODIFIED_BCL4 ) THEN
       IF ( DO_INCLUDE_SURFACE ) THEN
        DO Q = 1, N_LAYER_WFS
          L_PAR = L_WLOWER(2,N,Q) - L_WLOWER(1,N,Q)* FACTOR
          COL2_WF(CM,Q) = - L_PAR
        ENDDO
       ELSE
        DO Q = 1, N_LAYER_WFS
          COL2_WF(CM,Q) = - L_WLOWER(2,N,Q)
        ENDDO
       ENDIF
      ENDIF

C  Add direct beam variation to Final boundary
C  -------------------------------------------

      IF ( DO_INCLUDE_DIRECTBEAM ) THEN
        CM = C0 + 1
        FAC = - DIRECT_BEAM(IPARTIC) *
     &              CHAPMAN_FACTORS(N,LAYER_TO_VARY,IPARTIC)
        DO Q = 1, N_LAYER_WFS
          L_BEAM = L_DELTAU_VERT(LAYER_TO_VARY,Q) * FAC
          COL2_WF(CM,Q) = COL2_WF(CM,Q) + L_BEAM
        ENDDO
      ENDIF

C  Copy for the one-layer case

      IF ( NLAYERS .EQ. 1 ) THEN
        DO I = 1, 1
          DO Q = 1, N_LAYER_WFS
            SCOL2_WF(I,Q) = COL2_WF(I,Q)
          ENDDO
        ENDDO
      ENDIF

C  finish

      RETURN
      END

C

      SUBROUTINE TWOSTREAM_L_BVP_C_COLUMN_SETUP
     I       ( DO_INCLUDE_DIRECTBEAM, DO_PLANE_PARALLEL,
     I         FOURIER_COMPONENT,  IPARTIC, N_WEIGHTFUNCS,
     I         NBEAMS, NLAYERS, NTOTAL, NPARS,
     I         DO_INCLUDE_SURFACE, SURFTYPE, SURFACE_FACTOR,
     I         ALBEDO, STREAM_VALUE, DIRECT_BEAM,
     I         INITIAL_TRANS, T_DELT_MUBAR, WVEC, WUPPER, WLOWER,
     I         EIGENTRANS, XPOS, XNEG,
     I         BANDMAT2, SMAT2, IPIVOT, LCON, MCON,
     I         L_INITIAL_TRANS, L_T_DELT_MUBAR, L_WVEC,
     I         L_EIGENTRANS, L_XPOS, L_XNEG,
     I         L_DELTAU_VERT, CHAPMAN_FACTORS,
     O         L_WUPPER, L_WLOWER, COL2_WF, SCOL2_WF )

C  input arguments
C  ---------------

C  inclusion flags

      LOGICAL          DO_INCLUDE_DIRECTBEAM
      LOGICAL          DO_PLANE_PARALLEL

C  Fourier component and beam number

      INTEGER          FOURIER_COMPONENT, IPARTIC

C  Linearization control

      INTEGER          N_WEIGHTFUNCS

C  Surface control

      INTEGER          SURFTYPE
      LOGICAL          DO_INCLUDE_SURFACE
      DOUBLE PRECISION SURFACE_FACTOR
      DOUBLE PRECISION ALBEDO

C  Numbers

      INTEGER          NBEAMS, NLAYERS, NTOTAL, NPARS

C  Stream

      DOUBLE PRECISION STREAM_VALUE

C  tramsittance factors for solar beams.

      DOUBLE PRECISION
     &     INITIAL_TRANS  ( NLAYERS, NBEAMS ),
     &     T_DELT_MUBAR   ( NLAYERS, NBEAMS )

C  Eigenvector solutions

      DOUBLE PRECISION EIGENTRANS(NLAYERS)
      DOUBLE PRECISION XPOS(2,NLAYERS)
      DOUBLE PRECISION XNEG(2,NLAYERS)

C  particular solutions

      DOUBLE PRECISION WVEC   ( 2, NLAYERS )
      DOUBLE PRECISION WLOWER ( 2, NLAYERS )
      DOUBLE PRECISION WUPPER ( 2, NLAYERS )

C  Direct beam

      DOUBLE PRECISION DIRECT_BEAM ( NBEAMS )

C  Matrix, Band-matrix

      DOUBLE PRECISION SMAT2   (2,2)
      DOUBLE PRECISION BANDMAT2(7,NTOTAL)

C  Pivot matrices

      INTEGER          IPIVOT  (NTOTAL)

C  Solution constants of integration, and related quantities

      DOUBLE PRECISION LCON(NLAYERS)
      DOUBLE PRECISION MCON(NLAYERS)

C  Linearized tramsittance factors for solar beams.

      DOUBLE PRECISION
     &     L_INITIAL_TRANS  ( NLAYERS, NBEAMS,0:NLAYERS,NPARS ),
     &     L_T_DELT_MUBAR   ( NLAYERS, NBEAMS,0:NLAYERS,NPARS )

C  Linearized Beam solutions

      DOUBLE PRECISION L_WVEC(2,NLAYERS,0:NLAYERS,NPARS)

C  Linearized up and down solutions to the homogeneous RT equations

      DOUBLE PRECISION L_EIGENTRANS(NLAYERS,NPARS)
      DOUBLE PRECISION L_XPOS(2,NLAYERS,NPARS)
      DOUBLE PRECISION L_XNEG(2,NLAYERS,NPARS)

C  Direct beam linearizations

c      DOUBLE PRECISION DELTAU_VERT   ( NLAYERS )
      DOUBLE PRECISION L_DELTAU_VERT ( NLAYERS, NPARS )
      DOUBLE PRECISION CHAPMAN_FACTORS  ( NLAYERS, NLAYERS, NBEAMS )

C  Outputs
C  -------

C  Linearized Beam solutions at boundaries

      DOUBLE PRECISION L_WUPPER(2,NLAYERS,NPARS)
      DOUBLE PRECISION L_WLOWER(2,NLAYERS,NPARS)

C  Weighting function column matrices

      DOUBLE PRECISION COL2_WF  ( NTOTAL,NPARS)
      DOUBLE PRECISION SCOL2_WF ( 2,     NPARS)

C  local variables
C  ---------------

      INTEGER          Q, N, N1, I, CM, C0, K
      DOUBLE PRECISION CPOS, CNEG, L_HOM, L_BEAM, FAC, FAC3
      DOUBLE PRECISION HSP_U, HSM_U, CONST, WDEL, FACTOR, L_PAR
      DOUBLE PRECISION VAR1, VAR2, VAR_U, TRANS2, L_HOMU, L_HOMD

C  initialise
C  ----------

C  zero the results vectors

      DO I = 1, NTOTAL
        DO Q = 1, N_WEIGHTFUNCS
          COL2_WF(I,Q) = 0.0d0
        ENDDO
      ENDDO

C  Very important zeroing

      DO K = 1, NLAYERS
        DO I = 1, 2
          DO Q = 1, N_WEIGHTFUNCS
            L_WUPPER(I,K,Q) = 0.0d0
            L_WLOWER(I,K,Q) = 0.0d0
          ENDDO
        ENDDO
      ENDDO

C  Top of first layer (TOA), UPPER boundary condition
C  --------------------------------------------------

      N = 1

C  Get the linearized beam solution for the first layer

      CONST   = INITIAL_TRANS(N,IPARTIC)
      WDEL    = T_DELT_MUBAR(N,IPARTIC)
      TRANS2  = CONST * WDEL
      DO Q = 1, N_WEIGHTFUNCS
        VAR1 = L_T_DELT_MUBAR(N,IPARTIC,0,Q) * CONST
        VAR2 = L_INITIAL_TRANS(N,IPARTIC,0,Q)
        DO I = 1, 2
          VAR_U = VAR2 * WVEC(I,N) + L_WVEC(I,N,0,Q)
          L_WUPPER(I,N,Q) = CONST  * VAR_U
          L_WLOWER(I,N,Q) = TRANS2 * VAR_U + VAR1 * WVEC(I,N)
        ENDDO
      ENDDO

C  COmpute the column contributions

      DO Q = 1, N_WEIGHTFUNCS
        L_PAR = - L_WUPPER(1,N,Q)
        CPOS  = L_XPOS(1,N,Q)
        CNEG  =   EIGENTRANS(N)   * L_XNEG(1,N,Q) +
     &          L_EIGENTRANS(N,Q) *   XNEG(1,N)
        L_HOM = LCON(N) * CPOS + MCON(N) * CNEG
        COL2_WF(1,Q) = L_PAR - L_HOM
      ENDDO

C  Intermediate boundary conditions
C  --------------------------------

      DO N = 1, NLAYERS - 1

C  N1 is the layer below, C0 is the offset

        N1 = N + 1
        C0 = N*2 - 1

C  Get the linearized beam solution for the next layer

        CONST   = INITIAL_TRANS(N1,IPARTIC)
        WDEL    = T_DELT_MUBAR(N1,IPARTIC)
        TRANS2  = CONST * WDEL
        DO Q = 1, N_WEIGHTFUNCS
          VAR1 = L_T_DELT_MUBAR(N1,IPARTIC,0,Q) * CONST
          VAR2 = L_INITIAL_TRANS(N1,IPARTIC,0,Q)
          DO I = 1, 2
            VAR_U = VAR2 * WVEC(I,N1) + L_WVEC(I,N1,0,Q)
            L_WUPPER(I,N1,Q) = CONST  * VAR_U
            L_WLOWER(I,N1,Q) = TRANS2 * VAR_U + VAR1 * WVEC(I,N1)
          ENDDO
        ENDDO

C  .. 2 contributions to L_BEAM, from variations L_WUPPER L_WLOWER
C  .. 2 contributions to L_HOM,  from variations above and below

        DO I = 1, 2
          CM = C0 + I
          DO Q = 1, N_WEIGHTFUNCS
            CPOS = L_XPOS(I,N1,Q)
            CNEG =   EIGENTRANS(N1)   * L_XNEG(I,N1,Q) +
     &             L_EIGENTRANS(N1,Q) *   XNEG(I,N1)
            L_HOMU = LCON(N1) * CPOS + MCON(N1) * CNEG
            CNEG = L_XNEG(I,N,Q)
            CPOS =   EIGENTRANS(N)   * L_XPOS(I,N,Q) +
     &             L_EIGENTRANS(N,Q) *   XPOS(I,N)
            L_HOMD = LCON(N)*CPOS + MCON(N)*CNEG
            L_PAR  = L_WUPPER(I,N1,Q) - L_WLOWER(I,N,Q)
            L_HOM  = L_HOMU - L_HOMD
            COL2_WF(CM,Q) = L_PAR + L_HOM
          ENDDO
        ENDDO

C  End layer

      ENDDO

C  LOWEST layer
C  ------------

      N = NLAYERS
      C0 = (N-1)*2 + 1
      CM = C0 + 1
      FACTOR = SURFACE_FACTOR * ALBEDO * STREAM_VALUE

      IF ( DO_INCLUDE_SURFACE ) THEN
        DO Q = 1, N_WEIGHTFUNCS
          HSP_U = L_XPOS(1,N,Q) *   EIGENTRANS(N) +
     &              XPOS(1,N)   * L_EIGENTRANS(N,Q)
          HSM_U = L_XNEG(1,N,Q)
          L_PAR = L_WLOWER(2,N,Q) - L_WLOWER(1,N,Q) * FACTOR
          CPOS  =   EIGENTRANS(N)   * L_XPOS(2,N,Q) +
     &            L_EIGENTRANS(N,Q) *   XPOS(2,N)
          CPOS  = CPOS          - HSP_U * FACTOR
          CNEG  = L_XNEG(2,N,Q) - HSM_U * FACTOR
          L_HOM = LCON(N)*CPOS + MCON(N)*CNEG
          COL2_WF(CM,Q) = - L_PAR - L_HOM
        ENDDO
      ELSE
        DO Q = 1, N_WEIGHTFUNCS
          L_PAR = L_WLOWER(2,N,Q)
          CPOS  =   EIGENTRANS(N)   * L_XPOS(2,N,Q) +
     &            L_EIGENTRANS(N,Q) *   XPOS(2,N)
          CNEG  = L_XNEG(2,N,Q)
          L_HOM = LCON(N)*CPOS + MCON(N)*CNEG
          COL2_WF(CM,Q) = - L_PAR - L_HOM
        ENDDO
      ENDIF

C  Add direct beam variation to Final boundary
C  -------------------------------------------

      IF ( DO_INCLUDE_DIRECTBEAM ) THEN
        FAC = - DIRECT_BEAM(IPARTIC)
        DO Q = 1, N_WEIGHTFUNCS
          L_BEAM = 0.0d0
          DO K = 1, NLAYERS
            FAC3 = FAC * CHAPMAN_FACTORS(N,K,IPARTIC)
            L_BEAM = L_BEAM + L_DELTAU_VERT(K,Q) * FAC3
          ENDDO
          COL2_WF(CM,Q) = COL2_WF(CM,Q) + L_BEAM
        ENDDO
      ENDIF

C  Copy for the one-layer case

      IF ( NLAYERS .EQ. 1 ) THEN
        DO I = 1, 2
          DO Q = 1, N_WEIGHTFUNCS
            SCOL2_WF(I,Q) = COL2_WF(I,Q)
          ENDDO
        ENDDO
      ENDIF

C  finish

      RETURN
      END

C

      SUBROUTINE TWOSTREAM_BVP_LS_SOLUTION_MASTER
     I       ( DO_INCLUDE_DIRECTBEAM, DO_INCLUDE_SURFACE,
     I         FOURIER_COMPONENT, IBEAM, SURFTYPE,
     I         NBEAMS, NLAYERS, NTOTAL, DIRECT_BEAM,
     I         BANDMAT2, SMAT2, IPIVOT,
     I         LCON, MCON, EIGENTRANS,
     I         R2_HOMP, R2_HOMM, R2_PARTIC,
     O         COL2_WFALB, SCOL2_WFALB,
     O         NCONALB, PCONALB,
     O         STATUS )

C  WARNING. Only valid for

C  input arguments
C  ---------------

C  inclusion flags

      LOGICAL          DO_INCLUDE_DIRECTBEAM

C  Surface control

      INTEGER          SURFTYPE
      LOGICAL          DO_INCLUDE_SURFACE

C  Numbers

      INTEGER          NBEAMS, NLAYERS, NTOTAL

C  Fourier component and beam number

      INTEGER          FOURIER_COMPONENT, IBEAM

C  ginesolution transmittances

      DOUBLE PRECISION EIGENTRANS(NLAYERS)

C  Diffuse solution at surface (stream value)

      DOUBLE PRECISION R2_HOMP, R2_HOMM, R2_PARTIC

C  Solution constants of integration, and related quantities

      DOUBLE PRECISION LCON(NLAYERS)
      DOUBLE PRECISION MCON(NLAYERS)

C  Reflected Direct beam at surface

      DOUBLE PRECISION DIRECT_BEAM ( NBEAMS )

C  Matrix, Band-matrix

      DOUBLE PRECISION SMAT2   (2,2)
      DOUBLE PRECISION BANDMAT2(7,NTOTAL)

C  Pivot matrices

      INTEGER          IPIVOT  (NTOTAL)

C  output
C  ------

C  Weighting function column matrices

      DOUBLE PRECISION COL2_WFALB  ( NTOTAL,1)
      DOUBLE PRECISION SCOL2_WFALB ( 2,     1)

C  Linearized Solution constants of integration, and related quantities

      DOUBLE PRECISION NCONALB(NLAYERS)
      DOUBLE PRECISION PCONALB(NLAYERS)

C  status

      INTEGER          STATUS

C  Local variables
C  ---------------

      INTEGER          N, I, C0, CM
      DOUBLE PRECISION A, B, IDOWNSURF_Q

C  error tracing variables

      INTEGER          INFO
      CHARACTER*3      CI
      CHARACTER*70     MAIL, TRACE

C  Linearization of the regular BVP case
C  =====================================

C  set status

      STATUS = 0

C  Exit if Fourier component is not 0 and Surface type  not 1
C    This is the Lambertian condition

      IF ( .NOT. DO_INCLUDE_SURFACE .OR.
     &    (FOURIER_COMPONENT.NE.0 .and. SURFTYPE.EQ.1) ) RETURN

C  Set up the column vectors for Surface linearizations
C  ----------------------------------------------------

C  initialise; Only contribution is from lowest layer
C  boundary conditions not changed for all higher levels

      DO I = 1, NTOTAL
        COL2_WFALB(I,1) = 0.0d0
      ENDDO

      N  = NLAYERS
      CM = (N-1) * 2 + 2

      IDOWNSURF_Q = R2_PARTIC + MCON(N) * R2_HOMM +
     &                          LCON(N) * R2_HOMP * EIGENTRANS(N)
      COL2_WFALB(CM,1) = IDOWNSURF_Q
      IF ( DO_INCLUDE_DIRECTBEAM ) COL2_WFALB(CM,1) =
     &       COL2_WFALB(CM,1) + DIRECT_BEAM(IBEAM)

C  Copy for the single layer case

      IF ( NLAYERS .EQ. 1 ) THEN
        DO N = 1, NTOTAL
          SCOL2_WFALB(N,1) = COL2_WFALB(N,1)
        ENDDO
      ENDIF

C  BVP back-substitution: With compression (multilayers)
C  -----------------------------------------------------

      IF ( NLAYERS .GT. 1 ) THEN

C  LAPACK substitution (DGBTRS) using RHS column vector COL2_WF
C  BV solution for perturbed integration constants
C    ( call to LAPACK solver routine for back substitution )

        CALL DGBTRS
     &     ( 'n', NTOTAL, 2, 2, 1,
     &        BANDMAT2, 7, IPIVOT,
     &        COL2_WFALB, NTOTAL, INFO )

C  Error tracing

        IF ( INFO .LT. 0 ) THEN
          WRITE(CI, '(I3)' ) INFO
          MAIL  = 'argument i illegal value, for i = '//CI
          TRACE = 'Surface_Wfs for Lambertian weighting function '//
     *         '; (multilayer) DGBTRS call in LS_BVP_SOLUTION_MASTER'
          STATUS = 1
          CALL TWOSTREAM_ERROR_TRACE ( MAIL, TRACE, STATUS )
          RETURN
         ENDIF

C  Set integration constants NCON and PCON for +/- eigensolutions

        DO N = 1, NLAYERS
          C0 = (N-1)*2
          NCONALB(N) = COL2_WFALB(C0+1,1)
          PCONALB(N) = COL2_WFALB(C0+2,1)
        ENDDO

C  Solve the boundary problem: No compression, Single Layer only
C  -------------------------------------------------------------

      ELSE IF ( NLAYERS .EQ. 1 ) THEN
        A = SCOL2_WFALB(1,1)
        B = SCOL2_WFALB(2,1)
        SCOL2_WFALB(1,1) = SMAT2(1,1) * A + smat2(1,2) * B
        SCOL2_WFALB(2,1) = SMAT2(2,1) * A + smat2(2,2) * B
        NCONALB(1) = SCOL2_WFALB(1,1)
        PCONALB(1) = SCOL2_WFALB(2,1)
      ENDIF

C  debug
c      do n = 1, nlayers
c        write(*,*)n,NCONALB(n),pconalb(n)
c      enddo

C  Finish

      RETURN
      END

max_stars_repo_name: GEOS-ESM/AeroApps

max_issues_repo_name: GEOS-ESM/AeroApps

max_forks_repo_name: GEOS-ESM/AeroApps


text:
      subroutine sctdgl(n,itri,  adgl)
************************************************************************
*
*   SCTDGL -- For each element, scatter the diagonal contribution of
*             the local mass matrix to the global mass matrix diagonal.
*
************************************************************************
      include "parameters.h"

      integer tvtx
      common /mfe011/ tvtx(0:2,mtri)

      double precision a
      common /loc013/ a(65,9,0:2,0:2)

      integer n,itri,v0,v1,v2,i,j
      double precision adgl(9,*)

      do 10 j=1,n

      v0 = tvtx(0, j+itri-1)
      v1 = tvtx(1, j+itri-1)
      v2 = tvtx(2, j+itri-1)

      do 10 i=1,9
       adgl(i, v0) = adgl(i, v0) + a(j, i, 0,0)
       adgl(i, v1) = adgl(i, v1) + a(j, i, 1,1)
       adgl(i, v2) = adgl(i, v2) + a(j, i, 2,2)
   10 continue

      return
      end

ext: f

max_stars_repo_name: mfeproject/legacy-gwmfe

max_issues_repo_name: mfeproject/legacy-gwmfe

max_forks_repo_name: mfeproject/legacy-gwmfe


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

! tests internal procedure as a pointer target

module mod
  logical rslt(2), expect(2)

contains

  subroutine foo()
    procedure(bar), pointer :: p
    integer a
    p=>bar
    a = 0
    call bar()
    !print *, a
    rslt(1) = a .eq. -99
    a = 1
    call p()
    !print *, a
    rslt(2) = a .eq. -99

  contains

    subroutine bar()
      a=-99
    end subroutine bar
  end subroutine foo
end module mod

use mod
expect = .true.
rslt = .false.
call foo()
call check(rslt, expect, 2)
end program

max_stars_repo_name: abrahamtovarmob/flang

max_issues_repo_name: abrahamtovarmob/flang

max_forks_repo_name: abrahamtovarmob/flang


text:
      subroutine ct1d_d(c1,d2,t2,dect1d)

      implicit double precision(a-h,o-z)

      dimension d2(3),t2(3,3),dect1d(3)

c  this subroutine evaluates the quadrupole-quadrupole
c  electrostatic interaction

      dect1d(1)=c1*(t2(1,1)*d2(1)+t2(1,2)*d2(2)+t2(1,3)*d2(3))
      dect1d(2)=c1*(t2(1,2)*d2(1)+t2(2,2)*d2(2)+t2(2,3)*d2(3))
      dect1d(3)=c1*(t2(1,3)*d2(1)+t2(2,3)*d2(2)+t2(3,3)*d2(3))

      return
      end

max_stars_repo_name: mickcollins/SMFA

max_issues_repo_name: mickcollins/SMFA

max_forks_repo_name: mickcollins/SMFAPAC


        !COMPILER-GENERATED INTERFACE MODULE: Fri Mar  6 15:35:06 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE PREPARE_UVPS__genmod
          INTERFACE
            SUBROUTINE PREPARE_UVPS(POU,POV,POPS0,POPS1,PU0,PV0,PPS0,PU1&
     &,PV1,PPS1)
              REAL(KIND=8), INTENT(OUT) :: POU(64,32,10)
              REAL(KIND=8), INTENT(OUT) :: POV(64,32,10)
              REAL(KIND=8), INTENT(OUT) :: POPS0(64,32)
              REAL(KIND=8), INTENT(OUT) :: POPS1(64,32)
              REAL(KIND=8), INTENT(IN) :: PU0(2048,10)
              REAL(KIND=8), INTENT(IN) :: PV0(2048,10)
              REAL(KIND=8), INTENT(IN) :: PPS0(2048)
              REAL(KIND=8), INTENT(IN) :: PU1(2048,10)
              REAL(KIND=8), INTENT(IN) :: PV1(2048,10)
              REAL(KIND=8), INTENT(IN) :: PPS1(2048)
            END SUBROUTINE PREPARE_UVPS
          END INTERFACE
        END MODULE PREPARE_UVPS__genmod


text:
program matdrv
    use param
    use mathieu

    implicit none
    integer   ndec, i, j, k, l, nex, kindd, kindq, icq, isq, minacc, narg, &
              lnum, izxi, ioprad, iopang, max, maxd, maxj, maxk, maxn, maxp, &
              maxterm, maxbp, maxkbp, maxlp, ismax
    real(knd) cm, q, arg1, darg, r, x1, z, xi

    real(knd), dimension(:), allocatable ::     arg
    real(knd), dimension(:), allocatable ::     mc1c, mc1dc, mc23c, mc23dc, &
                                                ms1c, ms1dc, ms23c, ms23dc
    integer, dimension(:), allocatable ::       mc1e, mc1de, mc23e, mc23de, &
                                                ms1e, ms1de, ms23e, ms23de, &
                                                acc_rc, acc_rs
    integer, dimension(:,:), allocatable ::     acc_acs
    real(knd), dimension (:,:), allocatable ::  ce, ced, se, sed
    character (len = 9) kstr, fstr, astr
    character (len = 256) tstr

    kindd = 8
    kindq = 16

    if(knd == kindd) then
        kstr = "e23.14"
        fstr = "f17.14"
    else if (knd == kindq) then
        kstr = "e39.30"
        fstr = "f17.14"   ! normally "f33.30"
    end if
    astr = "e23.14"

    ndec = precision(cm)
    nex = range(cm) - 1

!   open input and output files
    open(1, file='matfcn.dat')
    open(20 ,file='fort.20')
    open(30, file='fort.30')
    open(40 ,file='fort.20')
    open(50, file='fort.30')
    open(60, file='fort.30')

    read(1, *) lnum, ioprad, iopang, izxi, icq, isq

    if (icq == 1) read(1,*) q
    if (icq == 2) read(1,*) cm
    read(1, *) r
    if (iopang /= 0) read(1, *) arg1, darg, narg

    select case (icq)
    case (1)
        cm = sqrt(2.0e0_knd * abs(q))
        if (q < 0.0e0_knd) isq = -1
    case (2)
          q = cm * cm / 2.0e0_knd
          if (isq == -1) q = -q
    end select

    select case (izxi)
    case (1)
          x1 = 2.0e0_knd * (sinh(0.5e0_knd * z)) ** 2
          z = r
    case (2)
          x1 = r
          z = 0.0e0_knd
    end select
    if(iopang  ==  0) narg = 1

    maxj = 1
    if(ioprad /= 0) maxj = 1.5 * lnum + 4 * ndec + int(cm) + 105

    if(isq == 1) then
        ismax = int(0.85e0_knd * cm)
        if(x1 < 1.0e0_knd) ismax = 1.5 * ismax
        if(x1 < 0.1e0_knd .and. x1 >= 0.00001e0_knd) &
            ismax = ismax * int(3.0e0_knd ** (-1.0e0_knd - log10(x1)))
        if(x1 < 0.00001e0_knd) ismax = 81 * ismax

        maxj = max(maxj, ismax + int(cm / 3.14159 )+ 4 * ndec + int(cm) + 105)
    end if

    maxp = 2 * lnum + 2 * cm + 4 * ndec + 105
    maxn = maxj
    maxk = 1
    maxkbp = 1

    if (ioprad /= 0 .and. isq /= 1 .and. x1 /= 0.0e0_knd) then
        maxkbp = lnum + 4 * ndec + int(cm) + 103
        if(minacc > ndec - 2 .or. (minacc > ndec - 4 .and. cm >  5.0e0_knd) &
                             .or. (minacc > ndec - 6 .and. cm > 10.0e0_knd) &
                             .or. (minacc > ndec - 8 .and. cm > 15.0e0_knd) &
                             .or. cm > 20e0_knd) then
            maxk = 1.5 * cm + 100
            if(x1 < 1.0e0_knd .and. x1 >= 0.01e0_knd) &
                maxk = 40 / x1 + cm / sqrt(x1) + 1.5 * cm + 200
            if(x1 < 0.01e0_knd.and.x1 > 0.0e0_knd) &
                maxk = 34 / x1 + 1.5 * cm + 1.4 * cm / sqrt(x1) + 200
            maxterm = 10000000
            maxk = min(maxk, maxterm)
            maxk = max(maxk, maxj)
        end if
    end if

    maxd = max(maxj, maxn, maxk, maxkbp, maxp) / 2 + 1

    maxlp = lnum + 3
    if(isq == -1) maxlp = max(maxlp, ismax + int(cm /3.14159) + 3)

    xi = x1 + 1.0e0_knd

    if(ioprad /= 0 .and. izxi == 1) write(20, "(1x,' z = '," // kstr // ")") z

    if(ioprad /= 0 .and. izxi == 2) write(20, "(1x,'xi = '," // kstr // ")") xi

    if(icq == 1) then
        if (ioprad /= 0) write(20, "(1x,' q = '," // kstr // ")") q
        if (iopang /= 0) write(30, "(1x,' q = '," // kstr // ")") q
    end if

    if(icq == 2) then
        if (ioprad /= 0) then
            if (isq == 1)  write(20, "(1x,' c = '," // kstr // ")") cm
            if (isq == -1) write(20, "(1x,' c = i times'," // kstr // ")") cm
        end if
        if (iopang /= 0) then
            if (isq == 1)  write(30, "(1x,' c = '," // kstr // ")") cm
            if (isq == -1) write(30, "(1x,' c = i times'," // kstr // ")") cm
        end if
    end if

    allocate (arg(narg), acc_rc(lnum), acc_rs(lnum), acc_acs(lnum, narg))
    allocate (mc1c(lnum),mc1dc(lnum),mc23c(lnum),mc23dc(lnum), &
              ms1c(lnum),ms1dc(lnum),ms23c(lnum),ms23dc(lnum))
    allocate (mc1e(lnum),mc1de(lnum),mc23e(lnum),mc23de(lnum), &
              ms1e(lnum),ms1de(lnum),ms23e(lnum),ms23de(lnum))
    allocate (ce(lnum,narg),ced(lnum,narg), &
              se(lnum,narg),sed(lnum,narg))

    if(iopang /= 0) then
        do j = 1, narg
            arg(j) = arg1 + (j - 1) * darg
        end do
    end if

    call matfcn(lnum, ioprad, izxi, icq, isq, cm, r, iopang, narg, arg, &
                mc1c, mc1e, mc1dc, mc1de, mc23c, mc23e, mc23dc, mc23de, acc_rc, &
                ms1c, ms1e, ms1dc, ms1de, ms23c, ms23e, ms23dc, ms23de, acc_rs, &
                ce, ced, se, sed, acc_acs)

    do i = 1, lnum
        l = i - 1

        if(iopang  /=  0) write(30, 70) l
70      format(1x,'l = ',i6)

        if(isq /= -1) then
            tstr = "(1x,i5,2x,4(" // fstr // ",i6,2x), i2)"
            write(20, tstr) l,mc1c(i),mc1e(i),mc1dc(i),mc1de(i),mc23c(i),mc23e(i),mc23dc(i),mc23de(i),acc_rc(i)
            tstr = "(8x,4(" // fstr // ",i6,2x), i2)"
            if(l > 0) write(20, tstr) ms1c(i),ms1e(i),ms1dc(i),ms1de(i),ms23c(i),ms23e(i),ms23dc(i),ms23de(i),acc_rs(i)
        else
            tstr = "(1x,i5,2x,4(" // fstr // ",i7,2x), i2)"
            write(20, tstr) l,mc1c(i),mc1e(i),mc1dc(i),mc1de(i),mc23c(i),mc23e(i),mc23dc(i),mc23de(i),acc_rc(i)
            tstr = "(8x,4(" // fstr // ",i7,2x), i2)"
            if(l > 0) write(20, tstr) ms1c(i),ms1e(i),ms1dc(i),ms1de(i),ms23c(i),ms23e(i),ms23dc(i),ms23de(i),acc_rs(i)
        end if

       do k = 1,narg
            if(iopang == 1) then
                tstr = "(4x," // fstr // ",5x," // astr // ",2x," // astr // ",2x,i2)"
                write(30, tstr) arg(k),ce(i,k),se(i,k), acc_acs(i,k)
            else if(iopang == 2) then
                tstr = "(4x," // fstr // ",5x," // astr // ",2x," // astr // ",2x,/,26x," // astr // ",2x," // astr // ",2x,i2)"
                write(30, tstr) arg(k),ce(i,k),ced(i,k),se(i,k),sed(i,k), acc_acs(i,k)
            endif
        end do
    end do

    deallocate (mc1c,mc1dc,mc23c,mc23dc,ms1c,ms1dc,ms23c,ms23dc)
    deallocate (mc1e,mc1de,mc23e,mc23de,ms1e,ms1de,ms23e,ms23de)
    deallocate (ce,ced,se,sed)
    deallocate (acc_rc, acc_rs, acc_acs)
    close(60)
    close(50)
    close(40)
    close(30)
    close(20)
    close(1)

end program matdrv

max_stars_repo_name: BrianGladman/mathieu

max_issues_repo_name: BrianGladman/mathieu

max_forks_repo_name: BrianGladman/mathieu


text:
The Advanced Materials Research Laboratory finished University Construction construction in the spring of 2008. The site is across the arboretum from the Putah Creek Lodge. The labs main purpose is to provide permanent laboratory and support space for students and faculty engaged in HVOF (high velocity oxygen fuel) research. A total of 4,625 assignable square feet will be provided including the HVOF lab, four fuel cell research labs, a machine shop and related research offices and support space.

 Users/SMCareBare

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
Debats du Senat (hansard)
2e Session, 36e Legislature,
Volume 138, Numero 44
Le jeudi 6 avril 2000
L'honorable Gildas L. Molgat, President
Le discours sur l'Accord definitif nisga'a
Le deces de sir Stanley Mathews
Le refus de sortir un timbre pour commemorer le 75e anniversaire de l'Eglise Unie
Projet de loi sur les Instituts de recherche en sante du Canada
Les travaux du Senat
L'Association parlementaire Canada-Europe
L'inscription omise au calendrier canadien
La croissance de la caisse d'assurance-emploi-Le versement de l'excedent
La Nouvelle-Ecosse-L'effet du projet de reduction des effectifs a Halifax
Le projet d'augmenter le nombre d'heures de conduite des camionneurs
Les travaux du Senat
Les propos du premier ministre du Quebec durant sa visite en France
Ucluelet-Tofino, en Colombie-Britannique-Demande de remplacement du systeme des baux de peche
Reponse differee a une question orale
La possibilite d'abaisser le seuil octroyant le statut de metropole
Les travaux du Senat
La Loi canadienne sur les societes par actions
Projet de loi modificatif-Deuxieme lecture
l'Accord definitif nisga'a
Troisieme lecture-Suite du debat
Deuxieme lecture-Suite du debat
Projet de loi modificatif-Deuxieme lecture-Suite du debat
Les travaux du Senat
Le jeudi 6 avril 2000
La seance est ouverte a 14 heures, le President etant au fauteuil.
Son Honneur le President :
Ils sont ici dans le cadre de leurs etudes et visitent Ottawa.
Ils ont aussi, heureusement, decide de visiter le Senat.
De la part de tous les honorables senateurs, je leur souhaite la bienvenue.
Honorables senateurs, je voudrais faire une annonce.
J'ai sejourne a Iqaluit du vendredi au dimanche.
Elle devait etre a Iqaluit pour le jour anniversaire.
Helen Maksagak, une ancienne commissaire, y etait.
Nous avons egalement celebre notre carnaval d'hiver, le Toonik Tyme, a Iqaluit.
L'honorable Dan Hays (leader adjoint du gouvernement) :
En fait, honorables senateurs, ces etudiants occuperont vos sieges.
J'espere que de nombreux honorables senateurs seront en mesure d'etre presents.
Le discours sur l'Accord definitif nisga'a
Un des correspondants etait P.J. Brabazon.
Aujourd'hui, j'ai recu un autre message de lui qui disait simplement merci.
Le deces de sir Stanley Mathews
L'honorable Francis William Mahovlich :
Sir Stanley avait70 ans, 23 ans de plus que moi.
Ce qui s'est produit me surprend encore aujourd'hui.
Il etait un parfait exemple de discipline personnelle.
Ses amis canadiens garderont toujours le souvenir de sir Stanley Mathews.
Le refus de sortir un timbre pour commemorer le 75e anniversaire de l'Eglise Unie
L'honorable Lois M. Wilson :
Cette Eglise canadienne entretient des relations internationales d'une facon tres singuliere.
Elle encourage l'unite, non la division.
Son Honneur le President :
Projet de loi sur les Instituts de recherche en sante du Canada
Le jeudi 6 avril 2000
Son Honneur le President :
Honorables senateurs, quand lirons-nous ce projet de loi une troisieme fois?
Les travaux du Senat
L'honorable Dan Hays (leader adjoint du gouvernement) :
Son Honneur le President :
Honorables senateurs, nous siegerons demain, vendredi, ce qui est un peu inhabituel pour nous.
Son Honneur le President :
Si c'est le cas, l'avis serait probablement donne au debut de la semaine.
Honorables senateurs, c'est l'unique but de mon intervention.
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
Toutefois, j'aimerais apporter une correction.
Le gouvernement ne dirige pas le Senat.
C'est la la tache des honorables senateurs.
Elle represente un groupe qui detient des sieges dans les deux Chambres.
Personne ne doit s'y tromper.
Il veut aller a la Chambre des communes.
L'Association parlementaire Canada-Europe
L'honorable Jerahmiel S. Grafstein :
L'inscription omise au calendrier canadien
L'honorable Gerald J. Comeau :
Le ministre Boudreau, etant d'origine acadienne, devrait etre insulte par cet oubli.
L'honorable J. Bernard Boudreau (leader du gouvernement) :
C'est un sentiment dont je ferai part aux autorites competentes.
Je vous assure que les Acadiens existent et qu'ils sont la pour rester.
La croissance de la caisse d'assurance-emploi-Le versement de l'excedent
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
Le leader du gouvernement au Senat pourrait-il verifier ces chiffres?
L'honorable J. Bernard Boudreau (leader du gouvernement) :
De toute evidence, il y a un surplus.
C'est une bonne nouvelle.
Il ne stagne pas dans une reserve.
En fait, c'est ce qui s'est produit.
Cela represente 35 milliards de dollars.
Cet argent ne vous appartient pas.
Malheureusement, ce n'est pas le cas.
Nous devons maintenant la rembourser.
Nous avons tout simplement accumule cette dette et laisse un fardeau aux generations a venir.
Nous laissons nos enfants et nos petits-enfants payer la facture.
L'honorable Consiglio Di Nino :
Et la Nouvelle-Ecosse?
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Honorables senateurs, je vais tenter d'etre juste et equitable a cet egard.
Il ne fait aucun doute que d'autres facteurs entrent en jeu.
J'ai fait du bon travail.
J'y ai consacre bien des efforts et voyez maintenant le resultat.
N'oubliez pas que le Seigneur vous a aide a travailler ce jardin.
Personne ne posait cette question il y a quelques annees.
L'honorable John Lynch-Staunton (chef de l'opposition) :
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Honorables senateurs, a vrai dire, je n'en sais rien.
L'honorable J. Michael Forrestall :
L'honorable J. Michael Forrestall :
Le Canada continuera-t-il d'y etre favorable?
L'honorable J. Bernard Boudreau (leader du gouvernement) :
La Nouvelle-Ecosse-L'effet du projet de reduction des effectifs a Halifax
L'honorable Donald H. Oliver :
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
Halifax est l'une des villes visees par ces compressions.
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Honorables senateurs, je remercie le senateur Oliver de cette question.
La qualite de ces services n'a pas son pareil au pays.
Je regretterais vivement qu'on change la structure actuelle.
La ville continue de donner des signes de forte croissance.
Nous devrions etre tres reconnaissants de cela.
Le projet d'augmenter le nombre d'heures de conduite des camionneurs
Si je comprends bien, Transports Canada ne tiendra pas de consultations a ce sujet.
Le ministere laisse cela aux provinces.
Pourquoi le gouvernement federal appuie-t-il la semaine de84 heures pour les camionneurs?
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Des avant-projets de changements sont a venir.
Je vais transmettre ses preoccupations au ministre et, par son entremise, aux fonctionnaires concernes.
Honorables senateurs, ce projet en cours est assujetti a une reglementation.
Le gouvernement federal ne tient meme pas de consultations publiques a ce sujet.
Le fait que l'honorable leader du gouvernement consulte ses notes ne suffit pas.
Je m'excuse de ne pas avoir informe votre bureau de cette question.
Je ne m'attends pas a ce que vous connaissiez le reglement en detail.
Dans un cas comme celui-ci cependant, je crois que nous devons nous interroger.
A premiere vue, cette mesure me parait bien radicale.
J'examinerai aussi cet aspect.
Les travaux du Senat
L'honorable Dan Hays (leader adjoint du gouvernement) :
Le leader voudra peut-etre y aller d'une reponse.
Son Honneur le President :
Le leader adjoint a-t-il la permission du Senat pour repondre a la question?
Si un comite siege, je suppose que ce sera tolerable.
Nous devons faire tres attention.
Cependant, le lundi est libre, par exemple, pour les seances de comites.
L'horaire des seances, esperons-le, pourra etre remanie.
La journee de lundi pourrait servir aux seances des comites, et demain aussi peut-etre.
Quoi qu'il en soit, c'est la meilleure reponse que je puisse donner.
Dans l'affirmative, sur quoi se fondera-t-il pour choisir l'heureux elu?
Honorables senateurs, normalement, il s'agirait de demandes de permission.
Ces demandes peuvent etre faites sous forme de motions.
D'apres mon interpretation du Reglement, cette motion ferait l'objet d'un debat.
C'est pourquoi je propose qu'un ou peut-etre deux comites siegent.
L'honorable John Lynch-Staunton (chef de l'opposition) :
Des temoins doivent comparaitre mercredi prochain, je presume.
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Nous ne sommes tout simplement pas d'accord avec lui.
Nous pensons qu'il a tort.
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Honorables senateurs, la situation soulevee par le senateur est hypothetique a l'extreme.
Je dis cela avec la plus grande confiance.
Les propos du premier ministre du Quebec durant sa visite en France
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Ucluelet-Tofino, en Colombie-Britannique-Demande de remplacement du systeme des baux de peche
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
Ils ont ete incapables d'obtenir une reponse du ministere des Peches et des Oceans.
Je demande au ministre de faire diligence.
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Honorables senateurs, je remercie l'honorable senateur de sa question.
Cependant, je connais la region dont a parle l'honorable senateur.
Je suis alle la-bas et c'est absolument magnifique.
Je transmettrai la reponse a l'honorable senateur.
Reponse differee a une question orale
L'honorable Dan Hays (leader adjoint du gouvernement) :
La possibilite d'abaisser le seuil octroyant le statut de metropole
(Reponse a la question posee par l'honorableBrenda M. Robertson le 28 mars 2000)
Moncton serait une telle region selon l'une ou l'autre definition.
Nous rendons deja disponible toutes les donnees que nous avons au sujet des centres urbains.
Les travaux du Senat
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
A mon avis, le meme principe s'applique aux comites.
Honorables senateurs, notre cote aura beaucoup de difficulte a accorder cette autorisation.
Nous reconnaissons que la difficulte de modifier les horaires des ministres constitue une circonstance exceptionnelle.
La semaine prochaine, plusieurs comites se pencheront sur des dossiers ordinaires d'importance.
Il y aura alors debat sur cette motion.
Si je comprends bien le Reglement, des negociations doivent avoir lieu.
Effectivement, elles se deroulent actuellement entre les deux cotes.
Je crois avoir depose une contre-proposition a la suspension des negociations.
L'honorable Dan Hays (leader adjoint du gouvernement) :
Chacun de nous doit interpreter l'etat de nos negociations.
Je ne vais pas en referer au gouvernement.
Cependant, je dois interpreter l'etat de la situation en fonction de notre objectif.
Esperons que nos negociations se poursuivront.
Nous avons eu de bons rapports et j'espere qu'ils se poursuivront.
J'espere avoir tort et que nos negociations aboutiront a une entente.
Honorables senateurs, je remercie le senateur.
Tous les senateurs peuvent ainsi savoir ou ils en sont.
Honorables senateurs, nous verrons comment se derouleront les choses.
Je suggere ce que pourrait etre et non ce que sera le scenario.
Quoi qu'il en soit, nous devons attendre et voir ce qui arrivera.
La Loi canadienne sur les societes par actions
Projet de loi modificatif-Deuxieme lecture
J'etais cense prononcer ce discours jeudi dernier.
Beaucoup de choses sont survenues au cours de la derniere semaine et demie.
J'ai ecoute avec beaucoup d'interet l'excellent discours du senateur Kirby mardi dernier.
Les entreprises ne vont pas rester ici en attendant une baisse eventuelle des impots.
Les reductions d'impot annoncees dans le dernier budget ne vont pas assez loin.
Il reste des obstacles a eliminer pour que le Canada devienne plus concurrentiel.
Un troisieme obstacle est la reglementation.
C'est peut-etre juste la facon dont fonctionne ce gouvernement.
Un exemple de cet etat de fait est ce qui s'est passe aujourd'hui.
Il n'y a aucune urgence nationale.
Honorables senateurs, nous nous faisons court-circuiter par l'edifice Langevin.
On nous dit qu'il doit etre adopte d'ici mercredi.
On ne nous donne cependant aucune bonne raison justifiant qu'il doive etre adopte mercredi.
Cela devrait nous inquieter tous.
Comment faire autrement pour savoir qui a parle a qui?
Le projet de loi S-19 temoigne de ce fait.
Bref, j'ai bien hate d'etudier cette mesure legislative en comite.
Son Honneur le President pro tempore :
L'idee est fascinante, et j'espere que le comite l'examinera serieusement.
Son Honneur le President pro tempore :
Plait-il aux honorables senateurs d'adopter la motion?
(La motion est adoptee et le projet de loi est lu une deuxieme fois.)
Son Honneur le President pro tempore :
Honorables senateurs, quand lirons-nous ce projet de loi une troisieme fois?
l'Accord definitif nisga'a
Troisieme lecture-Suite du debat
Honorables senateurs, j'invoque le Reglement.
Le senateur Austin n'est pas a sa place.
Il a l'habitude de repondre aux questions soulevees dans le cadre du debat.
Hier, j'ai pose des questions au sujet des droits des femmes autochtones.
Le gouvernement va-t-il y repondre aujourd'hui?
L'honorable Dan Hays (leader adjoint du gouvernement) :
Il sera de retour la semaine prochaine.
Son Honneur le President pro tempore :
Honorables senateurs, le senateur Sibbeston va poursuivre son discours d'hier.
L'honorable Nick G. Sibbeston :
Les Nisga'as ont attendu longtemps.
Or, les peuples autochtones ne se sont jamais satisfaits d'une delegation de pouvoirs.
Les Canadiens ont rejete l'Entente de Charlottetown lors d'un referendum national.
Le traite nisga'a est le point culminant de ce processus.
Les accords en sont a diverses etapes d'application et de developpement.
Ils ont utilise leur argent pour des investissements et des possibilites commerciales appropries.
Ils ont elargi leurs investissements dans tout l'ouest du Canada.
Ils ont investi dans toutes sortes de projets et d'entreprises.
Ils possedent des immeubles de bureaux.
Je sais d'experience ce qu'est l'autonomie gouvernementale.
On doit se battre pour obtenir le gouvernement responsable.
Il se composait de commissaires, de commissaires adjoints et d'un commissaire delegue.
Son Honneur le President :
Je regrette de vous interrompre de nouveau, senateur Sibbeston.
Votre periode de 15 minutes est maintenant ecoulee.
Demandez-vous la permission de continuer?
Le debat est trop important.
J'ai encore deux pages.
La permission est accordee ou elle ne l'est pas.
Nulle part, je crois.
Le Reglement prevoit une periode de 15 minutes.
En outre, cela depend du point a l'ordre du jour dont il est question.
Honorables senateurs, je ne me soucie pas vraiment du temps que parlera le bon senateur.
Nous pourrions l'etendre a une heure par consentement unanime.
Aurons-nous tous une demi-heure pour parler?
C'est tres irregulier.
Si nous avions tous une heure, ce serait tres bien.
Il se pourrait tres bien qu'elle soit defaite.
Cela dependra de la volonte du Senat, ce dont je ne peux pas prejuger.
Je suppose que notre cote l'emportera, mais ce n'est pas certain.
Il prevoit aussi45 minutes pour les parrains des projets de loi.
Cependant, le Reglement n'accorde que 15 minutes aux autres intervenants.
Je crois que c'est trop peu.
Je ne pense pas que nous devrions accorder des prolongations illimitees.
L'honorable Herbert O. Sparrow :
Nous avons consacre beaucoup de temps a cette discussion.
Il suffit de demander a l'honorable senateur combien de minutes il lui faut.
S'il n'y a pas d'abus, pourquoi faire un drame?
Pourquoi en faire toute une histoire?
Laissons parler le senateur Sibbeston.
C'est un sujet important.
L'honorable John Lynch-Staunton (chef de l'opposition) :
Il a lu des extraits de certains rapports, et cela m'a beaucoup interesse.
Sa contribution m'apporte beaucoup et a bien d'autres aussi.
On demande la permission de ne pas respecter le Reglement.
C'est simple, on respecte la regle ou on ne la respecte pas.
L'honorable Eymard G. Corbin :
Pourquoi ont-ils etabli cette regle des 15 minutes au depart?
C'etait pour prevenir les abus.
C'etait pour ne pas perdre le controle de la Chambre dans les situations tendues.
Je peux sentir la tension qui monte.
Nous devrions etre consequents dans nos actes.
L'honorable Anne C. Cools :
Honorables senateurs,15 minutes pour un discours important, ce n'est tout simplement pas suffisant.
Le fait de doubler le temps prevu dans le Reglement me semble raisonnable.
Je ne comprends pas la logique du senateur Kinsella.
Je ne comprends pas ce raisonnement.
Comme le senateur Cools, je pense que nous devrions modifier le Reglement.
Le plus tot nous le ferons, le mieux ce sera.
L'honorable Marcel Prud'homme :
Le leader adjoint lance un debat interessant au sujet de la revision du Reglement.
Certains d'entre nous sont tenaces.
J'ai toutes sortes de suggestions a faire.
Toutefois, le chef adjoint a ouvert la porte.
Je conseille au senateur de ne pas repondre puisque cela lancerait le debat.
L'honorable Francis William Mahovlich :
Son Honneur le President pro tempore :
Honorable senateur Sibbeston, demandez-vous la permission de continuer votre discours?
Son Honneur le President pro tempore :
Est-ce d'accord, honorables senateurs?
Les senateurs d'en face sont d'accord pour permettre au senateur Sibbeston de continuer.
S'il s'agissait d'une permission avec condition, il n'en serait pas question.
Laissons au senateur Sibbeston la chance de terminer ce qu'il a a dire.
C'est le moins que nous puissions faire.
Il lui suffit peut-etre seulement de cinq minutes de plus.
Le senateur Lynch-Staunton a dit nous.
Je constate cependant une position intenable.
Son Honneur le President pro tempore :
Je ne vois pas qu'il y ait consentement unanime.
Je regrette de vous avoir cause ce retard.
Ce sont tous des domaines d'interet tres local.
Je n'ai aucun doute que les Nisga'as sauront en faire autant.
Maintenant, 20 ans plus tard, ils sont prets.
Ils eprouvent des problemes, car c'est une region du pays difficile a gouverner.
Ils n'ont pas d'arbres ni de ressources.
Pourtant, ils sont optimistes et ils ont un bon moral.
Leur culture s'eveille, tout comme leur langue.
Les gens sont fiers de ce qui a ete realise chez eux.
Je crois que l'article 35 de la Constitution renferme ce droit.
Le projet de loi sur les Nisga'as decrit en detail et precisement ce droit.
Il ne convient tout simplement pas.
Le projet de loi sur les Nisga'as est une mesure positive.
J'ai examine leur systeme de justice lorsque je travaillais dans ce secteur.
Ce systeme commence a prendre de l'ampleur.
C'etait un moment dont le Canada peut etre fier.
Je suis fier de l'appuyer aujourd'hui.
J'espere que tous les senateurs en feront autant.
Il s'est beaucoup occupe de la question.
Je suis tres heureuse d'entendre ce qui se passe.
Nous partageons tous les terres de nos peuples autochtones.
Etant donne les documents qui ont ete signes, est-ce que notre Charte s'applique?
Je comprends la question posee par le senateur Finestone.
L'article 25 de la Charte va s'appliquer.
Honorables senateurs, je voudrais feliciter le senateur Sibbeston pour son discours.
Il n'y a aucune mention de cela dans le traite.
La societe autochtone n'est pas differente.
Ce serait deplorable si nous inscrivions ce concept dans la loi.
J'aimerais demander au senateur s'il est d'accord avec moi.
Un gouvernement que j'appuyais a fait valoir le droit inherent a l'autonomie gouvernementale.
Le senateur comprend donc mon point de vue sur ce sujet.
Des deux cotes, les arguments sont tres mauvais.
J'ai lu le temoignage de M. Molloy.
Toutefois, les gens d'en face ont eux aussi une argumentation solide.
Des temoins des deux cotes ont comparu devant nous.
L'honorable A. Raynell Andreychuk :
La derniere remarque du senateur m'a troublee un peu.
Les peuples autochtones que je connais ont toujours respecte la primaute du droit.
Ils se sont toujours fies la-dessus pour prouver qu'ils avaient ces droits.
Dans le cas contraire, nous devrons retourner a la table de negociation.
C'est ce qui m'inquiete.
Ils ont suivi les regles de leur propre nation pour arriver a cet accord.
Je comprends la question de l'honorable senateur.
C'est la une question juridique que le gouvernement federal aurait a regler.
Les Nisga'as continueront d'appliquer le traite le mieux possible.
Les tribunaux pourraient juger certains elements inconstitutionnels.
Le gouvernement federal devra trouver une solution.
La Charte des droits et libertes s'applique en l'occurrence.
Va-t-il falloir que nous nous battions encore 100 ans pour retrouver nos droits?
Malheureusement, je ne connais pas la societe nisga'a.
Elle jouit d'un grand respect parce qu'elle donne la vie a la societe.
L'honorable Jerahmiel S. Grafstein :
Pour ma part, je crains bien de devoir partager ces preoccupations.
Je regrette, senateur Sibbeston, mais je ne crois pas que ce soit le cas.
Je voudrais aborder une autre question de fond qui me preoccupe beaucoup.
Ils forment une minorite.
J'ai replique en disant que le Canada impose cinq ans de residence.
Je suis donc d'autant plus desole de ne pas etre d'accord avec lui.
Je vous cite son temoignage au complet:
Je vais maintenant aborder le sujet des droits des minorites.
C'est une question de droits des minorites.
Monsieur le president, mon opinion differe de celle du senateur Grafstein.
Nous sommes completement envahis dans notre propre pays.
Nous avons paye tres cher.
Pourquoi ne sommes-nous pas alles aussi loin que le senateur l'a suggere?
Je viens de vous exprimer une de mes opinions.
C'est le probleme auquel nous sommes confrontes.
Je vous demande la meme chose.
Si vous etiez a notre place, permettriez-vous cela?
Permettriez-vous a quelqu'un d'autre de gerer les biens de votre famille?
Je ne crois pas.
M. Gosnell a dit encore ceci au sujet des droits des femmes et des minorites:
Ce n'est pas a moi de prendre cette decision.
Je suis sur que d'autres questions seront soulevees.
Ce droit est au coeur meme de tous les droits des minorites.
L'abstention, bien qu'elle soit permise par notre Reglement, ne regle rien.
L'honorable senateur souleve bon nombre de questions.
Je parlerai d'abord de l'amendement conservateur.
A mon avis, un renvoi a six mois ne donnera rien.
On n'aura pas le temps d'apporter des correctifs.
Le projet de loi comprend des mesures de securite integrees.
Le traite ne disparaitra pas.
Ils ne peuvent participer a une infraction a la Constitution, mais ils peuvent l'interdire.
Je laisse cela de cote.
C'est regrettable, mais je laisse cela de cote.
Mon idee est faite a ce sujet.
Le plus tot cette loi sera adoptee, le mieux ce sera.
Je ne crois pas aux avis.
C'est pourquoi je ne crois pas aux avis.
Nous sommes devant une enigme.
Honorables senateurs, c'est la ou lui et moi ne sommes absolument plus d'accord.
C'est bien different.
Son Honneur le President pro tempore :
Honorables senateurs, la periode des questions et observations est ecoulee.
Y a-t-il consentement unanime pour poursuivre?
Son Honneur le President pro tempore :
Il y a plusieurs senateurs qui ont manifeste le desir de prendre la parole.
Je vais essayer d'etre bref.
Son Honneur le President pro tempore :
Y a-t-il consentement unanime pour poursuivre?
Il s'agit de savoir si cette question est suffisamment extraordinaire pour justifier un renvoi.
L'honorable senateur a dit: Soit, adoptez le projet de loi, mais je m'abstiendrai.
Honorables senateurs, je ne suis pas tres satisfait de ma position.
Je pense qu'il y a lieu de la nuancer.
Je vais etre franc.
J'ai commence mon exploration avec l'intention d'appuyer ce projet de loi.
Telle etait mon intention initiale.
A vrai dire, je ne suis pas fier de m'abstenir.
Ma position est a nuancer.
Il l'affirme sans l'expliquer.
Le senateur va m'avoir a l'usure, mais je vais repondre.
Il existe dans la Constitution une doctrine dite de l'arbre.
Quelles etaient les intentions des signataires de la Constitution a l'epoque?
J'ai relu le compte rendu de ces debats.
J'en ai lu une partie, pas l'integralite.
J'ai observe indirectement tous ces debats.
Je ne crois pas qu'on aurait pu en arriver a cette conclusion.
Je suis entierement d'accord avec tout ce qu'a dit le senateur Sibbeston.
Ecoutons ce qu'en disent d'autres.
Le senateur Sibbeston a ete tres juste.
C'est la une question fondamentale.
J'aimerais interroger le senateur Grafstein sur l'amendement qu'il n'appuie pas.
Je crois qu'il a absolument raison, que nous devons clarifier l'article 35.
Cela reglerait la question.
Il semble y avoir de bonnes opinions des deux cotes.
Il y aura des gagnants et des perdants.
J'ai pense que personne ne contestait que la meilleure solution est un reglement negocie.
C'est une enigme.
Je me suis explique du mieux que je le pouvais.
Le senateur Grafstein a essaye d'expliquer au senateur Murray pourquoi il s'abstenait.
Il a dit que le Senat a une responsabilite.
Je ne vois pas clairement en quoi consiste cette responsabilite a son avis.
Si le projet de loi est adopte, il fera evidemment l'objet de contestations judiciaires.
Chaque senateur doit repondre a sa propre conscience.
Le mieux que je puisse faire pour ma conscience est d'exprimer clairement mes reserves.
J'en ai fait part sous forme de preoccupations.
Si j'etais entierement satisfait de mon point de vue, j'irais jusqu'au bout.
Toutefois, un fausse tres profond separe les points de vue constitutionnels.
J'ai opte pour un cote de l'equation.
Vous pouvez me lacerer tant que vous voudrez.
Les audiences ont ete excellentes.
Apres cela, honorables senateurs, nous sommes a la grace de Dieu.
Je ne pense pas que ce soit exact.
Ai-je mal compris ce que le senateur a dit?
J'ai bien examine ce traite.
Il m'a fallu des semaines pour le lire et le comprendre.
Ma position n'a pas change depuis la deuxieme lecture.
Vous avez raison, honorables senateurs.
J'ai trouve une note avec la mention: Nous parlons ici du gouvernement municipal.
J'ai un probleme similaire a celui du senateur Murray.
La Couronne nous demande notre consentement sur cette question.
Encore une fois, soyons realistes.
Il l'a dit.
C'est un fait.
Le gouvernement a dit qu'il n'admettra aucun amendement.
Il l'a dit.
Meme s'il a permis un amendement, il l'a dit.
Soyons justes envers les Nisga'as et envers le processus.
C'est ce qu'a dit le gouvernement.
Il en va autrement pour ce qui est de l'avis.
Il est question de pouvoirs.
Certains sont exclusifs, d'autres concurrents.
Je respecte beaucoup leurs opinions.
Je reconnais cependant qu'il est divisible.
Des questions interessantes ont ete posees par des senateurs des deux cotes du comite.
Il s'agit d'une question de droit tres difficile a resoudre.
Je le regrette, mais la cour ne l'a pas encore dit.
Elle le fera peut-etre dans l'avenir, mais ce n'est pas encore fait.
Evidemment, nous pourrions le faire en modifiant la Constitution.
Nous pouvons modifier n'importe quel article de la Constitution par voie d'amendement constitutionnel.
La Cour supreme a accompli un travail impressionnant.
Je crois qu'ils sont tres importants.
Je crois que les renvois sont utiles.
Certains ont propose un renvoi a la Cour supreme.
Le projet de loi C-9 constituera un precedent d'une importance vitale.
Nombre d'autres accords seront conclus dans les annees a venir.
J'en suis heureux.
Je suis d'accord la-dessus.
Cela n'a aucun effet sur la division des pouvoirs.
Cela ne change pas la repartition des competences.
C'est une question fondamentale.
Le sourire est sage et il ne sert a rien de s'emporter.
Apprenez aussi que le sourire est doux au coeur de l'Indien.
Trop souvent dans l'histoire, c'est tout ce qu'il nous restait.
Elle ne fait que retablir, confirmer et moderniser une mesure legislative.
Ils voudraient une simple delegation de pouvoirs, sans plus.
Que ces gens s'informent.
Cette entente celebrera ses 25 ans cette annee.
L'histoire de la Colombie-Britannique est courte.
J'ai entendu cela.
Je le disais, cela m'a fait sourire.
Le Canada binational, souvenez-vous.
La premiere Confederation avait ce petit defaut d'enterrer les Premieres nations.
Etait-ce une loi parfaite?
Ou prenez-vous l'idee que notre systeme politique canadien est sans failles?
Plus encore, on voudrait que les Premieres nations n'aient aucun droit a l'erreur.
La recherche du mieux est un processus evolutif.
D'aucuns le souhaitent et en font une grosse histoire.
Nous en retrouvons aussi entre les provinces et a l'interieur des provinces.
Au Quebec, des Innus en ont avec les Cris.
Dans les Territoires du Nord-Ouest, les Denes en ont avec les Inuits.
C'est normal, pourquoi nous surprendre?
Nous les avons regles dans le passe, nous pouvons le faire dans l'avenir.
Nous remettons a jour une cartographie ancestrale.
Laissons aux Premieres nations le soin de clarifier ces choses.
Donnons du temps au temps.
Oui, le traite nisga'a constitue un precedent: il fait renaitre la fierte collective.
Parler est important, la democratie l'exige.
Les mots comptent, nous le savons.
L'ecrit fonde nos relations, nous le savons aussi.
Voila pourquoi nous avons des forums, des comites, des parlements et des commissions.
Nous signons des ententes et des traites, des lois et des contrats sociaux.
La Charte des droits et libertes nous protege.
L'histoire du Canada a certainement ete moins marquee par la violence.
C'est pourquoi nous avons toujours ete trahis.
Le temps est venu de passer a l'action et de faire preuve de generosite.
Il en est d'autres qui sont caduques.
Ne nous maintenez plus par avocasserie et mauvaise foi dans des culs-de-sac insupportables.
Ce ne sont pas de nouveaux droits inventes dans les circonstances de l'actualite.
Ils ne relevent pas de l'opportunite politique du moment.
Nous parlons d'une mise a jour de droits anciens et depuis longtemps brimes.
Comment pouvons-nous alors invoquer la Constitution pour ensuite nier ce que la Constitution affirme?
(Sur la motion du senateur DeWare, au nom du senateur Comeau, le debat est ajourne.)
Deuxieme lecture-Suite du debat
L'honorable Donald H. Oliver :
Honorables senateurs, je suis heureux de participer au debat sur cette importante question.
Je voudrais aborder brievement chacun de ces quatre elements.
La cour explique ensuite les motifs de sa retenue sur ces questions.
Pour etre legitimes, les institutions democratiques doivent reposer en definitive sur des fondations juridiques.
[...] par l'intermediaire d'institutions publiques creees en vertu de la Constitution.
Le passage suivant, tire de la decision, appuie ce point:
La cour poursuit plus loin:
Je vais maintenant parler de la protection des minorites et du role du Senat.
Son Honneur le President :
Demandez-vous la permission de continuer?
L'honorable Dan Hays (leader adjoint du gouvernement) :
Pendant huit ou neuf minutes.
Honorables senateurs, je remarque qu'il est six heures moins cinq.
Le senateur Oliver depassera 18 heures.
Son Honneur le President :
Son Honneur le President :
La permission de continuer est-elle accordee a l'honorable senateur Oliver?
Le passage du document de 1980 faisant autorite est ainsi libelle:
Sir Johh A. Macdonald:
Il y a trois grandes sections ayant des interets differents dans la Confederation proposee [...].
George Brown a aussi fait une citation semblable aux pages 35 et 38.
Voici ce que dit le professeur Monahan a la page 85 de son livre intitule:
La cour nous guide tres peu sur ce que serait une question claire.
Si une question est posee, des negociations ne seraient pas menees pour une autre question.
L'honorable Marie P.-Poulin :
Honorables senateurs, combien de fois faudra-t-il que les Quebecois disent non aux separatistes?
Cela me rappelle mes jours d'ecoliere.
La Cour supreme du Canada a confie au Parlement la responsabilite de definir les regles.
Il y en a assez comme cela qui s'en occupent a l'autre endroit.
Le gouvernement s'est engage a tenir compte de notre opinion.
C'est la-dessus que nous devrions concentrer nos efforts.
Je suis d'un avis tout a fait contraire.
Que dois-je faire?
A titre de senateur independant, je ne peux toutefois pas me cacher.
Par consequent, ils s'opposent au principe meme du projet de loi.
C'est ce que la Cour supreme a dit.
Je reconnais donc la legitimite de l'objectif du projet de loi.
Leur confiance en eux a chute.
Le projet de loi n'etablit pas un cadre pour la tenue d'un referendum.
Il etablit plutot un cadre pour les negociations que devrait engager le gouvernement federal.
Aucune province ne peut faire secession unilateralement; une modification a la Constitution serait necessaire.
Je ne partage pas leur avis.
Tous les Canadiens ont un interet dans l'avenir du pays.
Leurs representants a Ottawa doivent faire valoir leurs interets.
Honorables senateurs, j'en viens maintenant au role du Senat.
Certes, la Chambre des communes tiendra compte de son avis.
Eh bien, le Senat est un acteur politique tirant sa legitimite de la Constitution.
Entendons-nous bien sur ce que le Senat peut et ne peut pas faire.
Determiner si une question et un vote majoritaire sont clairs relevera d'un jugement politique.
Le Senat doit etre inextricablement mele a ce genre de decision politique.
Toutefois, le Senat ne peut exercer un veto permanent sur les questions constitutionnelle.
Le besoin de clarte est primordial.
Son Honneur le President :
J'en suis a la derniere page de mon discours, honorables senateurs.
Puis-je demander au senateur Roche de combien de temps il pense avoir besoin encore?
Il vient de nous dire qu'il lui reste une page.
Son Honneur le President :
Le senateur Roche nous a dit qu'il en etait a sa derniere page.
La permission est-elle accordee, honorables senateurs?
Je veux que ce sentiment se repande dans tout le pays.
L'honorable Jean-Claude Rivest :
Cette demarche inacceptable du gouvernement canadien trompe la population canadienne.
Plusieurs senateurs se sont exprimes dans le meme sens.
S'il y a un referendum a un moment donne, il portera la-dessus.
Que se passera-t-il dans l'opinion publique canadienne?
Si oui, je voterai en faveur de ce projet de loi.
Cependant, vous etes incapables de fournir cet element de preuve.
Pourtant, les Canadiens ont compris cela, et on peut le voir dans les sondages.
Oubliez cela, cela ne se fera pas!
Ils ne font pas cela accidentellement parce qu'ils n'auraient pas compris la question.
Parce que l'enjeu electoral ne serait pas clair?
D'ailleurs, le ministre Dion l'a dit, et je pense qu'il a raison.
C'est sa politique, il replique aux pequistes.
Tous les premiers ministres, de Macdonald a Laurier, ont toujours parle d'unite nationale.
Ce sera une donnee constante de la realite canadienne.
M. Pearson a cree la commission Laurendeau-Dunton.
Il a convoque la conference Canada Tomorrow.
Il a fait adopter le drapeau canadien.
Il a suivi une politique sur l'unite nationale.
C'etait une solidarite necessaire.
Il a propose l'Accord du lac Meech, qui a ete determinant.
Ceux qui l'ont saborde ont commis une erreur historique et catastrophique.
Ils ne sont pas de ce cote de la Chambre.
C'est un probleme quasi permanent dans la structure meme du pays.
Ces premiers ministres, quoi que l'on en pense, avaient une politique d'unite nationale.
Je le respecte eminemment a ce sujet.
Il va lui donner des garanties qu'il ne sera pas en mesure de livrer.
Les modalites d'application de ce projet de loi ne sont pas geniales.
La question portera sur la souverainete-association.
Vous affaiblissez ainsi les forces federalistes au Quebec.
Tres bien, c'est ce que dit le projet de loi.
Qu'avez-vous regle?
Les trois ou quatre millions de personnes qui auront vote vont demeurer au meme endroit.
Vous ne pourrez pas les disperser avec du poivre de cayenne!
Je ne veux pas que ce projet de loi soit applique.
Je ne veux pas de referendum, comme tout le monde au Senat.
Il aura l'effet contraire.
Aujourd'hui, personne n'a cure de ce projet de loi.
Il ne souleve pas la passion des foules.
Il y aura un referendum.
Personne ne le souhaite.
Il portera sur la souverainete-association.
On pretendra qu'il est confus et que la question n'est pas claire.
Bien sur, on peut exprimer cet avis.
Ce projet de loi ne nous aide en aucune facon.
Il ne fera pas changer un vote du OUI vers le NON.
Il ne changera strictement rien.
Il gardera exactement le meme discours.
Ce projet de loi ne modifie en rien le discours du Parti quebecois.
C'est un projet de loi inutile.
Ce n'est sans doute pas volontaire, mais c'est un fait.
Ce n'est pas vrai.
En tant que senateur quebecois et canadien, je vais voter contre ce projet de loi.
(Sur la motion du senateur Robichaud ( L'Acadie-Acadia ), le debat est ajourne.)
Projet de loi modificatif-Deuxieme lecture-Suite du debat
L'honorable Anne C. Cools :
Cette expression appelle sa propre condamnation juridique.
Une reglementation a ete elaboree, ce qu'il est convenu d'appeler legislation par delegation.
Cette reglementation a ete appelee Lignes directrices federales sur les pensions alimentaires pour enfants.
Il laissait intentionnellement de cote la question de la garde et de l'acces.
La plupart des Canadiens lui doivent beaucoup ainsi qu'aux senateurs qui nous ont appuyes.
Le modele de depenses lui-meme etait inadequat.
A Guide to the Guidelines.
A la page 311, il ecrit:
Le ministere aurait du utiliser un modele fonde sur la proportion des revenus.
Entre 1968 et 1997, cet age etait de 16 ans.
Honorables senateurs, le soutien ou l'entretien d'enfants a charge majeurs merite discussion.
C'est particulierement vrai dans le cas des familles.
L'echange financier est une fonction des rapports entre humains.
a ) il est age de moins de seize ans;
Cela avantageait donc les femmes et maximisait les pensions pour les enfants.
La plupart des enfants adultes veulent que cet argent leur soit verse directement.
Il n'en a pas ete ainsi, cependant.
Il n'existe aucune obligation de rendre des comptes.
Le retard est manifeste.
Ce n'est pas une question d'obligation juridique.
Honorables senateurs, voici quelques exemples tires de la jurisprudence.
Une relation pere-enfant va au-dela d'une simple dependance economique.
On lit un peu plus loin:
Finalement, on lit en conclusion que:
Je crois que cela remediera au probleme.
Cet enrichissement financier se fait souvent aux depens de l'enfant majeur.
(Sur la motion du senateur Sparrow, le debat est ajourne.)
Les travaux du Senat
L'honorable Dan Hays (leader adjoint du gouvernement) :
L'honorable senateur Prud'homme, c.p. ).
L'honorable Marcel Prud'homme :
Meme si ce discours a ete livre rapidement, il doit etre lu.
Elle a ete recemment elue a la direction de l'Union interparlementaire.
J'ai fait campagne pour lui en 1960.
Il ne s'en souvient peut-etre pas.
Ce n'est pas une question d'esprit de clocher.
Ils representent le Canada a son meilleur.
J'observe la diversite du Canada.
Les honorables senateurs connaissent mon opinion.
Grace a mon intervention, le senateur Poulin pourra donc revenir sur son interpellation.
Avec sa permission, j'aimerais ajourner le debat au nom du senateur Carstairs.
Cela avait ete convenu plus tot avec le senateur Poulin.
Permission ayant ete accordee de revenir aux avis de motion emanant du gouvernement:
L'honorable Dan Hays (leader adjoint du gouvernement) :
Honorables senateurs, je donne avis que demain, le 7 avril 2000, je proposerai:
Je devrais peut-etre apporter une precision.
Je donne avis aujourd'hui d'une motion que je proposerai demain.
On pourra debattre demain de la motion.
(Le Senat s'ajourne au vendredi 7 avril 2000, a 9 heures.)


text:
c     ****************************************************************
c     *                                                              *
c     *                      subroutine upres_iter_0                 *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 04/19/2015                 *
c     *                                                              *
c     *     residual nodal force vector for iteration "0" of step    *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine upres_iter_0( norm_load, nbeta, dt, nodof, iout,
     &                         cstmap, pbar, ifv, mdiag, du, res,
     &                         dstmap )
      use contact, only : contact_force
c
      implicit none
c
c                    parameters
c
      integer ::  nodof, iout, cstmap(*), dstmap(*)
      double precision
     & norm_load, nbeta, dt,
     & pbar(nodof), ifv(nodof), mdiag(nodof), du(nodof),
     & res(nodof)
c
c                    locals
c
      integer :: i
      double precision
     &  nfac, sum
      double precision, parameter :: zero = 0.0d00,
     &                               one  = 1.0d00
      logical, parameter :: local_debug = .false.
c
c
c              set the residual load vector at iter = 0 just before
c              solving equations.
c
c              du will have non-zero terms if using the extrapolated
c              displacement increment method and/or the user specified
c              imposed displacements.
c
c              pbar then includes the total "eternal" applied load
c              at n+1 (including estimated inertia).
c
c              ifv has the "internal" forces for stresses
c              at n plus the effects of imposed displacement
c              increments/temperatures for step.
c
c              Section 1.6 of Manual.
c
      if( local_debug ) write(iout,9300)
c
      nfac = one / (nbeta*dt*dt)
      sum = zero
c
      if( local_debug ) write(iout,9310) dt, nbeta, nfac, nodof
c
      do i = 1, nodof
        if( cstmap(i) .eq. 0 ) then
           res(i) = ( pbar(i)- mdiag(i)*du(i)*nfac
     &              + contact_force(i) ) - ifv(i)
        else
           res(i) = zero ! has absolute constraint
        end if
        sum = sum + res(i) * res(i)
      end do
c
c              if norm = 0 there is no incremental loading at
c              start of step to drive an increment of displacements
c
      norm_load = sqrt( sum )
c
      if( .not. local_debug ) return
c
      write(iout,9000) norm_load
      write(iout,9100)
      do i = 1, nodof ! nodof
       write(iout,9200) i, cstmap(i),  res(i), pbar(i),
     &               -mdiag(i)*du(i)*nfac,
     &               contact_force(i), -ifv(i)
      end do
      write(iout,9320)
c
      return
c
 9000 format(/,3x,'... norm of res vector (rhs for iter 0): ',e14.6)
 9100 format(/,6x,"dof",2x,"cstmap",5x, "res",13x,"pbar",
     & 9x, "-[M]du*nfact",
     & 3x,"contact_force",6x,"-ifv" )
 9200 format(3x,2i7,5e16.6)
 9300 format(/,1x,"... enter upres_iter_0 ...")
 9310 format(/,3x,"... dt, nbeta, nfact, nodof: ",3e14.6,i8)
 9320 format(/,1x,"... leave upres_iter_0 ...",//)
c
      end

c     ****************************************************************
c     *                                                              *
c     *                      subroutine upres                        *
c     *                                                              *
c     *                       written by : bh                        *
c     *                                                              *
c     *                   last modified : 05/11/2015 rhd             *
c     *                                                              *
c     *     compute structure level, residual force vector for use   *
c     *     in the next Newton iteration. the next iteration may not *
c     *     occur if the residuals indicate convergence during the   *
c     *     convergence tests following this code                    *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine upres(
     &    iter, iout, nodof, dt, nbeta, num_term_loads,
     &    sum_loads, mgload, mdiag, pbar, du, velocity, accel,
     &    ifv, res, cstmap, dstmap, load  )
c
      use mod_mpc, only : tied_con_mpcs_constructed, mpcs_exist
      use stiffness_data, only : d_lagrange_forces
      use contact, only : contact_force
c
      implicit none
c
c              parameters
c
      integer :: iter, iout, nodof, num_term_loads, cstmap(nodof),
     &           dstmap(nodof)
      double precision ::
     &  dt, nbeta, sum_loads, mgload, mdiag(nodof), pbar(nodof),
     &  du(nodof), velocity(nodof), accel(nodof), ifv(nodof),
     &  res(nodof), load(nodof)
c
c              locals
c
      integer :: i
      double precision ::
     &  nfac, zero, one, two, accel_n1, term_load, nfac1, nfac2,
     &  force_lag, total_external, inertia_contact
      logical :: have_mpc_equations
      logical, parameter :: local_debug = .false.
      data zero, one, two / 0.0d00, 1.0d00, 2.0d00 /
c
      mgload = zero
      nfac   = one / (nbeta*dt*dt)
      nfac1  = (one-two*nbeta)/(two*nbeta)
      nfac2  = one/(nbeta*dt)
c
      num_term_loads = 0
      sum_loads      = zero
      have_mpc_equations = tied_con_mpcs_constructed .or. mpcs_exist
c
      if( local_debug ) write(iout,9300) iter, have_mpc_equations
c
c              for iter = 1, 2, 3.. we are computing the
c              actual residual load. compute the euclidean
c
c              residual @ n+1 = applied @ n+1 - internal @ n+1
c
c              applied = pbar + contact + dlagrange - inertia
c                        adjustment
c
c                 pbar includes user-applied forces at n+1,
c                      no contact, mpc nodal forces at n,
c                      inertia forces at n
c
c                 Thus, applied here needs the full contact forces,
c                 the change in mpc nodal forces (sometimes called
c                 Lagrange multipliers) over the step and the
c                 change in inertial forces over the step.
c
c              internal = simply the assembled int B^T sigma
c
      if( have_mpc_equations ) then
        do i = 1, nodof
          res(i) = ( pbar(i) + contact_force(i) + d_lagrange_forces(i)
     &               - mdiag(i)*du(i)*nfac ) - ifv(i)
         end do
      else
        do i = 1, nodof
          res(i) = ( pbar(i) + contact_force(i)
     &               - mdiag(i)*du(i)*nfac ) - ifv(i)
        end do
      end if
c
      if( local_debug ) then
        write(iout,9400); write(iout,9405)
        do i = 1, nodof  ! 10
          force_lag = zero
          if( have_mpc_equations ) force_lag = d_lagrange_forces(i)
          total_external = pbar(i) + contact_force(i) +
     &                     force_lag - mdiag(i)*du(i)*nfac
          write(iout,9200) i, cstmap(i), res(i), pbar(i),
     &                     contact_force(i), force_lag,
     &                     mdiag(i)*du(i)*nfac, total_external,
     &                     ifv(i)
        end do
      end if
c
c              compute a norm and sum of the current estimate of the
c              total, applied nodal forces at n+1 for use in
c              some convergence tests
c
c              treat reaction forces separately. then zero residual
c              terms for dof w/ absolute constraints.
c              ifv is negative of reactions at dof with absolute cons
c
c              Nodal Lagrange forces for MPCs are not included in
c              the loading measure. They are always a set of
c              equilibrating forces.
c
      do i = 1, nodof
        accel_n1 = du(i)*nfac - nfac1*accel(i) - nfac2*velocity(i)
        inertia_contact = abs( accel_n1) * mdiag(i) +
     &                    abs( contact_force(i) )
        if( cstmap(i) .eq. 0 ) then ! no abs con
           term_load = inertia_contact + abs( load(i) )
        else  ! absolute constraint
           term_load = inertia_contact +
     &                 abs( ifv(i) ) !  may want to include + abs( load(i) )
           res(i)    = zero
        end if
        if( term_load .ne. zero ) then
           mgload = mgload + term_load * term_load
           num_term_loads = num_term_loads + 1
           sum_loads = sum_loads + abs(term_load)
        end if
      end do
c
      mgload = sqrt( mgload )
      if( local_debug ) write(iout,9100) mgload
c
      if( local_debug ) write(iout,9305)
c
      return
c
 9100 format(5x, "... mgload: ",e14.6)
 9200 format(2x,2i7,7f16.6)
 9300 format(/,1x,"--- entering upres. iter, have multipoint: ",i3,l2)
 9305 format(1x,"--- leaving upres ---" )
 9400 format(5x,"... various force vector:")
 9405 format(t5,"sdof", t11,"cstmap", t25,"res", t40, "pbar",
     &  t51, "contact force",
     &  t70, "dlagrange", t82, "inertia adjust",t101,"total ext",t120,
     &   "ifv" )
c
      end


text:
! ----------------------------------------------------------------------------------------------
!> @brief     This module reflects the version macro definition only.
!> version    1.0.0
!> @author    Christopher Kebschull(TUBS/IRAS)
!> @date      14.10.19.
!> @copyright Apache License 2.0
!
! ----------------------------------------------------------------------------------------------

!> This module combines all libraries (inout, math and astro) into slam
module slam
    use ISO_C_BINDING

#define SLAM_VERSION_MAJOR 1
#define SLAM_VERSION_MINOR 1
#define SLAM_VERSION_REVISION 0

end module slam
!=========================================================================================

max_stars_repo_name: Space-Systems/libslam

max_issues_repo_name: Space-Systems/libslam

max_forks_repo_name: Space-Systems/libslam