VARIABLE pass_cnt
VARIABLE fail_cnt

: passed
    pass_cnt @ 1+ pass_cnt !
;

: failed
    fail_cnt @ 1+ fail_cnt !
;

: test_cond
    \\ ----------------------------------
    \\ passed and failed counter init
    0 pass_cnt !
    0 fail_cnt !
    \\ test 1: equal
    1 1 =
        IF ." equal test 1 passed" LF passed
        ELSE ." equal test 1 failed" LF failed
        THEN FLUSH
    \\ test 2: equal
    1 2 =
        IF ." equal test 2 failed" LF failed
        ELSE ." equal test 2 passed" LF passed
        THEN FLUSH
    \\ test 3: equal
    2 1 =
        IF ." equal test 3 failed" LF failed
        ELSE ." equal test 3 passed" LF passed
        THEN FLUSH
    \\ ----------------------------------
    \\ test 1: greater-than
    2 1 >
        IF ." greater-than test 1 passed" LF passed
        ELSE ." greater-than test 1 failed" LF failed
        THEN FLUSH
    \\ test 2: greater-than
    1 2 >
        IF ." greater-than test 2 failed" LF failed
        ELSE ." greater-than test 2 passed" LF passed
        THEN FLUSH
    \\ test 3: greater-than
    1 1 >
        IF ." greater-than test 3 failed" LF failed
        ELSE ." greater-than test 3 passed" LF passed
        THEN FLUSH
    \\ ----------------------------------
    \\ test 1: less-than
    1 2 <
        IF ." less-than test 1 passed" LF passed
        ELSE ." less-than test 1 failed" LF failed
        THEN FLUSH
    \\ test 2: less-than
    2 1 <
        IF ." less-than test 2 failed" LF failed
        ELSE ." less-than test 2 passed" LF passed
        THEN FLUSH
    \\ test 3: less-than
    1 1 <
        IF ." less-than test 3 failed" LF failed
        ELSE ." less-than test 3 passed" LF passed
        THEN FLUSH
    \\ ----------------------------------
    \\ test 1: greater-than or equal
    2 1 >=
        IF ." greater-than or equal test 1 passed" LF passed
        ELSE ." greater-than or equal test 1 failed" LF failed
        THEN FLUSH
    \\ test 2: greater-than or equal
    1 1 >=
        IF ." greater-than or equal test 2 passed" LF passed
        ELSE ." greater-than or equal test 2 failed" LF failed
        THEN FLUSH
    \\ test 3: greater-than or equal
    1 2 >=
        IF ." greater-than or equal test 3 failed" LF failed
        ELSE ." greater-than or equal test 3 passed" LF passed
        THEN FLUSH
    \\ ----------------------------------
    \\ test 1: less-than or equal
    1 2 <=
        IF ." less-than or equal test 1 passed" LF passed
        ELSE ." less-than or equal test 1 failed" LF failed
        THEN FLUSH
    \\ test 2: less-than or equal
    1 1 <=
        IF ." less-than or equal test 2 passed" LF passed
        ELSE ." less-than or equal test 2 failed" LF failed
        THEN FLUSH
    \\ test 3: less-than or equal
    2 1 <=
        IF ." less-than or equal test 3 failed" LF failed
        ELSE ." less-than or equal test 3 passed" LF passed
        THEN FLUSH
    \\ ----------------------------------
    \\ test 1: not-equal
    1 2 !=
        IF ." not-equal test 1 passed" LF passed
        ELSE ." not-equal test 1 failed" LF failed
        THEN FLUSH
    \\ test 2: not-equal
    2 1 !=
        IF ." not-equal test 2 passed" LF passed
        ELSE ." not-equal test 2 failed" LF failed
        THEN FLUSH
    \\ test 3: not-equal
    1 1 !=
        IF ." not-equal test 3 failed" LF failed
        ELSE ." not-equal test 3 passed" LF passed
        THEN FLUSH
    \\ ----------------------------------
    \\ test 1: equal to zero
    0 =0
        IF ." equal to zero test 1 passed" LF passed
        ELSE ." equal to zero test 1 failed" LF failed
        THEN FLUSH
    \\ test 2: equal to zero
    1 =0
        IF ." equal to zero test 2 failed" LF failed
        ELSE ." equal to zero test 2 passed" LF passed
        THEN FLUSH
    \\ ----------------------------------
    \\ test 1: not equal to zero
    1 !=0
        IF ." not equal to zero test 1 passed" LF passed
        ELSE ." not equal to zero test 1 failed" LF failed
        THEN FLUSH
    \\ test 2: not equal to zero
    0 !=0
        IF ." not equal to zero test 2 failed" LF failed
        ELSE ." not equal to zero test 2 passed" LF passed
        THEN FLUSH
    \\ ----------------------------------
    \\ test 1: greater-than zero
    1 >0
        IF ." greater-than zero test 1 passed" LF passed
        ELSE ." greater-than zero test 1 failed" LF failed
        THEN FLUSH
    \\ test 2: greater-than zero
    0 >0
        IF ." greater-than zero test 2 failed" LF failed
        ELSE ." greater-than zero test 2 passed" LF passed
        THEN FLUSH
    \\ ----------------------------------
    \\ test 1: less-than zero
    -1 <0
        IF ." less-than zero test 1 passed" LF passed
        ELSE ." less-than zero test 1 failed" LF failed
        THEN FLUSH
    \\ test 2: less-than zero
    0 <0
        IF ." less-than zero test 2 failed" LF failed
        ELSE ." less-than zero test 2 passed" LF passed
        THEN FLUSH

    LF
    fail_cnt @
    pass_cnt @
    2dup
    ." Count : " + . LF
    ." Passed: " . LF
    ." Failed: " . LF
;

: test_stack
    \\ ----------------------------------
    \\ passed and failed counter init
    0 pass_cnt !
    0 fail_cnt !
    \\ ----------------------------------
    \\ test: noop
    0 noop
        =0 IF ." noop test passed" LF passed
        ELSE ." noop test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: drop
    0 1 drop
        =0 IF ." drop test passed" LF passed
        ELSE ." drop test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: 2drop
    0 1 2 2drop
        =0 IF ." 2drop test passed" LF passed
        ELSE ." 2drop test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: dup
    1 dup
        = IF ." dup test passed" LF passed
        ELSE ." dup test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: 2dup
    1 1 2dup
        = IF
            = IF ." 2dup test passed" LF passed
            ELSE ." 2dup test failed" LF failed
            THEN
        ELSE ." 2dup test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: swap
    1 2 swap
       1 = IF
            2 = IF ." swap test passed" LF passed
            ELSE ." swap test failed" LF failed
            THEN
        ELSE ." swap test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: 2swap
    1 2 3 4 2swap
       + 3 = IF
            + 7 = IF ." 2swap test passed" LF passed
            ELSE ." 2swap test failed" LF failed
            THEN
        ELSE ." 2swap test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: pick
    1 2 3 4
       0 pick
       1 = IF ." pick test passed" LF passed
        ELSE ." pick test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: over
    1 2 over
       1 = IF ." over test passed" LF passed
        ELSE ." over test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: 2over
    1 1 3 3 2over
       + 2 = IF ." 2over test passed" LF passed
        ELSE ." 2over test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: rot
    1 2 3 rot
       1 = IF ." rot test passed" LF passed
        ELSE ." rot test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: 2rot
    1 2 3 4 5 6 2rot
       + 3 = IF ." 2rot test passed" LF passed
        ELSE ." 2rot test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: nip
    1 2 3 4 nip
       swap 2 = IF ." nip test passed" LF passed
        ELSE ." nip test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: tuck
    1 2 tuck
       2drop 2 = IF ." tuck test passed" LF passed
        ELSE ." tuck test failed" LF failed
        THEN FLUSH

    LF
    fail_cnt @
    pass_cnt @
    2dup
    ." Count : " + . LF
    ." Passed: " . LF
    ." Failed: " . LF
;

: test_float
    \\ ----------------------------------
    \\ passed and failed counter init
    0 pass_cnt !
    0 fail_cnt !
    \\ ----------------------------------
    \\ test: float-increment
    1.99 f1+
        2.99 = IF ." float-increment test passed" LF passed
        ELSE ." float-increment test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: float-add
    1.50 1.55 f+
        3.05 = IF ." float-add test passed" LF passed
        ELSE ." float-add test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: float-subtract
    3.978 3.008 f-
        0.970 = IF ." float-subtract test passed" LF passed
        ELSE ." float-subtract test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: float-multiply
    1.50 2.05 f*
        3.75 = IF ." float-multiply test passed" LF passed
        ELSE ." float-multiply test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: float-divide
    4.98 1.69 f/
        2.94674556213 = IF ." float-divide test passed" LF passed
        ELSE ." float-divide test failed" LF failed
        THEN FLUSH
    \\ ----------------------------------
    \\ test: float-multiply-divide
    2.2 2.2 4.0 f*/
        1.21 = IF ." float-multiply-divide test passed" LF passed
        ELSE ." float-multiply-divide test failed" LF failed
        THEN FLUSH

    LF
    fail_cnt @
    pass_cnt @
    2dup
    ." Count : " + . LF
    ." Passed: " . LF
    ." Failed: " . LF
;

/*
    >r r> 2>r 2r> r@ 2r@ ! @
    and or xor ~ << >>
    1+ 1- + - * / * / mod /mod negate abs min max

    pc sp rp

*/


      double precision function acorni(idum)
c-----------------------------------------------------------------------
c
c Fortran implementation of ACORN random number generator of order less
c than or equal to 12 (higher orders can be obtained by increasing the
c parameter value MAXORD).
c
c
c NOTES: 1. The variable idum is a dummy variable. The common block
c           IACO is used to transfer data into the function.
c
c        2. Before the first call to ACORN the common block IACO must
c           be initialised by the user, as follows. The values of
c           variables in the common block must not subsequently be
c           changed by the user.
c
c             KORDEI - order of generator required ( must be =< MAXORD)
c
c             MAXINT - modulus for generator, must be chosen small
c                      enough that 2*MAXINT does not overflow
c
c             ixv(1) - seed for random number generator
c                      require 0 < ixv(1) < MAXINT
c
c             (ixv(I+1),I=1,KORDEI)
c                    - KORDEI initial values for generator
c                      require 0 =< ixv(I+1) < MAXINT
c
c        3. After initialisation, each call to ACORN generates a single
c           random number between 0 and 1.
c
c        4. An example of suitable values for parameters is
c
c             KORDEI   = 10
c             MAXINT   = 2**30
c             ixv(1)   = an odd integer in the (approximate) range
c                        (0.001 * MAXINT) to (0.999 * MAXINT)
c             ixv(I+1) = 0, I=1,KORDEI
c
c
c
c Author: R.S.Wikramaratna,                           Date: October 1990
c-----------------------------------------------------------------------
      implicit integer (i-n)
      implicit double precision (a-h,o-z)

      parameter (KORDEI=12,MAXOP1=KORDEI+1,MAXINT=2**30)
      common/iaco/ ixv(MAXOP1)

      do i=1,KORDEI
            ixv(i+1)=(ixv(i+1)+ixv(i))
            if(ixv(i+1).ge.MAXINT) ixv(i+1)=ixv(i+1)-MAXINT
      end do
      acorni=dble(ixv(KORDEI+1))/MAXINT
      return
      end


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine anisotropic(anisol,anisox)
!
!     expands the 21 anisotropic elastic constants into a
!     3x3x3x3 matrix
!
      implicit none
!
      real*8 anisol(21),anisox(3,3,3,3)
!
      intent(in) anisol
!
      intent(out) anisox
!
      anisox(1,1,1,1)=anisol(1)
      anisox(1,1,1,2)=anisol(7)
      anisox(1,1,1,3)=anisol(11)
      anisox(1,1,2,1)=anisol(7)
      anisox(1,1,2,2)=anisol(2)
      anisox(1,1,2,3)=anisol(16)
      anisox(1,1,3,1)=anisol(11)
      anisox(1,1,3,2)=anisol(16)
      anisox(1,1,3,3)=anisol(4)
      anisox(1,2,1,1)=anisol(7)
      anisox(1,2,1,2)=anisol(10)
      anisox(1,2,1,3)=anisol(14)
      anisox(1,2,2,1)=anisol(10)
      anisox(1,2,2,2)=anisol(8)
      anisox(1,2,2,3)=anisol(19)
      anisox(1,2,3,1)=anisol(14)
      anisox(1,2,3,2)=anisol(19)
      anisox(1,2,3,3)=anisol(9)
      anisox(1,3,1,1)=anisol(11)
      anisox(1,3,1,2)=anisol(14)
      anisox(1,3,1,3)=anisol(15)
      anisox(1,3,2,1)=anisol(14)
      anisox(1,3,2,2)=anisol(12)
      anisox(1,3,2,3)=anisol(20)
      anisox(1,3,3,1)=anisol(15)
      anisox(1,3,3,2)=anisol(20)
      anisox(1,3,3,3)=anisol(13)
      anisox(2,1,1,1)=anisol(7)
      anisox(2,1,1,2)=anisol(10)
      anisox(2,1,1,3)=anisol(14)
      anisox(2,1,2,1)=anisol(10)
      anisox(2,1,2,2)=anisol(8)
      anisox(2,1,2,3)=anisol(19)
      anisox(2,1,3,1)=anisol(14)
      anisox(2,1,3,2)=anisol(19)
      anisox(2,1,3,3)=anisol(9)
      anisox(2,2,1,1)=anisol(2)
      anisox(2,2,1,2)=anisol(8)
      anisox(2,2,1,3)=anisol(12)
      anisox(2,2,2,1)=anisol(8)
      anisox(2,2,2,2)=anisol(3)
      anisox(2,2,2,3)=anisol(17)
      anisox(2,2,3,1)=anisol(12)
      anisox(2,2,3,2)=anisol(17)
      anisox(2,2,3,3)=anisol(5)
      anisox(2,3,1,1)=anisol(16)
      anisox(2,3,1,2)=anisol(19)
      anisox(2,3,1,3)=anisol(20)
      anisox(2,3,2,1)=anisol(19)
      anisox(2,3,2,2)=anisol(17)
      anisox(2,3,2,3)=anisol(21)
      anisox(2,3,3,1)=anisol(20)
      anisox(2,3,3,2)=anisol(21)
      anisox(2,3,3,3)=anisol(18)
      anisox(3,1,1,1)=anisol(11)
      anisox(3,1,1,2)=anisol(14)
      anisox(3,1,1,3)=anisol(15)
      anisox(3,1,2,1)=anisol(14)
      anisox(3,1,2,2)=anisol(12)
      anisox(3,1,2,3)=anisol(20)
      anisox(3,1,3,1)=anisol(15)
      anisox(3,1,3,2)=anisol(20)
      anisox(3,1,3,3)=anisol(13)
      anisox(3,2,1,1)=anisol(16)
      anisox(3,2,1,2)=anisol(19)
      anisox(3,2,1,3)=anisol(20)
      anisox(3,2,2,1)=anisol(19)
      anisox(3,2,2,2)=anisol(17)
      anisox(3,2,2,3)=anisol(21)
      anisox(3,2,3,1)=anisol(20)
      anisox(3,2,3,2)=anisol(21)
      anisox(3,2,3,3)=anisol(18)
      anisox(3,3,1,1)=anisol(4)
      anisox(3,3,1,2)=anisol(9)
      anisox(3,3,1,3)=anisol(13)
      anisox(3,3,2,1)=anisol(9)
      anisox(3,3,2,2)=anisol(5)
      anisox(3,3,2,3)=anisol(18)
      anisox(3,3,3,1)=anisol(13)
      anisox(3,3,3,2)=anisol(18)
      anisox(3,3,3,3)=anisol(6)
!
      return
      end


C FISHPK12 FROM PORTLIB                                  12/30/83
      SUBROUTINE HW3CRT (XS,XF,L,LBDCND,BDXS,BDXF,YS,YF,M,MBDCND,BDYS,
     1                   BDYF,ZS,ZF,N,NBDCND,BDZS,BDZF,ELMBDA,LDIMF,
     2                   MDIMF,F,PERTRB,IERROR,W)
C
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * * *  PURPOSE    * * * * * * * * * * * * * * * * * *
C
C          SUBROUTINE HW3CRT SOLVES THE STANDARD SEVEN-POINT FINITE
C     DIFFERENCE APPROXIMATION TO THE HELMHOLTZ EQUATION IN CARTESIAN
C     COORDINATES:
C
C         (D/DX)(DU/DX) + (D/DY)(DU/DY) + (D/DZ)(DU/DZ)
C
C                    + LAMBDA*U = F(X,Y,Z) .
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * *    PARAMETER DESCRIPTION     * * * * * * * * * *
C
C
C            * * * * * *   ON INPUT    * * * * * *
C
C     XS,XF
C        THE RANGE OF X, I.E. XS .LE. X .LE. XF .
C        XS MUST BE LESS THAN XF.
C
C     L
C        THE NUMBER OF PANELS INTO WHICH THE INTERVAL (XS,XF) IS
C        SUBDIVIDED.  HENCE, THERE WILL BE L+1 GRID POINTS IN THE
C        X-DIRECTION GIVEN BY X(I) = XS+(I-1)DX FOR I=1,2,...,L+1,
C        WHERE DX = (XF-XS)/L IS THE PANEL WIDTH.  L MUST BE AT
C        LEAST 5 .
C
C     LBDCND
C        INDICATES THE TYPE OF BOUNDARY CONDITIONS AT X = XS AND X = XF.
C
C        = 0  IF THE SOLUTION IS PERIODIC IN X, I.E.
C             U(L+I,J,K) = U(I,J,K).
C        = 1  IF THE SOLUTION IS SPECIFIED AT X = XS AND X = XF.
C        = 2  IF THE SOLUTION IS SPECIFIED AT X = XS AND THE DERIVATIVE
C             OF THE SOLUTION WITH RESPECT TO X IS SPECIFIED AT X = XF.
C        = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO X IS
C             SPECIFIED AT X = XS AND X = XF.
C        = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO X IS
C             SPECIFIED AT X = XS AND THE SOLUTION IS SPECIFIED AT X=XF.
C
C     BDXS
C        A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        DERIVATIVE OF THE SOLUTION WITH RESPECT TO X AT X = XS.
C        WHEN LBDCND = 3 OR 4,
C
C             BDXS(J,K) = (D/DX)U(XS,Y(J),Z(K)), J=1,2,...,M+1,
C                                                K=1,2,...,N+1.
C
C        WHEN LBDCND HAS ANY OTHER VALUE, BDXS IS A DUMMY VARIABLE.
C        BDXS MUST BE DIMENSIONED AT LEAST (M+1)*(N+1).
C
C     BDXF
C        A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        DERIVATIVE OF THE SOLUTION WITH RESPECT TO X AT X = XF.
C        WHEN LBDCND = 2 OR 3,
C
C             BDXF(J,K) = (D/DX)U(XF,Y(J),Z(K)), J=1,2,...,M+1,
C                                                K=1,2,...,N+1.
C
C        WHEN LBDCND HAS ANY OTHER VALUE, BDXF IS A DUMMY VARIABLE.
C        BDXF MUST BE DIMENSIONED AT LEAST (M+1)*(N+1).
C
C     YS,YF
C        THE RANGE OF Y, I.E. YS .LE. Y .LE. YF.
C        YS MUST BE LESS THAN YF.
C
C     M
C        THE NUMBER OF PANELS INTO WHICH THE INTERVAL (YS,YF) IS
C        SUBDIVIDED.  HENCE, THERE WILL BE M+1 GRID POINTS IN THE
C        Y-DIRECTION GIVEN BY Y(J) = YS+(J-1)DY FOR J=1,2,...,M+1,
C        WHERE DY = (YF-YS)/M IS THE PANEL WIDTH.  M MUST BE AT
C        LEAST 5 .
C
C     MBDCND
C        INDICATES THE TYPE OF BOUNDARY CONDITIONS AT Y = YS AND Y = YF.
C
C        = 0  IF THE SOLUTION IS PERIODIC IN Y, I.E.
C             U(I,M+J,K) = U(I,J,K).
C        = 1  IF THE SOLUTION IS SPECIFIED AT Y = YS AND Y = YF.
C        = 2  IF THE SOLUTION IS SPECIFIED AT Y = YS AND THE DERIVATIVE
C             OF THE SOLUTION WITH RESPECT TO Y IS SPECIFIED AT Y = YF.
C        = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y IS
C             SPECIFIED AT Y = YS AND Y = YF.
C        = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y IS
C             SPECIFIED AT Y = YS AND THE SOLUTION IS SPECIFIED AT Y=YF.
C
C     BDYS
C        A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y AT Y = YS.
C        WHEN MBDCND = 3 OR 4,
C
C             BDYS(I,K) = (D/DY)U(X(I),YS,Z(K)), I=1,2,...,L+1,
C                                                K=1,2,...,N+1.
C
C        WHEN MBDCND HAS ANY OTHER VALUE, BDYS IS A DUMMY VARIABLE.
C        BDYS MUST BE DIMENSIONED AT LEAST (L+1)*(N+1).
C
C     BDYF
C        A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y AT Y = YF.
C        WHEN MBDCND = 2 OR 3,
C
C             BDYF(I,K) = (D/DY)U(X(I),YF,Z(K)), I=1,2,...,L+1,
C                                                K=1,2,...,N+1.
C
C        WHEN MBDCND HAS ANY OTHER VALUE, BDYF IS A DUMMY VARIABLE.
C        BDYF MUST BE DIMENSIONED AT LEAST (L+1)*(N+1).
C
C     ZS,ZF
C        THE RANGE OF Z, I.E. ZS .LE. Z .LE. ZF.
C        ZS MUST BE LESS THAN ZF.
C
C     N
C        THE NUMBER OF PANELS INTO WHICH THE INTERVAL (ZS,ZF) IS
C        SUBDIVIDED.  HENCE, THERE WILL BE N+1 GRID POINTS IN THE
C        Z-DIRECTION GIVEN BY Z(K) = ZS+(K-1)DZ FOR K=1,2,...,N+1,
C        WHERE DZ = (ZF-ZS)/N IS THE PANEL WIDTH.  N MUST BE AT LEAST 5.
C
C     NBDCND
C        INDICATES THE TYPE OF BOUNDARY CONDITIONS AT Z = ZS AND Z = ZF.
C
C        = 0  IF THE SOLUTION IS PERIODIC IN Z, I.E.
C             U(I,J,N+K) = U(I,J,K).
C        = 1  IF THE SOLUTION IS SPECIFIED AT Z = ZS AND Z = ZF.
C        = 2  IF THE SOLUTION IS SPECIFIED AT Z = ZS AND THE DERIVATIVE
C             OF THE SOLUTION WITH RESPECT TO Z IS SPECIFIED AT Z = ZF.
C        = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Z IS
C             SPECIFIED AT Z = ZS AND Z = ZF.
C        = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Z IS
C             SPECIFIED AT Z = ZS AND THE SOLUTION IS SPECIFIED AT Z=ZF.
C
C     BDZS
C        A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        DERIVATIVE OF THE SOLUTION WITH RESPECT TO Z AT Z = ZS.
C        WHEN NBDCND = 3 OR 4,
C
C             BDZS(I,J) = (D/DZ)U(X(I),Y(J),ZS), I=1,2,...,L+1,
C                                                J=1,2,...,M+1.
C
C        WHEN NBDCND HAS ANY OTHER VALUE, BDZS IS A DUMMY VARIABLE.
C        BDZS MUST BE DIMENSIONED AT LEAST (L+1)*(M+1).
C
C     BDZF
C        A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        DERIVATIVE OF THE SOLUTION WITH RESPECT TO Z AT Z = ZF.
C        WHEN NBDCND = 2 OR 3,
C
C             BDZF(I,J) = (D/DZ)U(X(I),Y(J),ZF), I=1,2,...,L+1,
C                                                J=1,2,...,M+1.
C
C        WHEN NBDCND HAS ANY OTHER VALUE, BDZF IS A DUMMY VARIABLE.
C        BDZF MUST BE DIMENSIONED AT LEAST (L+1)*(M+1).
C
C     ELMBDA
C        THE CONSTANT LAMBDA IN THE HELMHOLTZ EQUATION. IF
C        LAMBDA .GT. 0, A SOLUTION MAY NOT EXIST.  HOWEVER, HW3CRT WILL
C        ATTEMPT TO FIND A SOLUTION.
C
C     F
C        A THREE-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        RIGHT SIDE OF THE HELMHOLTZ EQUATION AND BOUNDARY VALUES (IF
C        ANY).  FOR I=2,3,...,L, J=2,3,...,M, AND K=2,3,...,N
C
C                   F(I,J,K) = F(X(I),Y(J),Z(K)).
C
C        ON THE BOUNDARIES F IS DEFINED BY
C
C        LBDCND      F(1,J,K)         F(L+1,J,K)
C        ------   ---------------   ---------------
C
C          0      F(XS,Y(J),Z(K))   F(XS,Y(J),Z(K))
C          1      U(XS,Y(J),Z(K))   U(XF,Y(J),Z(K))
C          2      U(XS,Y(J),Z(K))   F(XF,Y(J),Z(K))   J=1,2,...,M+1
C          3      F(XS,Y(J),Z(K))   F(XF,Y(J),Z(K))   K=1,2,...,N+1
C          4      F(XS,Y(J),Z(K))   U(XF,Y(J),Z(K))
C
C        MBDCND      F(I,1,K)         F(I,M+1,K)
C        ------   ---------------   ---------------
C
C          0      F(X(I),YS,Z(K))   F(X(I),YS,Z(K))
C          1      U(X(I),YS,Z(K))   U(X(I),YF,Z(K))
C          2      U(X(I),YS,Z(K))   F(X(I),YF,Z(K))   I=1,2,...,L+1
C          3      F(X(I),YS,Z(K))   F(X(I),YF,Z(K))   K=1,2,...,N+1
C          4      F(X(I),YS,Z(K))   U(X(I),YF,Z(K))
C
C        NBDCND      F(I,J,1)         F(I,J,N+1)
C        ------   ---------------   ---------------
C
C          0      F(X(I),Y(J),ZS)   F(X(I),Y(J),ZS)
C          1      U(X(I),Y(J),ZS)   U(X(I),Y(J),ZF)
C          2      U(X(I),Y(J),ZS)   F(X(I),Y(J),ZF)   I=1,2,...,L+1
C          3      F(X(I),Y(J),ZS)   F(X(I),Y(J),ZF)   J=1,2,...,M+1
C          4      F(X(I),Y(J),ZS)   U(X(I),Y(J),ZF)
C
C        F MUST BE DIMENSIONED AT LEAST (L+1)*(M+1)*(N+1).
C
C        NOTE:
C
C        IF THE TABLE CALLS FOR BOTH THE SOLUTION U AND THE RIGHT SIDE F
C        ON A BOUNDARY, THEN THE SOLUTION MUST BE SPECIFIED.
C
C     LDIMF
C        THE ROW (OR FIRST) DIMENSION OF THE ARRAYS F,BDYS,BDYF,BDZS,
C        AND BDZF AS IT APPEARS IN THE PROGRAM CALLING HW3CRT. THIS
C        PARAMETER IS USED TO SPECIFY THE VARIABLE DIMENSION OF THESE
C        ARRAYS.  LDIMF MUST BE AT LEAST L+1.
C
C     MDIMF
C        THE COLUMN (OR SECOND) DIMENSION OF THE ARRAY F AND THE ROW (OR
C        FIRST) DIMENSION OF THE ARRAYS BDXS AND BDXF AS IT APPEARS IN
C        THE PROGRAM CALLING HW3CRT.  THIS PARAMETER IS USED TO SPECIFY
C        THE VARIABLE DIMENSION OF THESE ARRAYS.
C        MDIMF MUST BE AT LEAST M+1.
C
C     W
C        A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR
C        WORK SPACE.  THE LENGTH OF W MUST BE AT LEAST 30 + L + M + 5*N
C        + MAX(L,M,N) + 7*(INT((L+1)/2) + INT((M+1)/2))
C
C
C            * * * * * *   ON OUTPUT   * * * * * *
C
C     F
C        CONTAINS THE SOLUTION U(I,J,K) OF THE FINITE DIFFERENCE
C        APPROXIMATION FOR THE GRID POINT (X(I),Y(J),Z(K)) FOR
C        I=1,2,...,L+1, J=1,2,...,M+1, AND K=1,2,...,N+1.
C
C     PERTRB
C        IF A COMBINATION OF PERIODIC OR DERIVATIVE BOUNDARY CONDITIONS
C        IS SPECIFIED FOR A POISSON EQUATION (LAMBDA = 0), A SOLUTION
C        MAY NOT EXIST.  PERTRB IS A CONSTANT, CALCULATED AND SUBTRACTED
C        FROM F, WHICH ENSURES THAT A SOLUTION EXISTS.  PWSCRT THEN
C        COMPUTES THIS SOLUTION, WHICH IS A LEAST SQUARES SOLUTION TO
C        THE ORIGINAL APPROXIMATION.  THIS SOLUTION IS NOT UNIQUE AND IS
C        UNNORMALIZED.  THE VALUE OF PERTRB SHOULD BE SMALL COMPARED TO
C        THE RIGHT SIDE F.  OTHERWISE, A SOLUTION IS OBTAINED TO AN
C        ESSENTIALLY DIFFERENT PROBLEM.  THIS COMPARISON SHOULD ALWAYS
C        BE MADE TO INSURE THAT A MEANINGFUL SOLUTION HAS BEEN OBTAINED.
C
C     IERROR
C        AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.  EXCEPT
C        FOR NUMBERS 0 AND 12, A SOLUTION IS NOT ATTEMPTED.
C
C        =  0  NO ERROR
C        =  1  XS .GE. XF
C        =  2  L .LT. 5
C        =  3  LBDCND .LT. 0 .OR. LBDCND .GT. 4
C        =  4  YS .GE. YF
C        =  5  M .LT. 5
C        =  6  MBDCND .LT. 0 .OR. MBDCND .GT. 4
C        =  7  ZS .GE. ZF
C        =  8  N .LT. 5
C        =  9  NBDCND .LT. 0 .OR. NBDCND .GT. 4
C        = 10  LDIMF .LT. L+1
C        = 11  MDIMF .LT. M+1
C        = 12  LAMBDA .GT. 0
C
C        SINCE THIS IS THE ONLY MEANS OF INDICATING A POSSIBLY INCORRECT
C        CALL TO HW3CRT, THE USER SHOULD TEST IERROR AFTER THE CALL.
C
C
C    * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C     DIMENSION OF   BDXS(MDIMF,N+1),BDXF(MDIMF,N+1),BDYS(LDIMF,N+1),
C     ARGUMENTS      BDYF(LDIMF,N+1),BDZS(LDIMF,M+1),BDZF(LDIMF,M+1),
C                    F(LDIMF,MDIMF,N+1),W(SEE ARGUMENT LIST)
C
C     LATEST         DECEMBER 1, 1978
C     REVISION
C
C     SUBPROGRAMS    HW3CRT,POIS3D,POS3D1,TRID,RFFTI,RFFTF,RFFTF1,
C     REQUIRED       RFFTB,RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF,
C                    COSQF1,COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI,
C                    CFFTI1,CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB,
C                    CFFTF,CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF,
C                    PIMACH
C
C     SPECIAL        NONE
C     CONDITIONS
C
C     COMMON         VALUE
C     BLOCKS
C
C     I/O            NONE
C
C     PRECISION      SINGLE
C
C     SPECIALIST     ROLAND SWEET
C
C     LANGUAGE       FORTRAN
C
C     HISTORY        WRITTEN BY ROLAND SWEET AT NCAR IN JULY,1977
C
C     ALGORITHM      THIS SUBROUTINE DEFINES THE FINITE DIFFERENCE
C                    EQUATIONS, INCORPORATES BOUNDARY DATA, AND
C                    ADJUSTS THE RIGHT SIDE OF SINGULAR SYSTEMS AND
C                    THEN CALLS POIS3D TO SOLVE THE SYSTEM.
C
C     SPACE          7862(DECIMAL) = 17300(OCTAL) LOCATIONS ON THE
C     REQUIRED       NCAR CONTROL DATA 7600
C
C     TIMING AND        THE EXECUTION TIME T ON THE NCAR CONTROL DATA
C     ACCURACY       7600 FOR SUBROUTINE HW3CRT IS ROUGHLY PROPORTIONAL
C                    TO L*M*N*(LOG2(L)+LOG2(M)+5), BUT ALSO DEPENDS ON
C                    INPUT PARAMETERS LBDCND AND MBDCND.  SOME TYPICAL
C                    VALUES ARE LISTED IN THE TABLE BELOW.
C                       THE SOLUTION PROCESS EMPLOYED RESULTS IN A LOSS
C                    OF NO MORE THAN THREE SIGNIFICANT DIGITS FOR L,M AN
C                    N AS LARGE AS 32.  MORE DETAILED INFORMATION ABOUT
C                    ACCURACY CAN BE FOUND IN THE DOCUMENTATION FOR
C                    SUBROUTINE POIS3D WHICH IS THE ROUTINE THAT ACTUALL
C                    SOLVES THE FINITE DIFFERENCE EQUATIONS.
C
C
C                       L(=M=N)     LBDCND(=MBDCND=NBDCND)      T(MSECS)
C                       -------     ----------------------      --------
C
C                         16                  0                    300
C                         16                  1                    302
C                         16                  3                    348
C                         32                  0                   1925
C                         32                  1                   1929
C                         32                  3                   2109
C
C     PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN.
C                    THE MACHINE DEPENDENT CONSTANT PI IS DEFINED IN
C                    FUNCTION PIMACH.
C
C     REQUIRED       COS,SIN,ATAN
C     RESIDENT
C     ROUTINES
C
C     REFERENCE      NONE
C
C     REQUIRED         COS,SIN,ATAN
C     RESIDENT
C     ROUTINES
C
C     REFERENCE        NONE
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      DIMENSION       BDXS(MDIMF,1)          ,BDXF(MDIMF,1)          ,
     1                BDYS(LDIMF,1)          ,BDYF(LDIMF,1)          ,
     2                BDZS(LDIMF,1)          ,BDZF(LDIMF,1)          ,
     3                F(LDIMF,MDIMF,1)       ,W(1)
C
C     CHECK FOR INVALID INPUT.
C
      IERROR = 0
      IF (XF .LE. XS) IERROR = 1
      IF (L .LT. 5) IERROR = 2
      IF (LBDCND.LT.0 .OR. LBDCND.GT.4) IERROR = 3
      IF (YF .LE. YS) IERROR = 4
      IF (M .LT. 5) IERROR = 5
      IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 6
      IF (ZF .LE. ZS) IERROR = 7
      IF (N .LT. 5) IERROR = 8
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 9
      IF (LDIMF .LT. L+1) IERROR = 10
      IF (MDIMF .LT. M+1) IERROR = 11
      IF (IERROR .NE. 0) GO TO 188
      DY = (YF-YS)/FLOAT(M)
      TWBYDY = 2./DY
      C2 = 1./(DY**2)
      MSTART = 1
      MSTOP = M
      MP1 = M+1
      MP = MBDCND+1
      GO TO (104,101,101,102,102),MP
  101 MSTART = 2
  102 GO TO (104,104,103,103,104),MP
  103 MSTOP = MP1
  104 MUNK = MSTOP-MSTART+1
      DZ = (ZF-ZS)/FLOAT(N)
      TWBYDZ = 2./DZ
      NP = NBDCND+1
      C3 = 1./(DZ**2)
      NP1 = N+1
      NSTART = 1
      NSTOP = N
      GO TO (108,105,105,106,106),NP
  105 NSTART = 2
  106 GO TO (108,108,107,107,108),NP
  107 NSTOP = NP1
  108 NUNK = NSTOP-NSTART+1
      LP1 = L+1
      DX = (XF-XS)/FLOAT(L)
      C1 = 1./(DX**2)
      TWBYDX = 2./DX
      LP = LBDCND+1
      LSTART = 1
      LSTOP = L
C
C     ENTER BOUNDARY DATA FOR X-BOUNDARIES.
C
      GO TO (122,109,109,112,112),LP
  109 LSTART = 2
      DO 111 J=MSTART,MSTOP
         DO 110 K=NSTART,NSTOP
            F(2,J,K) = F(2,J,K)-C1*F(1,J,K)
  110    CONTINUE
  111 CONTINUE
      GO TO 115
  112 DO 114 J=MSTART,MSTOP
         DO 113 K=NSTART,NSTOP
            F(1,J,K) = F(1,J,K)+TWBYDX*BDXS(J,K)
  113    CONTINUE
  114 CONTINUE
  115 GO TO (122,116,119,119,116),LP
  116 DO 118 J=MSTART,MSTOP
         DO 117 K=NSTART,NSTOP
            F(L,J,K) = F(L,J,K)-C1*F(LP1,J,K)
  117    CONTINUE
  118 CONTINUE
      GO TO 122
  119 LSTOP = LP1
      DO 121 J=MSTART,MSTOP
         DO 120 K=NSTART,NSTOP
            F(LP1,J,K) = F(LP1,J,K)-TWBYDX*BDXF(J,K)
  120    CONTINUE
  121 CONTINUE
  122 LUNK = LSTOP-LSTART+1
C
C     ENTER BOUNDARY DATA FOR Y-BOUNDARIES.
C
      GO TO (136,123,123,126,126),MP
  123 DO 125 I=LSTART,LSTOP
         DO 124 K=NSTART,NSTOP
            F(I,2,K) = F(I,2,K)-C2*F(I,1,K)
  124    CONTINUE
  125 CONTINUE
      GO TO 129
  126 DO 128 I=LSTART,LSTOP
         DO 127 K=NSTART,NSTOP
            F(I,1,K) = F(I,1,K)+TWBYDY*BDYS(I,K)
  127    CONTINUE
  128 CONTINUE
  129 GO TO (136,130,133,133,130),MP
  130 DO 132 I=LSTART,LSTOP
         DO 131 K=NSTART,NSTOP
            F(I,M,K) = F(I,M,K)-C2*F(I,MP1,K)
  131    CONTINUE
  132 CONTINUE
      GO TO 136
  133 DO 135 I=LSTART,LSTOP
         DO 134 K=NSTART,NSTOP
            F(I,MP1,K) = F(I,MP1,K)-TWBYDY*BDYF(I,K)
  134    CONTINUE
  135 CONTINUE
  136 CONTINUE
C
C     ENTER BOUNDARY DATA FOR Z-BOUNDARIES.
C
      GO TO (150,137,137,140,140),NP
  137 DO 139 I=LSTART,LSTOP
         DO 138 J=MSTART,MSTOP
            F(I,J,2) = F(I,J,2)-C3*F(I,J,1)
  138    CONTINUE
  139 CONTINUE
      GO TO 143
  140 DO 142 I=LSTART,LSTOP
         DO 141 J=MSTART,MSTOP
            F(I,J,1) = F(I,J,1)+TWBYDZ*BDZS(I,J)
  141    CONTINUE
  142 CONTINUE
  143 GO TO (150,144,147,147,144),NP
  144 DO 146 I=LSTART,LSTOP
         DO 145 J=MSTART,MSTOP
            F(I,J,N) = F(I,J,N)-C3*F(I,J,NP1)
  145    CONTINUE
  146 CONTINUE
      GO TO 150
  147 DO 149 I=LSTART,LSTOP
         DO 148 J=MSTART,MSTOP
            F(I,J,NP1) = F(I,J,NP1)-TWBYDZ*BDZF(I,J)
  148    CONTINUE
  149 CONTINUE
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
  150 CONTINUE
      IWB = NUNK+1
      IWC = IWB+NUNK
      IWW = IWC+NUNK
      DO 151 K=1,NUNK
         I = IWC+K-1
         W(K) = C3
         W(I) = C3
         I = IWB+K-1
         W(I) = -2.*C3+ELMBDA
  151 CONTINUE
      GO TO (155,155,153,152,152),NP
  152 W(IWC) = 2.*C3
  153 GO TO (155,155,154,154,155),NP
  154 W(IWB-1) = 2.*C3
  155 CONTINUE
      PERTRB = 0.
C
C     FOR SINGULAR PROBLEMS ADJUST DATA TO INSURE A SOLUTION WILL EXIST.
C
      GO TO (156,172,172,156,172),LP
  156 GO TO (157,172,172,157,172),MP
  157 GO TO (158,172,172,158,172),NP
  158 IF (ELMBDA) 172,160,159
  159 IERROR = 12
      GO TO 172
  160 CONTINUE
      MSTPM1 = MSTOP-1
      LSTPM1 = LSTOP-1
      NSTPM1 = NSTOP-1
      XLP = (2+LP)/3
      YLP = (2+MP)/3
      ZLP = (2+NP)/3
      S1 = 0.
      DO 164 K=2,NSTPM1
         DO 162 J=2,MSTPM1
            DO 161 I=2,LSTPM1
               S1 = S1+F(I,J,K)
  161       CONTINUE
            S1 = S1+(F(1,J,K)+F(LSTOP,J,K))/XLP
  162    CONTINUE
         S2 = 0.
         DO 163 I=2,LSTPM1
            S2 = S2+F(I,1,K)+F(I,MSTOP,K)
  163    CONTINUE
         S2 = (S2+(F(1,1,K)+F(1,MSTOP,K)+F(LSTOP,1,K)+F(LSTOP,MSTOP,K))/
     1                                                          XLP)/YLP
         S1 = S1+S2
  164 CONTINUE
      S = (F(1,1,1)+F(LSTOP,1,1)+F(1,1,NSTOP)+F(LSTOP,1,NSTOP)+
     1    F(1,MSTOP,1)+F(LSTOP,MSTOP,1)+F(1,MSTOP,NSTOP)+
     2                                   F(LSTOP,MSTOP,NSTOP))/(XLP*YLP)
      DO 166 J=2,MSTPM1
         DO 165 I=2,LSTPM1
            S = S+F(I,J,1)+F(I,J,NSTOP)
  165    CONTINUE
  166 CONTINUE
      S2 = 0.
      DO 167 I=2,LSTPM1
         S2 = S2+F(I,1,1)+F(I,1,NSTOP)+F(I,MSTOP,1)+F(I,MSTOP,NSTOP)
  167 CONTINUE
      S = S2/YLP+S
      S2 = 0.
      DO 168 J=2,MSTPM1
         S2 = S2+F(1,J,1)+F(1,J,NSTOP)+F(LSTOP,J,1)+F(LSTOP,J,NSTOP)
  168 CONTINUE
      S = S2/XLP+S
      PERTRB = (S/ZLP+S1)/((FLOAT(LUNK+1)-XLP)*(FLOAT(MUNK+1)-YLP)*
     1                                              (FLOAT(NUNK+1)-ZLP))
      DO 171 I=1,LUNK
         DO 170 J=1,MUNK
            DO 169 K=1,NUNK
               F(I,J,K) = F(I,J,K)-PERTRB
  169       CONTINUE
  170    CONTINUE
  171 CONTINUE
  172 CONTINUE
      NPEROD = 0
      IF (NBDCND .EQ. 0) GO TO 173
      NPEROD = 1
      W(1) = 0.
      W(IWW-1) = 0.
  173 CONTINUE
      CALL POIS3D (LBDCND,LUNK,C1,MBDCND,MUNK,C2,NPEROD,NUNK,W,W(IWB),
     1             W(IWC),LDIMF,MDIMF,F(LSTART,MSTART,NSTART),IR,W(IWW))
C
C     FILL IN SIDES FOR PERIODIC BOUNDARY CONDITIONS.
C
      IF (LP .NE. 1) GO TO 180
      IF (MP .NE. 1) GO TO 175
      DO 174 K=NSTART,NSTOP
         F(1,MP1,K) = F(1,1,K)
  174 CONTINUE
      MSTOP = MP1
  175 IF (NP .NE. 1) GO TO 177
      DO 176 J=MSTART,MSTOP
         F(1,J,NP1) = F(1,J,1)
  176 CONTINUE
      NSTOP = NP1
  177 DO 179 J=MSTART,MSTOP
         DO 178 K=NSTART,NSTOP
            F(LP1,J,K) = F(1,J,K)
  178    CONTINUE
  179 CONTINUE
  180 CONTINUE
      IF (MP .NE. 1) GO TO 185
      IF (NP .NE. 1) GO TO 182
      DO 181 I=LSTART,LSTOP
         F(I,1,NP1) = F(I,1,1)
  181 CONTINUE
      NSTOP = NP1
  182 DO 184 I=LSTART,LSTOP
         DO 183 K=NSTART,NSTOP
            F(I,MP1,K) = F(I,1,K)
  183    CONTINUE
  184 CONTINUE
  185 CONTINUE
      IF (NP .NE. 1) GO TO 188
      DO 187 I=LSTART,LSTOP
         DO 186 J=MSTART,MSTOP
            F(I,J,NP1) = F(I,J,1)
  186    CONTINUE
  187 CONTINUE
  188 CONTINUE
      RETURN
      END


	subroutine nufft1dII(nj,x,iflag,ns,rt,tol,U,V,xsub,r)
	implicit none

	integer :: ns,rt,iflag,nj,k,j,r,xsub(nj)
	real  :: tol
	real*8 pi,x(nj)
	parameter (pi=3.141592653589793238462643383279502884197d0)
	complex*16 fftconst,U(nj,r),V(ns,r)
	complex*16 M(nj,ns)

	fftconst = iflag*dcmplx(0,1)/ns*2*pi

	do k = 1,nj
	   do j = 1,ns
	      M(k,j) = exp(fftconst*(j-1)*(x(k)-floor(x(k)+0.5)))
	   enddo
	enddo

	!call lowrankfac(M,tol,rt,rt,U,V)
	xsub = mod(floor(x+0.5),ns)+1
	r = size(V,2)

	end subroutine

	subroutine nufft1dIIapp(nj,plan,c,U,V,xsub,ns,kflag,r,S)
	integer  r,i,j,k,nj,ns,kflag,num
	integer mm,xsub(nj)
	complex*16 M(r,ns),N(r,ns),S(nj),c(ns),c2(ns),U(r,nj),V(r,ns)
        complex*16,allocatable :: c1(:)
	double complex in1, out1
	dimension in1(ns), out1(nj)
	integer*8 :: plan

        c2=c
        if (kflag .lt. 0) then
           mm=floor(ns/2.0+0.6)
           allocate(c1(mm))
           c1=c2(1:mm)
           c2(1:mm)=c2(mm+1:ns)
           c2(mm+1:ns)=c1
        endif

	do k = 1,ns
	   M(:,k) = conjg(V(:,k))*c2(k)
	enddo
        !print *,'M(1,1:5)=',M(1,1:5)

	do i = 1,r
	   in1 = M(i,:)
	   call dfftw_execute_dft(plan, in1, out1)
	   N(i,:) = out1
	enddo
        !print *,'N(1,1:5)=',N(1,1:5)
        !print *,'xsub(1:5)',xsub(1:5)
	S = sum(U*N(:,xsub),1)

	end subroutine


      SUBROUTINE ELMT05(d,ul,xl,ix,tl,s,r,ndf,ndm,nst,isw,dm,
     1                   nen,n,nh1,nh2,nh3,h,ctan,ior,iow)

c .....................................................................
c     elmt05 - Two dimensional truss element
c
c     written:  fmk
c     created:  03/99
c     revision: A
c .....................................................................
      implicit none

      integer ix(*),ndf,ndm,nst,isw,nh1,nh2,nh3,nen,n,ior,iow,dm
      real*8  d(*), ul(ndf,nen,*), xl(ndm,*), tl(*), s(nst,*), r(*)

      real*8  h(*), ctan(*)

      integer  i,j
      real*8  cs, sn, L, dx, dy, k, m, A, E, rho, tran(4), eps, force

      if(isw.eq.0) then
c     output element type
         if(iow.lt.0) then
            write(*,*) '   Elmt05: 2d Truss Element.'
         else
            write(iow,*) '   Elmt05: 2d Truss Element.'
         endif

      elseif(isw.eq.1) then
c     input material properties & set nh1(=nh2), nh3
c     d(1) = A, d(2)=E, d(3) = rho, nh1 = 0, nh2 = 0

      elseif(isw.eq.2) then
c     check of mesh if desired (chec)

      elseif(isw.eq.3) then
c     compute element residual and tangent matrix

c ...... compute element length
         dx = xl(1,2) - xl(1,1)
         dy = xl(2,2) - xl(2,1)
         L = sqrt(dx*dx + dy*dy)
         cs = dx/L
         sn = dy/L
         tran(1) = cs
         tran(2) = sn
         tran(3) = -cs
         tran(4) = -sn

c ...... add stiffness portion to matrix
         A = d(1)
         E = d(2)
         if(ctan(1).ne.0.0d0) then
            k = ctan(1)*A*E/L
            do i = 1,4
               do j = 1,4
                  s(i,j) = s(i,j) + k*tran(i)*tran(j)
               enddo
            enddo
         endif

c ...... add mass portion to matrix
         rho = d(3)
         if (ctan(3).ne.0.0d0) then
            m = ctan(3)*rho*A*L/2
            do i = 1,4
               s(i,i) = s(i,i) + m
            enddo
         endif

c ...... compute the strain
         eps = cs*(ul(1,2,1)-ul(1,1,1))
         eps = eps + sn*ul(2,2,1)-ul(2,1,1)
         eps = eps/L

c .....  compute the residual
         force = E*A*L*eps
         r(1) = cs*force
         r(2) = sn*force
         r(3) = -r(1)
         r(4) = -r(2)

c .....  add the inertia effects
         m = rho*A*L/2
         r(1) = r(1) - m*ul(1,1,5)
         r(2) = r(2) - m*ul(1,2,5)
         r(3) = r(3) - m*ul(2,1,5)
         r(4) = r(4) - m*ul(2,2,5)

      elseif(isw.eq.4) then
c     output element quantities
         write(iow,1001) n,d(1),d(2),d(3),ix(1),ix(2)

1001  format(5x,'Linear 2d Truss Element'//
     1  5x,'A:      ',e12.5/5x,'E: ',e12.5/
     2  5x,'rho: ',e12.5/5x,'end1: ',i5,'end2: ',i5)

      elseif(isw.eq.5) then
c     compute element mass matrix

c        compute element length
         dx = xl(1,2) - xl(1,1)
         dy = xl(2,2) - xl(2,1)
         L = sqrt(dx*dx + dy*dy)

c ...... compute mass matrix
         A = d(1)
         rho = d(3)
         m = ctan(3)*rho*A*L/2
         do i = 1,4
            s(i,i) = m
         enddo

         r(1) = m
         r(2) = m
         r(3) = m
         r(4) = m

      elseif(isw.eq.6) then
c     compute element residual

c ...... compute element length
         dx = xl(1,2) - xl(1,1)
         dy = xl(2,2) - xl(2,1)
         L = sqrt(dx*dx + dy*dy)
         cs = dx/L
         sn = dy/L

c ...... compute the strain
         eps = cs*(ul(1,2,1)-ul(1,1,1))
         eps = eps + sn*(ul(2,2,1)-ul(2,1,1))
         eps = eps/L

c .....  compute the residual
         A = d(1)
         E = d(2)
         force = E*A*L*eps
         r(1) = cs*force
         r(2) = sn*force
         r(3) = -cs*force
         r(4) = -sn*force

c .....  add the inertia effects
         m = rho*A*L/2
         r(1) = r(1) - m*ul(1,1,5)
         r(2) = r(2) - m*ul(1,2,5)
         r(3) = r(3) - m*ul(2,1,5)
         r(4) = r(4) - m*ul(2,2,5)

      elseif(isw.eq.7) then
c     output surface loading

      elseif(isw.eq.8) then
c     compute stress projections at nodes

      endif

      end


      SUBROUTINE NNLS (A, MDA, M, N, B, X, RNORM, W, Z, INDEX, MODE)

C     C.L.LAWSON AND R.J.HANSON, JET PROPULSION LABORATORY:
C     'SOLVING LEAST SQUARES PROBLEMS'. PRENTICE-HALL.1974

C      **********   NONNEGATIVE LEAST SQUARES   **********

C     GIVEN AN M BY N MATRIX, A, AND AN M-VECTOR, B, COMPUTE AN
C     N-VECTOR, X, WHICH SOLVES THE LEAST SQUARES PROBLEM

C                  A*X = B  SUBJECT TO  X >= 0

C     A(),MDA,M,N
C            MDA IS THE FIRST DIMENSIONING PARAMETER FOR THE ARRAY,A().
C            ON ENTRY A()  CONTAINS THE M BY N MATRIX,A.
C            ON EXIT A() CONTAINS THE PRODUCT Q*A,
C            WHERE Q IS AN M BY M ORTHOGONAL MATRIX GENERATED
C            IMPLICITLY BY THIS SUBROUTINE.
C            EITHER M>=N OR M<N IS PERMISSIBLE.
C            THERE IS NO RESTRICTION ON THE RANK OF A.
C     B()    ON ENTRY B() CONTAINS THE M-VECTOR, B.
C            ON EXIT B() CONTAINS Q*B.
C     X()    ON ENTRY X() NEED NOT BE INITIALIZED.
C            ON EXIT X() WILL CONTAIN THE SOLUTION VECTOR.
C     RNORM  ON EXIT RNORM CONTAINS THE EUCLIDEAN NORM OF THE
C            RESIDUAL VECTOR.
C     W()    AN N-ARRAY OF WORKING SPACE.
C            ON EXIT W() WILL CONTAIN THE DUAL SOLUTION VECTOR.
C            W WILL SATISFY W(I)=0 FOR ALL I IN SET P
C            AND W(I)<=0 FOR ALL I IN SET Z
C     Z()    AN M-ARRAY OF WORKING SPACE.
C     INDEX()AN INTEGER WORKING ARRAY OF LENGTH AT LEAST N.
C            ON EXIT THE CONTENTS OF THIS ARRAY DEFINE THE SETS
C            P AND Z AS FOLLOWS:
C            INDEX(1)    THRU INDEX(NSETP) = SET P.
C            INDEX(IZ1)  THRU INDEX (IZ2)  = SET Z.
C            IZ1=NSETP + 1 = NPP1, IZ2=N.
C     MODE   THIS IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING MEANING:
C            1    THE SOLUTION HAS BEEN COMPUTED SUCCESSFULLY.
C            2    THE DIMENSIONS OF THE PROBLEM ARE WRONG,
C                 EITHER M <= 0 OR N <= 0.
C            3    ITERATION COUNT EXCEEDED, MORE THAN 3*N ITERATIONS.

      INTEGER          I,II,IP,ITER,ITMAX,IZ,IZMAX,IZ1,IZ2,J,JJ,JZ,
     *                 K,L,M,MDA,MODE,N,NPP1,NSETP,INDEX(N)

      DOUBLE PRECISION A(MDA,N),B(M),X(N),W(N),Z(M),ASAVE,DIFF,
     *                 FACTOR,DDOT,ZERO,ONE,WMAX,ALPHA,
     *                 C,S,T,U,V,UP,RNORM,UNORM,DNRM2

      DIFF(U,V)=       U-V

      DATA             ZERO,ONE,FACTOR/0.0D0,1.0D0,1.0D-2/

c     revised          Dieter Kraft, March 1983

      MODE=2
      IF(M.LE.0.OR.N.LE.0)            GOTO 290
      MODE=1
      ITER=0
      ITMAX=3*N

C STEP ONE (INITIALIZE)

      DO 100 I=1,N
  100    INDEX(I)=I
      IZ1=1
      IZ2=N
      NSETP=0
      NPP1=1
      X(1)=ZERO
      CALL DCOPY(N,X(1),0,X,1)

C STEP TWO (COMPUTE DUAL VARIABLES)
C .....ENTRY LOOP A

  110 IF(IZ1.GT.IZ2.OR.NSETP.GE.M)    GOTO 280
      DO 120 IZ=IZ1,IZ2
         J=INDEX(IZ)
  120    W(J)=DDOT(M-NSETP,A(NPP1,J),1,B(NPP1),1)

C STEP THREE (TEST DUAL VARIABLES)

  130 WMAX=ZERO
      DO 140 IZ=IZ1,IZ2
      J=INDEX(IZ)
         IF(W(J).LE.WMAX)             GOTO 140
         WMAX=W(J)
         IZMAX=IZ
  140 CONTINUE

C .....EXIT LOOP A

      IF(WMAX.LE.ZERO)                GOTO 280
      IZ=IZMAX
      J=INDEX(IZ)

C STEP FOUR (TEST INDEX J FOR LINEAR DEPENDENCY)

      ASAVE=A(NPP1,J)
      CALL H12(1,NPP1,NPP1+1,M,A(1,J),1,UP,Z,1,1,0)
      UNORM=DNRM2(NSETP,A(1,J),1)
      T=FACTOR*ABS(A(NPP1,J))
      IF(DIFF(UNORM+T,UNORM).LE.ZERO) GOTO 150
      CALL DCOPY(M,B,1,Z,1)
      CALL H12(2,NPP1,NPP1+1,M,A(1,J),1,UP,Z,1,1,1)
      IF(Z(NPP1)/A(NPP1,J).GT.ZERO)   GOTO 160
  150 A(NPP1,J)=ASAVE
      W(J)=ZERO
                                      GOTO 130
C STEP FIVE (ADD COLUMN)

  160 CALL DCOPY(M,Z,1,B,1)
      INDEX(IZ)=INDEX(IZ1)
      INDEX(IZ1)=J
      IZ1=IZ1+1
      NSETP=NPP1
      NPP1=NPP1+1
      DO 170 JZ=IZ1,IZ2
         JJ=INDEX(JZ)
  170    CALL H12(2,NSETP,NPP1,M,A(1,J),1,UP,A(1,JJ),1,MDA,1)
      K=MIN(NPP1,MDA)
      W(J)=ZERO
      CALL DCOPY(M-NSETP,W(J),0,A(K,J),1)

C STEP SIX (SOLVE LEAST SQUARES SUB-PROBLEM)
C .....ENTRY LOOP B

  180 DO 200 IP=NSETP,1,-1
         IF(IP.EQ.NSETP)              GOTO 190
         CALL DAXPY(IP,-Z(IP+1),A(1,JJ),1,Z,1)
  190    JJ=INDEX(IP)
  200    Z(IP)=Z(IP)/A(IP,JJ)
      ITER=ITER+1
      IF(ITER.LE.ITMAX)               GOTO 220
  210 MODE=3
                                      GOTO 280
C STEP SEVEN TO TEN (STEP LENGTH ALGORITHM)

  220 ALPHA=ONE
      JJ=0
      DO 230 IP=1,NSETP
         IF(Z(IP).GT.ZERO)            GOTO 230
         L=INDEX(IP)
         T=-X(L)/(Z(IP)-X(L))
         IF(ALPHA.LT.T)               GOTO 230
         ALPHA=T
         JJ=IP
  230 CONTINUE
      DO 240 IP=1,NSETP
         L=INDEX(IP)
  240    X(L)=(ONE-ALPHA)*X(L) + ALPHA*Z(IP)

C .....EXIT LOOP B

      IF(JJ.EQ.0)                     GOTO 110

C STEP ELEVEN (DELETE COLUMN)

      I=INDEX(JJ)
  250 X(I)=ZERO
      JJ=JJ+1
      DO 260 J=JJ,NSETP
         II=INDEX(J)
         INDEX(J-1)=II
         CALL DROTG(A(J-1,II),A(J,II),C,S)
         T=A(J-1,II)
         CALL DROT(N,A(J-1,1),MDA,A(J,1),MDA,C,S)
         A(J-1,II)=T
         A(J,II)=ZERO
  260    CALL DROT(1,B(J-1),1,B(J),1,C,S)
      NPP1=NSETP
      NSETP=NSETP-1
      IZ1=IZ1-1
      INDEX(IZ1)=I
      IF(NSETP.LE.0)                  GOTO 210
      DO 270 JJ=1,NSETP
         I=INDEX(JJ)
         IF(X(I).LE.ZERO)             GOTO 250
  270 CONTINUE
      CALL DCOPY(M,B,1,Z,1)
                                      GOTO 180
C STEP TWELVE (SOLUTION)

  280 K=MIN(NPP1,M)
      RNORM=DNRM2(M-NSETP,B(K),1)
      IF(NPP1.GT.M) THEN
         W(1)=ZERO
         CALL DCOPY(N,W(1),0,W,1)
      ENDIF

C END OF SUBROUTINE NNLS

  290 END


c************************************************
		program MODELador
c************************************************
c
c Se trata de un programa que es capaz de fabricar un fichero
c perturbado en T,Pe,H,V a partir de un modelo tau,t,pe,magfield
c definiciones
	parameter (np=50000)	!numero maximo de puntos en tau
	character nombre*20,nomin*20
	real ttau(np),tt(np),ppe(np),hh(np),MMIC(NP),VVZ(NP),
     &       GG(NP),FFI(NP)
	real tau(np),t(np),pe(np),h(np),vz(np),MIC(NP),G(NP),FI(NP)
	real xa(11),ya(11)
c	________________________________________________________________
c se abre el fichero a modificar
11	print*,'Input model?:'
	read(*,'(a)')nomin
c	print*,'se espera una linea de cabecera : Vmac,fill '
c	print*,'los datos estan dados en tau (1),o en logtau (2): '
c	read*,niflog
        niflog=2

	open(2,file=nomin)
c leemos la cabecera
	read(2,*)vmac,fill,stray

c se lee contando las lineas
	num=0
	do while (num.lt.499)
	   num=num+1
	   read(2,*,end=10,err=11)ttau(num),tt(num),ppe(num),MMIC(NUM),
     $                            hh(num),VVZ(NUM),gg(num),ffi(num)
	end do
10	num=num-1
	close(2)

	if(niflog.eq.1)then
	     do i=1,num
		ttau(i)=alog10(ttau(i))
	     end do
	end if

c Que vamos a variar?
	print*,'Do you want to modify the step in log tau (yes=1,no=0): '
	read*,nvtau
	if(nvtau.eq.0)then
	   do i=1,num
	      tau(i)=ttau(i)
	      t(i)=tt(i)
	      pe(i)=ppe(i)
	      h(i)=hh(i)
              vz(i)=vvz(i)
	      mic(i)=mmic(i)
              g(i)=gg(i)
              fi(i)=ffi(i)
	   end do
	   n=num
	else
c interpolaremos las presiones en logaritmos neperianos
	    do i=1,num
	       ppe(i)=alog(ppe(i))
	    end do

c     	print*,'paso igual a cero no equiespaciado'
    	print*,'Give the initial and the final log tau, and the step (1.2,-4,.1): '
	    read*,tau1,taun,paso
	    paso=-paso
	    if(paso.eq.0)then
	       print*,'Number of points in log tau'
	       read*,n
	       do i=1,n
		  print*,'tau numero ',i,' ='
		  read*,tau(i)
	       end do
	    else
	       n=nint((taun-tau1)/paso)+1
c definimos la red en tau
	       do i=1,n
	          tau(i)=tau1+(i-1)*paso
	       end do
	    end if
c interpolamos
	    print*,'Degree of the polynomial to be used for interpolating :'
	    read*,ngrado
c            ngrado=2
	    n2=int(ngrado/2)

	    do i=1,n
	       CALL LOCATE(TTAU,NUM,TAU(I),J)
	       n3=j-n2-1
               if(n3.lt.0)n3=0
               if(n3+ngrado+1.gt.num)n3=num-ngrado-1
	       do k=1,ngrado+1
		     xa(k)=ttau(n3+k)
	       end do
	       do k=1,ngrado+1
		     ya(k)=tt(n3+k)
	       end do
	       CALL POLINT(XA,YA,NGRADO+1,TAU(I),T(I),ERROR)
	       do k=1,ngrado+1
		     ya(k)=ppe(n3+k)
	       end do
	       CALL POLINT(XA,YA,NGRADO+1,TAU(I),pe(I),ERROR)
	       do k=1,ngrado+1
		     ya(k)=hh(n3+k)
	       end do
	       CALL POLINT(XA,YA,NGRADO+1,TAU(I),h(I),ERROR)
	       do k=1,ngrado+1
	             ya(k)=vvz(n3+k)
	       end do
	       CALL POLINT(XA,YA,NGRADO+1,TAU(I),vz(I),ERROR)
	       do k=1,ngrado+1
		     ya(k)=mmic(n3+k)
	       end do
	       CALL POLINT(XA,YA,NGRADO+1,TAU(I),mic(I),ERROR)
	       do k=1,ngrado+1
		     ya(k)=gg(n3+k)
	       end do
	       CALL POLINT(XA,YA,NGRADO+1,TAU(I),g(I),ERROR)
	       do k=1,ngrado+1
		     ya(k)=ffi(n3+k)
	       end do
	       CALL POLINT(XA,YA,NGRADO+1,TAU(I),fi(I),ERROR)
	    end do
	    do i=1,n
		pe(i)=exp(pe(i))
	    end do
	end if

        npar=-1
        do while(npar.ne.0)
	print*,'Select the physical quantity to be modified:'
	print*,'None=0,t=1,p=2,h=3,vz=4,mic=5,gamma=6,phi=7 :'
	read*,npar
        if(npar.eq.0)goto 101
c	print*,'entre que taus? (entre 1 y ',n,'=todos)'
c	read*,i1,i2
        i1=1
        i2=n
	print*,'xx=a+b*x+c*log10(tau) dame a , b ,c '
	read*,a,b,c

	do i=i1,i2
	   if(npar.eq.1)t(i)=a+b*t(i)+c*tau(i)
	   if(npar.eq.2)pe(i)=a+b*pe(i)+c*tau(i)
	   if(npar.eq.3)h(i)=a+b*h(i)+c*tau(i)
	   if(npar.eq.4)vz(i)=a+b*vz(i)+c*tau(i)
	   if(npar.eq.5)mic(i)=a+b*mic(i)+c*tau(i)
	   if(npar.eq.6)g(i)=a+b*g(i)+c*tau(i)
	   if(npar.eq.7)fi(i)=a+b*fi(i)+c*tau(i)
	end do
101     end do
c se abre el fichero en donde se escribira el modelo
	print*,'Output model? '
	read(*,'(a)')nombre
	open(1,file=nombre)

	write(1,*)vmac,fill,stray
	do i=1,n
      	    write(1,100)tau(i),t(i),pe(i),mic(i),h(i),vz(i),g(i),fi(i)
	end do
100     format(1x,f7.4,1x,f8.1,1x,1pe12.5,1x,e10.3,1x,4(e11.4,1x))

	close(1)
	end


      SUBROUTINE FORCE(ETAFCG,DIVFCG,PHIFCG)
C
C COMPUTES VORTICITY, DIVERGENCE AND GEOPOTENTIAL FORCING FOR
C TEST CASE 4 ON THE GRID
C ALTERNATIVELY, COMPUTES U/V/H-MOMENTUM FORCING
C WHICH FORCING IS DETERMINED BY LOGICAL VARIABLE MOMENT
C = .TRUE.  U/V MOMENTUM FORCING
C = .FALSE. VORTICITY/DIVERGENCE FORCING
C
C CALLED BY: COMP1
C CALLS: BUBFNC, DBUBF, D2BUBF, GLAT, GLON
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C---- Common Blocks ----------------------------------------------------
C
C CONSTANTS & TIMESTEPS
      INCLUDE 'consts.i'
C INITIAL CONDITIONS CASE 4
      INCLUDE 'finit.i'
      INCLUDE 'case4.i'
C
C------------ Arguments ------------------------------------------------
C
C     Output
C
C VORTICITY FORCING / U-MOMENTUM*COS(PHI) FORCING
      REAL ETAFCG(NLON+2,NLAT)
C DIVERGENCE FORCING / V-MOMENTUM*COS(PHI) FORCING
      REAL DIVFCG(NLON+2,NLAT)
C GEOPOTENTIAL FORCING / H-MOMENTUM*G FORCING
      REAL PHIFCG(NLON+2,NLAT)
C
C------ Local Variables ------------------------------------------------
C
C      LOCAL VARIABLES REQUIRED TO EFFICIENTLY COMPUTE FORCING:  A LOT
C      OF SPACE HERE, BUT NECESSARY FOR TRACTABLE AND DEBUGGABLE PROBLEM
C
      REAL BUB, DBUB, D2BUB
      REAL C     (NLON), PSIB  (NLON)
      REAL DCDM  (NLON), DCDL  (NLON),
     $     D2CDM (NLON), D2CDL (NLON),
     $     D3CDM (NLON), D3CDL (NLON),
     $     DMDCDL(NLON), DMD2CL(NLON),
     $     DKDM  (NLON), DKDL  (NLON),
     $     D2KDM (NLON), D2KDL (NLON),
     $     D3KDM (NLON), D3KDL (NLON),
     $     DLDKDM(NLON), DLD2KM(NLON),
     $     DMD2KL(NLON), DLD2CM(NLON)
      REAL TMP1  (NLON), TMP2  (NLON), TMP3  (NLON),
     $     UT    (NLON), VT    (NLON),
     $     DUTDL (NLON), DUTDM (NLON),
     $     DVTDL (NLON), DVTDM (NLON)
C
C     TEMPORARIES
C
      INTEGER I,J
      REAL TMSHFT, DFDM, AI, A2I, RLAT, SNJ, CSJ, COR, SRCSJ,
     $     TMPRY, CSJI, CSJ2I, ACSJI, AACSJI, ACSJ2I, RLON
C
C----- External Functions ----------------------------------------------
C
C     ZONAL FLOW FUNCTIONS AND DERIVATIVES
C
      EXTERNAL BUBFNC, DBUBF, D2BUBF
      REAL BUBFNC, DBUBF, D2BUBF
C
C     SPATIAL LAT./LONG. GRID
C
      EXTERNAL GLAT, GLON
      REAL GLAT, GLON
C
C----- Executable Statements -------------------------------------------
C
      TMSHFT = SU0*REAL(NSTEP-1)*DT/A
      DFDM   = 2.0*OMEGA
      AI    = 1.0/A
      A2I   = 1.0/(A*A)
C
      DO 510 J=1,NLAT
         RLAT = GLAT(J)
C
C        LATITUDE = RLAT = GLAT(J)
C
         SNJ  = SIN(RLAT)
         CSJ  = COS(RLAT)*COS(RLAT)
C
C        STEADY ZONAL FLOW BUB AND ITS TWO DERIVATIVES
C
         BUB    = BUBFNC(RLAT)*COS(RLAT)
         DBUB   = DBUBF(RLAT)
         D2BUB  = D2BUBF(RLAT)
C
C        CORIOLIS PARAMETER
C
         COR    = 2.0*OMEGA*SNJ
C
C        LONGITUDE INDEPENDENT FACTORS
C
         SRCSJ  = COS(RLAT)
         TMPRY  = TAN(RLAT)
C        TMPRY2 = TMPRY*TMPRY
         CSJI   = 1.0/CSJ
         CSJ2I  = 1.0/(CSJ**2)
         ACSJI  = 1.0/(A*CSJ)
         AACSJI = 1.0/(A*A*CSJ)
         ACSJ2I = 1.0/((A*CSJ)**2)
C
         DO 100 I=1,NLON
            RLON = GLON(I)
C
C           LONGITUDE = RLON = GLON(I)
C           LATITUDE = RLAT = GLAT(J)
C
C           CALCULATE C AND ALL OF ITS DERIVATIVES FOR THIS TIME STEP
C
C (A.28)
            C(I)      = SIN(RLAT0)*SNJ + COS(RLAT0)*SRCSJ
     $                                     *COS(RLON-TMSHFT-RLON0)
C (A.38)
            DCDM(I)   = SIN(RLAT0) - COS(RLON-TMSHFT-RLON0)*
     $                      COS(RLAT0)*TMPRY
C (A.39)
            DCDL(I)   = -COS(RLAT0)*SRCSJ*SIN(RLON-TMSHFT-RLON0)
C (A.40)
C SIMPLIFIED TERM
            D2CDM(I)  = -COS(RLAT0)*COS(RLON-TMSHFT-RLON0)*
     $                      CSJI/SRCSJ
C (A.41)
            D2CDL(I)  = -COS(RLAT0)*SRCSJ*COS(RLON-TMSHFT-RLON0)
C (A.42)
C SIMPLIFIED TERM
            D3CDM(I)  = D2CDM(I)*3.0*SNJ*CSJI
C
C (A.43)
            D3CDL(I)  = -DCDL(I)
C (A.44)
            DMDCDL(I) = +COS(RLAT0)*SIN(RLON-TMSHFT-RLON0)*TMPRY
C (A.45)
            DLD2CM(I) = +COS(RLAT0)*SIN(RLON-TMSHFT-RLON0)*
     $                       CSJI/SRCSJ
C (A.46)
            DMD2CL(I) = +COS(RLAT0)*COS(RLON-TMSHFT-RLON0)*TMPRY
  100    CONTINUE
C
C     CALCULATE PSI BAR AND ALL OF ITS DERIVATIVES (DKDM, ETC.)
C
         DO 120 I=1,NLON
C (A.27)
            PSIB(I)   = ALFA*EXP(-SIGMA*((1.0-C(I))/(1.0+C(I))))
            TMP1(I)   = 2.0*SIGMA*PSIB(I)/((1.0 + C(I))**2)
            TMP2(I)   = (SIGMA - (1.0 + C(I)))/((1.0 + C(I))**2)
            TMP3(I)   = (((1.0+C(I))**2)-2.0*SIGMA*(1.0+C(I)))
     $                      /((1.0 + C(I))**4)
C (A.29)
            DKDM(I)   = TMP1(I)*DCDM(I)
C (A.30)
            DKDL(I)   = TMP1(I)*DCDL(I)
C (A.31)
            D2KDM(I)  = TMP1(I)*(D2CDM(I) + 2.0*(DCDM(I)**2)
     $                    *TMP2(I))
C (A.32)
            D2KDL(I)  = TMP1(I)*(D2CDL(I) + 2.0*(DCDL(I)**2)
     $                    *TMP2(I))
C (A.33)
            D3KDM(I)  = TMP1(I)*(D3CDM(I) + 2.0*(DCDM(I)**3)
     $                    *TMP3(I) + 2.0*DCDM(I)*TMP2(I)*(3.0
     $                    *D2CDM(I) + 2.0*(DCDM(I)**2)*TMP2(I)))
C (A.34)
            D3KDL(I)  = TMP1(I)*(D3CDL(I) + 2.0*(DCDL(I)**3)
     $                    *TMP3(I) + 2.0*DCDL(I)*TMP2(I)*(3.0
     $                    *D2CDL(I) + 2.0*(DCDL(I)**2)*TMP2(I)))
C (A.35)
            DLDKDM(I) = TMP1(I)*(DMDCDL(I) + 2.0*DCDL(I)
     $                    *DCDM(I)*TMP2(I))
C (A.37)
            DMD2KL(I) = TMP1(I)*(DMD2CL(I) + 2.0*(DCDL(I)**2)
     $                    *DCDM(I)*TMP3(I) + 2.0*DCDM(I)*TMP2(I)
     $                    *(D2CDL(I) + 2.0*(DCDL(I)**2)*TMP2(I))
     $                    + 4.0*DCDL(I)*DMDCDL(I)*TMP2(I))
C (A.36)
            DLD2KM(I) = TMP1(I)*(DLD2CM(I) + 2.0*(DCDM(I)**2)
     $                    *DCDL(I)*TMP3(I) + 2.0*DCDL(I)*TMP2(I)
     $                    *(D2CDM(I) + 2.0*(DCDM(I)**2)*TMP2(I))
     $                    + 4.0*DCDM(I)*DMDCDL(I)*TMP2(I))
  120    CONTINUE
C
C     COMPUTE COMMONLY UTILIZED TERMS IN FORCING (U AND V TILDE)
C
         DO 160 I=1,NLON
            UT(I)    = BUB - CSJ*DKDM(I)*AI
            VT(I)    = DKDL(I)*AI
            DUTDL(I) = -CSJ*DLDKDM(I)*AI
            DVTDL(I) = D2KDL(I)*AI
            DUTDM(I) = DBUB - (CSJ*D2KDM(I) - 2.0*SNJ*DKDM(I))*AI
            DVTDM(I) = DLDKDM(I)*AI
  160    CONTINUE
C
C     COMPUTE FORCING TERMS
C
         DO 500 I=1,NLON
C
            IF (MOMENT) THEN
C
C           U-MOMENTUM FORCING
C
            TMP1(I) = (CSJ*SU0)/(A*A)*DLDKDM(I)
            TMP1(I) = TMP1(I) + UT(I)*ACSJI*DUTDL(I)
            TMP1(I) = TMP1(I) + VT(I)*AI*DUTDM(I)
C
            ETAFCG(I,J) = TMP1(I) + COR*(AI*DKDL(I)-VT(I))
C
            ELSE
C
C           FORCING ON VORTICITY EQUATION
C           COMPUTE LAMBDA DERIVATIVE 1ST (CAN BE USED FOR TIME DRVTVE)
C
C (A.16,A.17)
            TMP1(I)     = D3KDL(I)*AACSJI + (CSJ*DLD2KM(I)
     $                    - 2.0*SNJ*DLDKDM(I))*A2I
            ETAFCG(I,J) = (UT(I)*ACSJI - (SU0*AI))*TMP1(I)
C (A.18)
            TMP2(I)     = (DMD2KL(I)*CSJI + 2.0*SNJ
     $                    *D2KDL(I)*CSJ2I + CSJ*D3KDM(I)
     $                    - 4.0*SNJ*D2KDM(I) - 2.0*DKDM(I))*A2I
     $                    + DFDM - D2BUB*AI
C (A.13)
            ETAFCG(I,J) = ETAFCG(I,J) + TMP2(I)*VT(I)*AI
            ENDIF
C
C           COMPUTE FORCING ON GEOPOTENTIAL EQUATION
C
C (A.25)
            TMP3(I)     = COR*DKDL(I)
            PHIFCG(I,J) = -SU0*AI*TMP3(I) + UT(I)*TMP3(I)*ACSJI
            PHIFCG(I,J) = PHIFCG(I,J) + AI*VT(I)*(PSIB(I)*DFDM+
     $                    COR*DKDM(I))
C
C     ADD TERM TO BALANCE ZONAL FLOW
C
            PHIFCG(I,J) = PHIFCG(I,J) - VT(I)*BUB*CSJI*
     $                    (COR + BUB*ACSJI*SNJ)
C
            IF (MOMENT) THEN
C
C           V-MOMENTUM FORCING
C
            TMP3(I) = - SU0*A2I*D2KDL(I)
            TMP3(I) = TMP3(I) + UT(I)*ACSJI*DVTDL(I)
            TMP3(I) = TMP3(I) + VT(I)*AI*DVTDM(I)
            TMP3(I) = TMP3(I) + (UT(I)*UT(I)+VT(I)*VT(I))*
     $                SNJ*ACSJI
C
            DIVFCG(I,J) = TMP3(I) + CSJ*AI*(COR*DKDM(I)+
     $                  PSIB(I)*DFDM)
            DIVFCG(I,J) = DIVFCG(I,J) + COR*(UT(I)-BUB) -
     $                  ACSJI*SNJ*BUB*BUB
C
            ELSE
C
C           COMPUTE FORCING ON DIVERGENCE EQUATION (MOST MESSY!)
C           LAPLACIAN OF PHI FIRST
C
C (A.19)
            DIVFCG(I,J) = COR*D2KDL(I)*AACSJI + ( CSJ*
     $                    (COR*D2KDM(I) + 2.0*DFDM*DKDM(I)) - 2.0
     $                    * SNJ*(PSIB(I)*DFDM + COR*DKDM(I)))*A2I
C
C           CALCULATE ETA-F NEXT
C
            TMP3(I)     = ACSJI*DVTDL(I)-AI*DUTDM(I)
C
            DIVFCG(I,J) = DIVFCG(I,J) - TMP3(I)*COR + UT(I)*AI*DFDM
C
C           FINALLY, ADD LAPLACIAN OF U**2/(2*CSJ) AND V**2/(2*CSJ)
C
            DIVFCG(I,J) = DIVFCG(I,J) + 2.0*SNJ*AACSJI*(
     $                    UT(I)*CSJI*DVTDL(I) - VT(I)*CSJI*DUTDL(I)
     $                    + UT(I)*DUTDM(I) + VT(I)*DVTDM(I) )
C
            DIVFCG(I,J) = DIVFCG(I,J) + 2.0*AACSJI*(
     $                    DUTDM(I)*DVTDL(I) - DUTDL(I)*DVTDM(I) )
C
            DIVFCG(I,J) = DIVFCG(I,J) + (UT(I)*UT(I)+VT(I)*VT(I))
     $                    *(1.0+SNJ*SNJ)*ACSJ2I
C
C     ADD TERM TO BALANCE ZONAL FLOW
C
            DIVFCG(I,J) = DIVFCG(I,J) - COR*AI*DBUB - BUB*AI*DFDM -
     $                    ACSJ2I*(BUB*BUB*(1+SNJ*SNJ)+
     $                    2.0*SNJ*CSJ*BUB*DBUB)
C
            ENDIF
C
  500    CONTINUE
  510 CONTINUE
C
      RETURN
      END


*     SB04PD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 20, NMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDU, LDV
      PARAMETER        ( LDA = MMAX, LDB = NMAX, LDC = MMAX,
     $                   LDU = MMAX, LDV = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 1 + 2*MMAX + MAX( 3*MMAX, 5*NMAX,
     $                                            2*( NMAX + MMAX ) ) )
*     .. Local Scalars ..
      CHARACTER        DICO, FACTA, FACTB, TRANA, TRANB
      INTEGER          I, INFO, ISGN, J, M, N
      DOUBLE PRECISION SCALE
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,MMAX), B(LDB,NMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), U(LDU,MMAX), V(LDV,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB04PD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, ISGN, DICO, FACTA, FACTB, TRANA, TRANB
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) M
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,M ), I = 1,M )
         IF ( LSAME( FACTA, 'F' ) )
     $      READ ( NIN, FMT = * ) ( ( U(I,J), J = 1,M ), I = 1,M )
         IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) N
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N )
            IF ( LSAME( FACTB, 'F' ) )
     $         READ ( NIN, FMT = * ) ( ( V(I,J), J = 1,N ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,M )
*           Find the solution matrix X.
            CALL SB04PD( DICO, FACTA, FACTB, TRANA, TRANB, ISGN, M, N,
     $                   A, LDA, U, LDU, B, LDB, V, LDV, C, LDC, SCALE,
     $                   DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 )
     $         WRITE ( NOUT, FMT = 99998 ) INFO
            IF ( INFO.EQ.0 .OR. INFO.EQ.M+N+1 ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 1, M
                  WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,N )
   20          CONTINUE
               WRITE ( NOUT, FMT = 99995 ) SCALE
               IF ( LSAME( FACTA, 'N' ) ) THEN
                  WRITE ( NOUT, FMT = 99994 )
                  DO 40 I = 1, M
                     WRITE ( NOUT, FMT = 99996 ) ( U(I,J), J = 1,M )
   40             CONTINUE
               END IF
               IF ( LSAME( FACTB, 'N' ) ) THEN
                  WRITE ( NOUT, FMT = 99993 )
                  DO 60 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( V(I,J), J = 1,N )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB04PD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB04PD = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' Scaling factor = ',F8.4)
99994 FORMAT (/' The orthogonal matrix U is ')
99993 FORMAT (/' The orthogonal matrix V is ')
99992 FORMAT (/' M is out of range.',/' M = ',I5)
99991 FORMAT (/' N is out of range.',/' N = ',I5)
      END


C --- Plain QSSA with fixed step size
C
      SUBROUTINE INTEGRATE( TIN, TOUT  )

      INCLUDE 'KPP_ROOT_params.h'
      INCLUDE 'KPP_ROOT_global.h'

C TIN - Start Time
      KPP_REAL TIN
C TOUT - End Time
      KPP_REAL TOUT

C Local variables
      KPP_REAL P_VAR(NVAR), D_VAR(NVAR)
      LOGICAL IsReject
      KPP_REAL T, Tnext, STEP, Told, SUP
      KPP_REAL ratio, tmp
      INTEGER i

      T = TIN
      Tnext = TOUT
      STEP = 0.1
      Told = T
      SUP  = 1e-14
      IsReject = .false.

C -- BELOW THIS LIMIT USE TAYLOR INSTEAD OF EXP ---

      do while ( T.lt.Tnext )

        if ( T.gt.Tnext ) then
          STEP = Tnext - Told
          T = Tnext
        end if

        CALL FSPLIT_VAR ( VAR,  P_VAR, D_VAR )

        do i=1,NVAR
          if ( abs(D_VAR(i)).gt.SUP ) then
            ratio = P_VAR(i)/D_VAR(i)
            tmp = exp(-D_VAR(i)*STEP)
            VAR(i) = tmp * (VAR(i) - ratio) + ratio
          else
            tmp = D_VAR(i) * STEP
            VAR(i) = VAR(i) + P_VAR(i) * 0.5 * STEP * ( 1 - 0.5 * tmp *
     *             ( 1 - 1.0 / 3.0 * tmp ) )
          end if
        end do

        T = T + STEP
        TIME = T

      end do

      RETURN
      END


C **********************************************************************
C J2 Mises Plasticity with isotropic Johnson-Cook hardening for plane
C strain case and 3D case.
C **********************************************************************

      include 'JohnsonCook.f'

C **********************************************************************
C VUHARD subroutine core
C **********************************************************************
      subroutine vuhard (
C Read only -
     1     nblock,
     2     nElement, nIntPt, nLayer, nSecPt,
     3     lAnneal, stepTime, totalTime, dt, cmname,
     4     nstatev, nfieldv, nprops,
     5     props, tempOld, tempNew, fieldOld, fieldNew,
     6     stateOld,
     7     eqps, eqpsRate,
C Write only -
     8     yield, dyieldDtemp, dyieldDeqps,
     9     stateNew )
C
      include 'vaba_param.inc'
C
      dimension nElement(nblock),
     1     props(nprops),
     2     tempOld(nblock),
     3     fieldOld(nblock,nfieldv),
     4     stateOld(nblock,nstatev),
     5     tempNew(nblock),
     6     fieldNew(nblock,nfieldv),
     7     eqps(nblock),
     8     eqpsRate(nblock),
     9     yield(nblock),
     1     dyieldDtemp(nblock),
     2     dyieldDeqps(nblock,2),
     3     stateNew(nblock,nstatev)
C
      character*80 cmname
C
C **********************************************************************
C Start of the subroutine grab the parameters of the constitutive law
C **********************************************************************
      parA      = props(1)
      parB      = props(2)
      parn      = props(3)
      parC      = props(4)
      parm      = props(5)
      pardepsp0 = props(6)
      parT0     = props(7)
      parTm     = props(8)
C
C **********************************************************************
C Main computation block
C **********************************************************************
      do k = 1, nblock
        epsp = eqps(k)
        depsp = eqpsRate(k)
        temp = tempNew(k)
C Compute the yield stress
        Yield(k) = yieldStress(epsp, depsp, temp,
     1    parA, parB, parC, parn, parm, pardepsp0, parT0, parTm)
C Compute derivative of yield / epsp
        dyieldDeqps(k,1) = yieldHardEpsp(epsp, depsp, temp,
     1    parA, parB, parC, parn, parm, pardepsp0, parT0, parTm)
C Compute derivative of yield / depsp
        dyieldDeqps(k,2) = yieldHardDepsp(epsp, depsp, temp,
     1    parA, parB, parC, parn, parm, pardepsp0, parT0, parTm)
C Compute derivative of yield / temp
        dyieldDtemp(k) = yieldHardTemp(epsp, depsp, temp,
     1    parA, parB, parC, parn, parm, pardepsp0, parT0, parTm)
      end do
C
      return
      end


      SUBROUTINE SIMCONF(D,K,H,L,R,B0,BX0,S0,Q0,BC,BD,G,AVY,SI,S2)
C
      INCLUDE 'timsac_f.h'
C
cc      PROGRAM SIMCON
C     PROGRAM 74.3.2.  OPTIMAL CONTROLLER DESIGN AND SIMULATION
C-----------------------------------------------------------------------
C     ** DESIGNED BY H. AKAIKE, THE INSTITUTE OF STATISTICAL MATHEMATICS
C     ** PROGRAMMED BY E. ARAHATA, THE INSTITUTE OF STATISTICAL MATHEMAT
C         TOKYO
C     ** DATE OF THE LATEST REVISION: MARCH 25, 1977
C     ** THIS PROGRAM WAS ORIGINALLY PUBLISHED IN
C        "TIMSAC-74 A TIME SERIES ANALYSIS AND CONTROL PROGRAM PACKAGE(2
C        BY H. AKAIKE, E. ARAHATA AND T. OZAKI, COMPUTER SCIENCE MONOGRA
C        NO.6 MARCH 1976, THE INSTITUTE OF STATISTICAL MATHEMATICS
C-----------------------------------------------------------------------
C     THIS PROGRAM PRODUCES OPTIMAL CONTROLLER GAIN AND SIMULATES THE
C     CONTROLLED PROCESS. THE BASIC STATE SPACE MODEL IS OBTAINED
C     FROM THE AUTOREGRESSIVE MOVING AVERAGE MODEL OF A VECTOR
C     PROCESS Y(I); Y(I)+B(1)Y(I-1)+..+B(K)Y(I-K)=X(I)+A(1)X(I-1)+..
C     ..+A(K-1)X(I-K+1).
C
C     THE FOLLOWING INPUTS ARE REQUIRED:
C      THE OUTPUTS OF PROGRAM MARKOV:
C       (D,K): INTEGERS
C             D, DIMENSION OF Y(I) (LESS THAN OR EQUAL TO MJD)
C             K, ORDER OF THE PROCESS (LESS THAN OR EQUAL TO MJK)
C       (B(I),I=1,K): MATRICES OF AUTOREGRESSIVE COEFFICIENTS
C       (W(I),I=1,K-1): IMPULSE RESPONCE MATRICES OF THE VECTOR VARIABLE
C                       Y(I) TO THE INNOVATION INPUT
C      S: D*D COVARIANCE MATRIX OF INNOVATION X(I)
C      (H,L,R): INTEGERS
C              H, SPAN OF CONTROL PERFORMANCE EVALUATION
C              L, LENGTH OF EXPERIMENTAL OBSERVATION
C              R, DIMENSION OF CONTROL INPUT (LESS THAN OR EQUAL TO D)
C                 THE LAST R COMPONENTS OF Y(I) REPRESENT THE CONTROL IN
C                 AND THE REST REPRESENT THE OUTPUT OF THE SYSTEM.
C      QX: WEIGHTING MATRIX OF PERFORMANCE, POSITIVE DEFINITE
C
C     BASIC EQUATION OF THE SYSTEM IS AS FOLLOWS;
C     V(I+1)=A*V(I)+BD*SI(I)+BC*CI(I+1): STATE VECTOR
C     CI(I+1)=G*V(I)                   : CONTROLLER INPUT
C     Y(I)=C*V(I)                      : OBSERVED OUTPUT
C     WHERE        +-                              -+
C              A = I     0       I       0 ..     0 I ,
C                  I     0       0       I ..     0 I
C                  I     .       .       . ..     . I
C                  I -B(K) -B(K-1) -B(K-2) .. -B(1) I
C                  +-                              -+
C
C                  +-                -+
C              C = I   I 0 0 ... 0    I,
C                  +-                -+
C
C              +-     -+     +-       -+
C              I       I     I  I      I
C              I       I     I  W(1)   I
C              I BD BC I  =  I  W(2)   I  =  BX,
C              I       I     I   .     I
C              I       I     I  W(K-1) I
C              +-     -+     +-       -+
C
C              G = INVERSE(-(BC'*Q(H)*BC))*BC'*Q(H)*A,
C              Z(I+1) = Q(I)-Q(I)*BC*INVERSE(BC'*Q(I)*BC)*BC'*Q(I) (I=0,
C              Q(I+1) = A'*Z(I+1)*A+Q(0) (I=0,H-1),
C                     +-       -+
C              Q(0) = I QX 0..0 I
C                     I  0 0..0 I
C                     I  0 0..0 I
C                     I  . ...0 I
C                     I  0 0..0 I
C                     +-       -+
C              SI(I)= OUTPUT (FIRST D-R COMPONENTS OF Y(I)) INNOVATION.
C     B(I)(I=1,K) ARE THE AUTOREGRESSIVE COEFFICIENTS OF THE AR-MA
C     REPRESENTATION OF Y(I).
C     W(J)(J=0,K-1)(W(0)=I) ARE THE IMPULSE RESPONSE MATRICES OF Y(I+J)
C     THE INNOVATION X(I).
C     BY MODIFYING THE INPUT LOADING PROGRAM, Q(0) MAY BE PUT EQUAL TO A
C     ARBITRARY KD*KD POSITIVE DEFINITE MATRIX.
C     THE DIMENSIONS OF THE MATRICES ARE AS FOLLOWES:
C     A:  (K*D)*(K*D) MATRIX
C     B:  D*D         MATRIX
C     BD: (K*D)*(D-R) MATRIX
C     BC: (K*D)*R     MATRIX
C     W:  D*D         MATRIX
C     Q:  (K*D)*(K*D) MATRIX
C     QX: D*D         MATRIX
C     Z:  (K*D)*(K*D) MATRIX
C     G:  R*(K*D)     MATRIX
C     S:  D*D         MATRIX
C     V:  (K*D)*1     VECTOR
C     SI: (D-R)*1     VECTOR
C     CI: R*1         VECTOR
C     Y:  D*1         VECTOR
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: SIMCONF
C
cxx      IMPLICIT REAL*8 (A-H,O-Z)
cc      REAL*4 RANDOM
cxx      REAL*8 RANDM
cxx      INTEGER D,H,R,H1
cc      DIMENSION B(10,10,10),BD(100,10),BC(100,10)
cc      DIMENSION Q(100,100),Q0(100,100),Z(100,100),G(10,100)
cc      DIMENSION W1(10)
cc      DIMENSION S(10,10),WIN(10,10),Y(10,1000),W2(100,100)
cc      DIMENSION SI(10),CI(10),V(100),AV(100),BCN(100),BDN(100)
cc      DIMENSION W3(10,10),W4(10,10),S2(10)
cc      DIMENSION R1(10,100),R3(10,100)
cc      DIMENSION BX(100,10)
cxx      DIMENSION B0(D,D,K),B(D,D,K),BD(K*D,D-R),BC(K*D,R)
cxx      DIMENSION Q(K*D,K*D),Q0(D,D),Z(K*D,K*D),G(R,K*D)
cxx      DIMENSION W1(D)
cxx      DIMENSION S0(D,D),S(D-R,D-R)
cxx      DIMENSION WIN1(D,D),WIN2(R,D),Y(D,L),W2(K*D,K*D)
cxx      DIMENSION SI(D),CI(R),V(K*D),AV(K*D),AVY(D),BCN(K*D),BDN(K*D)
cxx      DIMENSION W31(R,R),W32(D,D),W41(D,D),W42(R,D),S2(D)
cxx      DIMENSION R1(R,K*D),R3(R,K*D)
cxx      DIMENSION BX0((K-1)*D,D),BX(K*D,D)
      INTEGER :: D, K, H, L, R
      REAL(8) :: B0(D,D,K), BX0((K-1)*D,D), S0(D,D), Q0(D,D), BC(K*D,R),
     1           BD(K*D,D-R), G(R,K*D), AVY(D), SI(D), S2(D)
      INTEGER H1
      REAL(8) :: RANDM, B(D,D,K), Q(K*D,K*D),Z(K*D,K*D), W1(D),
     1           S(D-R,D-R), WIN1(D,D), WIN2(R,D), Y(D,L),
     2           W2(K*D,K*D), CI(R), V(K*D), AV(K*D), BCN(K*D),
     3           BDN(K*D), W31(R,R), W32(D,D), W41(D,D), W42(R,D),
     4           R1(R,K*D), R3(R,K*D), BX(K*D,D), CST0, CST1, CSTM6,
     5           BDMN, AL, SUM, WDET
cc      EQUIVALENCE(Q0(1,1),BCN(1))
cc      EQUIVALENCE(WIN(1,1),W1(1),SI(1),CI(1))
cc      EQUIVALENCE(V(1),S2(1))
cc      EQUIVALENCE(Q(1,1),Z(1,1),Y(1,1))
cc      EQUIVALENCE (R1(1,1),G(1,1))
cc      EQUIVALENCE(BX(1,1),R3(1,1),AV(1))
cc      DATA B/1000*0.0D-00/,BC/1000*0.0D-00/,BD/1000*0.0D-00/
cc      DATA Q0/10000*0.0D-00/,Q/10000*0.0D-00/,Z/10000*0.0D-00/
cc      DATA S/100*0.0D-00/,SI/10*0.0D-00/,CI/10*0.0D-00/
cc      DATA W1/10*0.0D-00/,W2/10000*0.0D-00/
cc      DATA R1/1000*0.0D-00/
cc      DATA BX/1000*0.0D-00/,WIN/100*0.0D-00/,W3/100*0.0D-00/
C     ABSOLUTE DIMENSIONS
cc      MJD=10
cc      MJK=10
cc      MJKD=MJK*MJD
C
C     INPUT / OUTPUT DATA FILE OPEN
cc	CALL SETWND
cc	CALL FLOPN2(NFL)
cc	IF (NFL.EQ.0) GO TO 999
C
C     INITIAL CONDITION INPUT
cc      READ(5,800) D,K
cc      WRITE(6,900)
      KD=K*D
      KX=KD-D
C     AR-COEFFICIENT MATRICES B(I)(I=1,K) INPUT
      ISW=1
      DO  107 IX=1,K
C     COMMON SUBROUTINE CALL
cc      CALL REMATX(WIN,D,D,ISW,MJD,MJD)
      DO  106 I=1,D
      DO  105 J=1,D
cc  105 B(I,J,IX)=-WIN(I,J)
cxx  105 B(I,J,IX)=-B0(I,J,IX)
      B(I,J,IX)=-B0(I,J,IX)
  105 CONTINUE
  106 CONTINUE
  107 CONTINUE
C
      CST0=0.0D-00
      CST1=1.0D-00
      CSTM6=-6.0D-00
c
c     initialize data area
      CALL DINIT(Q,KD*KD,CST0)
      CALL DINIT(Z,KD*KD,CST0)
      CALL DINIT(SI,D,CST0)
      CALL DINIT(CI,R,CST0)
      CALL DINIT(W1,D,CST0)
      CALL DINIT(W2,KD*KD,CST0)
      CALL DINIT(R1,R*KD,CST0)
      CALL DINIT(WIN1,D*D,CST0)
      CALL DINIT(WIN2,R*D,CST0)
      CALL DINIT(W31,R*R,CST0)
      CALL DINIT(W32,D*D,CST0)
      CALL DINIT(BX,KD*D,CST0)
c
C     MATRIX BX SET
      K1=K-1
      K2=K1*D
      DO 102 I=1,D
cxx  102 BX(I,I)=CST1
      BX(I,I)=CST1
  102 CONTINUE
C
C     IMPULSE RESPONSE MATRICES W(I),I=1,K-1 INPUT
cc      I1=0
cc      DO  117 IX=1,K1
C     COMMON SUBROUTINE CALL
C     MATRIX INPUT, ROWWISE
cc      CALL REMATX (WIN,D,D,ISW,MJD,MJD)
cc      I1=I1+D
cc      DO  116 I=1,D
cc      I2=I1+I
cc      DO 115 J=1,D
cc  115 BX(I2,J)=WIN(I,J)
cc  116 CONTINUE
cc  117 CONTINUE
cxx      DO 116 I=1,(K-1)*D
      DO 126 I=1,(K-1)*D
      DO 116 J=1,D
         BX(I+D,J)=BX0(I,J)
  116 CONTINUE
  126 CONTINUE

C
C     INNOVATION COVARIANCE MATRIX INPUT
C     COMMON SUBROUTINE CALL
cc      CALL REMATX (S,D,D,ISW,MJD,MJD)
cxx      DO 117 I=1,D-R
      DO 127 I=1,D-R
      DO 117 J=1,D-R
         S(I,J)=S0(I,J)
  117 CONTINUE
  127 CONTINUE
cc      READ (5,800) H,L,R
cc      WRITE(6,901) D,K,H,L,R
C     MATRIX Q(0) SET UP
C     COMMON SUBROUTINE CALL
C     FOR A GENERAL Q(0) REPLACE THE FOLLWING STATEMENT 108-109 BY
C     CALL REMATX(Q0,KD,KD,ISW,MJKD,MJKD)
cc  108 CALL REMATX(W3,D,D,ISW,MJD,MJD)
C
C
cc      DO  109  I=1,D
cc      DO  118  J=1,D
cc  118 Q0(I,J)=W3(I,J)
cc  109 CONTINUE
cc      DO 119 I=1,KD
cc      DO 119 J=1,KD
cxx      DO 119 I=1,D
      DO 120 I=1,D
      DO 119 J=1,D
cxx  119 Q(I,J)=Q0(I,J)
      Q(I,J)=Q0(I,J)
  119 CONTINUE
  120 CONTINUE
C
C     MATRIX BC AND BD SET UP
      KDR=D-R
      DO 1120 I=1,KD
      DO 1119 J=1,KDR
cxx 1119 BD(I,J)=BX(I,J)
      BD(I,J)=BX(I,J)
 1119 CONTINUE
 1120 CONTINUE
      DO 1122 I=1,KD
      DO 1121 J=1,R
      J1=KDR+J
cxx 1121 BC(I,J)=BX(I,J1)
      BC(I,J)=BX(I,J1)
 1121 CONTINUE
 1122 CONTINUE
C
C     INITIAL MATRIX PRINT OUT FOR DEBUGGING
cc      DO  707 IX=1,K
cc      DO  708 I=1,D
cc      DO  709 J=1,D
cc  709 WIN(I,J)=-B(I,J,IX)
cc  708 CONTINUE
cc      WRITE (6,700) IX
cc      CALL SUBMPR (WIN,D,D,MJD,MJD)
cc  707 CONTINUE
cc      WRITE(6,702)
cc      CALL SUBMPR (BC,KD,R,MJKD,MJD)
cc      WRITE(6,703)
cc      CALL SUBMPR (BD,KD,KDR,MJKD,MJD)
cc      WRITE(6,704)
cc      CALL SUBMPR(W3,D,D,MJD,MJD)
cc      WRITE(6,706)
cc      CALL SUBMPR(S,D,D,MJD,MJD)
C     INITIAL PRINT FOR DEBUGGING END
C     ITERATIVE COMPUTATION OF G
      H1=H+1
      DO 200 IX=1,H1
C     R1=BC'*Q R1 STORE
cc      CALL MULTRX(BC,KD,R,MJKD,MJD,Q,KD,KD,MJKD,MJKD,R1,R,KD,MJD,MJKD,2)
      CALL MULTRX(BC,KD,R,Q,KD,KD,R1,R,KD,2)
C     W3=R1*BC
cc      CALL MULTRX(R1,R,KD,MJD,MJKD,BC,KD,R,MJKD,MJD,W3,R,R,MJD,MJD,1)
      CALL MULTRX(R1,R,KD,BC,KD,R,W31,R,R,1)
C     W3=(INVERSE OF W3)
cc      CALL INVDET(W3,WDET,R,MJD)
      CALL INVDETS(W31,WDET,R)
C     R3=W3*R1 R3 STORE
cc      CALL MULTRX(W3,R,R,MJD,MJD,R1,R,KD,MJD,MJKD,R3,R,KD,MJD,MJKD,1)
      CALL MULTRX(W31,R,R,R1,R,KD,R3,R,KD,1)
      IF(IX.EQ.H1) GO TO 210
C     W2=R1'*R3
cc      CALL MULTRX(R1,R,KD,MJD,MJKD,R3,R,KD,MJD,MJKD,W2,KD,KD,MJKD,MJKD,2
cc     A)
      CALL MULTRX(R1,R,KD,R3,R,KD,W2,KD,KD,2)
C     Z=Q-W2
cc      CALL SUBTAC(Q,W2,Z,KD,KD,MJKD,MJKD)
      CALL SUBTAC(Q,W2,Z,KD,KD)
C
C     W2=A'*Z COMPUTATION:
C
C     +-                               -+     +-
C     I     0  0  0  0  ..  0 -B(K)'    I     I     Z(1,1) .. Z(1,K)
C     I     I  0  0  0  ..  0 -B(K-1)'  I     I      .          .
C     I     0  I  0  0  ..  0 -B(K-2)'  I     I      .          .
C     I     0  0  I  0  ..  0 -B(K-3)'  I  *  I      .          .
C     I     0  0  0  I  ..  0 -B(K-4)'  I     I      .          .
C     I     .  .  .  .  ..  .    .      I     I      .          .
C     I     0  0  0  0  ..  I -B(1)'    I     I     Z(K,1) .. Z(K,K)
C     +-                               -+     +-
C
C         +-                                                    -+
C         I   -B(K)'Z(K,1)          .... -B(K)'Z(K,K)            I
C         I   -B(K-1)'Z(K,1)+Z(1,1) .... -B(K-1)'Z(K,K)+Z(1,K)   I
C      =  I   -B(K-2)'Z(K,1)+Z(2,1) .... -B(K-2)'Z(K,K)+Z(2,K)   I ,
C         I   -B(K-3)'Z(K,1)+Z(3,1) .... -B(K-3)'Z(K,K)+Z(3,K)   I
C         I             .           ....           .             I
C         I             .           ....           .             I
C         I             .           ....           .             I
C         I   -B(1)'Z(K,1)+Z(K-1,1) .... -B(1)'Z(K,K)+Z(K-1,K)   I
C         +-                                                    -+
C
C     WHERE Z(J,L)(J=1,K;L=1,K) ARE THE D*D SUB MATRICES OF THE
C     BLOCK MATRIX Z.
C     A'*Z IS STORED IN W2.
      IZ=K+1
cc      KX=KD-D
      J1=D+1
      KIZ=0
      DO  408 IY=1,K
      IZ=IZ-1
      DO  402 I=1,D
      DO  401 J=1,D
cc  401 WIN(I,J)=B(I,J,IZ)
cxx  401 WIN1(I,J)=B(I,J,IZ)
      WIN1(I,J)=B(I,J,IZ)
  401 CONTINUE
  402 CONTINUE
      KJZ=0
      DO  407 JY=1,K
      DO  404 I=1,D
      KIX=KX+I
      DO  403 J=1,D
      KJX=KJZ+J
cc  403 W3(I,J)=Z(KIX,KJX)
cxx  403 W32(I,J)=Z(KIX,KJX)
      W32(I,J)=Z(KIX,KJX)
  403 CONTINUE
  404 CONTINUE
cc      CALL MULTRX (WIN,D,D,MJD,MJD,W3,D,D,MJD,MJD,
cc     AW4,D,D,MJD,MJD,2)
      CALL MULTRX (WIN1,D,D,W32,D,D,W41,D,D,2)
      DO  406 I=1,D
      KIX=KIZ+I
      DO  405 J=1,D
      KJX=KJZ+J
cc  405 W2(KIX,KJX)=W4(I,J)
cxx  405 W2(KIX,KJX)=W41(I,J)
      W2(KIX,KJX)=W41(I,J)
  405 CONTINUE
  406 CONTINUE
      KJZ=KJZ+D
  407 CONTINUE
      KIZ=KIZ+D
  408 CONTINUE
      DO  411 IY=J1,KD
      DO  410 JY=1,KD
      IYY=IY-D
cxx  409 W2(IY,JY) = W2(IY,JY) + Z(IYY,JY)
      W2(IY,JY) = W2(IY,JY) + Z(IYY,JY)
  410 CONTINUE
  411 CONTINUE
C
C     Q=W2*A COMPUTATIONF W2=A'*Z
C
C     +-                   -+     +-                                -+
C     I  W2(1,1)...W2(1,K)  I     I     0     I        0   ..    0   I
C     I     .          .    I  *  I     0     0        I   ..    0   I
C     I     .          .    I     I     .     .        .   ..    .   I
C     I  W2(K,1)...W2(K,K)  I     I  -B(K) -B(K-1) -B(K-2) .. -B(1)  I
C     +-                   -+     +-                                -+
C
C         +-
C         I  -W2(1,K)B(K) -W2(1,K)B(K-1)+W2(1,1) ... -W2(1,K)B(1)+W2(1,K
C         I  -W2(2,K)B(K) -W2(2,K)B(K-1)+W2(2,1) ... -W2(2,K)B(1)+W2(2,K
C         I  -W2(3,K)B(K) -W2(3,K)B(K-1)+W2(3,1) ... -W2(3,K)B(1)+W2(3,K
C      =  I  -W2(4,K)B(K) -W2(4,K)B(K-1)+W2(4,1) ... -W2(4,K)B(1)+W2(4,K
C         I         .                  .         ...        .
C         I         .                  .         ...        .
C         I         .                  .         ...        .
C         I  -W2(K,K)B(K) -W2(K,K)B(K-1)+W2(K,1) ... -W2(K,K)B(1)+W2(K,K
C         +-
C
C     WHERE W2(J,L)(J=1,K;L=1,K) ARE THE (J,L) D*D SUB MATRICES
C     OF THE BLOCK MATRIX W2.
C     W2*A IS STORED IN Q.
      IZ=K+1
      KJZ=0
      DO  419 JY=1,K
      IZ=IZ-1
      DO  413 I=1,D
      DO  412 J=1,D
cxx  412 W32(I,J)=B(I,J,IZ)
      W32(I,J)=B(I,J,IZ)
  412 CONTINUE
  413 CONTINUE
      KIZ=0
      DO  418 IY=1,K
      DO  415 J=1,D
      KJX=KX+J
      DO  414 I=1,D
      KIX=KIZ+I
cc  414 WIN(I,J)=W2(KIX,KJX)
cxx  414 WIN1(I,J)=W2(KIX,KJX)
      WIN1(I,J)=W2(KIX,KJX)
  414 CONTINUE
  415 CONTINUE
cc      CALL MULTRX (WIN,D,D,MJD,MJD,W3,D,D,MJD,MJD,
cc     AW4,D,D,MJD,MJD,1)
      CALL MULTRX (WIN1,D,D,W32,D,D,W41,D,D,1)
      DO  417 J=1,D
      KJX=KJZ+J
      DO  416 I=1,D
      KIX=KIZ+I
cc  416 Q(KIX,KJX)=W4(I,J)
cxx  416 Q(KIX,KJX)=W41(I,J)
      Q(KIX,KJX)=W41(I,J)
  416 CONTINUE
  417 CONTINUE
      KIZ=KIZ+D
  418 CONTINUE
      KJZ=KJZ+D
  419 CONTINUE
      DO  422 JY=J1,KD
      DO  421 IY=1,KD
      JYY=JY-D
cxx  420 Q(IY,JY)=Q(IY,JY)+W2(IY,JYY)
      Q(IY,JY)=Q(IY,JY)+W2(IY,JYY)
  421 CONTINUE
  422 CONTINUE
cc      DO 142 I=1,KD
cc      DO 142 J=1,KD
cxx      DO 142 I=1,D
      DO 143 I=1,D
      DO 142 J=1,D
cxx  142 Q(I,J)=Q(I,J)+Q0(I,J)
      Q(I,J)=Q(I,J)+Q0(I,J)
  142 CONTINUE
  143 CONTINUE
  200 CONTINUE
C
C     G=-(INVERSE(BC'*Q*BC))*BC'*Q*A
C     G=R3*A; R3=INVERSE(BC'*Q*BC)*BC'*Q:
C
C     +-                   -+     +-                               -+
C     I  W(1) W(2) .. W(K)  I  *  I    0      I       0   ..    0   I
C     +-                   -+     I    0      0       I   ..    0   I
C                                 I    0      0       0   ..    0   I
C                                 I    .      .       .   ..    .   I
C                                 I -B(K) -B(K-1) -B(K-2) .. -B(1)  I
C                                 +-                               -+
C
C       +-
C       I
C     = I -W(K)B(K) -W(K)B(K-1)+W(1) -W(K)B(K-2)+W(2) ... -W(K)B(1)+W(K-
C       I
C       +-
C
C     WHERE W(J)(J=1,K) ARE THE J-TH R*D SUB MATRIX OF THE BLOCK MATRIX
C     R3*A IS STORED IN G.
  210 CONTINUE
      DO  455 I=1,R
      DO  454 J=1,D
      KJX=KX+J
cc  454 WIN(I,J)=R3(I,KJX)
cxx  454 WIN2(I,J)=R3(I,KJX)
      WIN2(I,J)=R3(I,KJX)
  454 CONTINUE
  455 CONTINUE
      IZ=K+1
      DO  461 JY=1,K
      IZ=IZ-1
      DO  453 I=1,D
      DO  452 J=1,D
cc  452 W3(I,J)=B(I,J,IZ)
cxx  452 W32(I,J)=B(I,J,IZ)
      W32(I,J)=B(I,J,IZ)
  452 CONTINUE
  453 CONTINUE
cc      CALL MULTRX (WIN,R,D,MJD,MJD,W3,D,D,MJD,MJD,
cc     AW4,R,D,MJD,MJD,1)
      CALL MULTRX (WIN2,R,D,W32,D,D,W42,R,D,1)
      KJZ=(JY-1)*D
      DO 457 I=1,R
      DO 456 J=1,D
      KJY=KJZ+J
cc  456 G(I,KJY)=W4(I,J)
cxx  456 G(I,KJY)=W42(I,J)
      G(I,KJY)=W42(I,J)
  456 CONTINUE
  457 CONTINUE
cc      IF  (KJZ) 461,461,458
      IF  (KJZ .LE. 0) GO TO 461
      IF  (KJZ .GT. 0) GO TO 458
  458 DO  460 I=1,R
      DO  459 J=1,D
      KJX=KJZ+J-D
      KJY=KJZ+J
cxx  459 G(I,KJY)=G(I,KJY)+R3(I,KJX)
      G(I,KJY)=G(I,KJY)+R3(I,KJX)
  459 CONTINUE
  460 CONTINUE
  461 CONTINUE
      DO 202 I=1,R
      DO 201 J=1,KD
cxx  201 G(I,J)=-G(I,J)
      G(I,J)=-G(I,J)
  201 CONTINUE
  202 CONTINUE
C     G PRINT OUT
cc      WRITE(6,903) R,KD
C     COMMON SUBROUTINE CALL
cc      CALL SUBMPR(G,R,KD,MJD,MJKD)
C
C
C
C     ****************
C     SIMULATION START
C     ****************
C     V(I),I=1,KD  CLEAR
cxx      DO  301 I=1,KD
cxx  301 V(I)=CST0
      V(1:KD)=CST0
C     CONSTANT FOR NOISE GENERATION
C     COMMON SUBROUTINE CALL
cc      SI(1)=RANDOM(1)
      SI(1)=RANDM(1,KK1,KK2,KK3,KK4)
C     OBSERVED SYSTEM OUTPUT GENERATION I=1,L
C     COVARIANCE MATRIX FACTORIZATION
C     COMMON SUBROUTINE CALL
cc      CALL LTINV  (S,KDR,MJD)
      CALL LTINV  (S,KDR)
C     MATRIX S ARRANGEMENT
      IF(KDR.EQ.1) GO TO 260
cxx      DO 12 I=2,KDR
      DO 13 I=2,KDR
      IM1=I-1
      DO 12 J=1,IM1
cxx   12 S(I,J)=S(J,I)
      S(I,J)=S(J,I)
   12 CONTINUE
   13 CONTINUE
  260 CONTINUE
C
      DO  500 J=1,L
C     AV=A*V COMPUTATION:
C
C     +-                               -+     +-    -+
C     I     0     I       0   ...    0  I     I V(1) I
C     I     0     0       I   ...    0  I     I V(2) I
C     I     0     0       0   ...    0  I  *  I V(3) I
C     I     .     .       .   ...    .  I     I   .  I
C     I     .     .       .   ...    .  I     I   .  I
C     I -B(K) -B(K-1) -B(K-2) ... -B(1) I     I V(K) I
C     +-                               -+     +-    -+
C
C       +-                                   -+
C       I  V(2)                               I
C     = I  V(3)                               I ,
C       I  V(4)                               I
C       I    .                                I
C       I    .                                I
C       I  -B(K)V(1)-B(K-1)V(2)-...-B(1)V(K)  I
C       +-                                   -+
C
C     WHERE V(J)(J=1,K) ARE THE D-DIMENSIONAL SUB VECTORS OF V.
C     A*V IS STORED IN THE VECTOR AV.
cxx      DO  432 I1=1,D
cxx  432 W1(I1)=CST0
      W1(1:D)=CST0
      IZ=K+1
      KJZ=0
      DO  436 JY=1,K
      IZ=IZ-1
      DO  434 I1=1,D
      DO  433 I2=1,D
      J2=KJZ+I2
cxx  433 W1(I1)=W1(I1)+B(I1,I2,IZ)*V(J2)
      W1(I1)=W1(I1)+B(I1,I2,IZ)*V(J2)
  433 CONTINUE
  434 CONTINUE
      KJZ=KJZ+D
  436 CONTINUE
      II1=0
      DO  439 IY=1,K1
      I1=II1+1
      I2=II1+D
      DO  438 IZ=I1,I2
      J1=IZ+D
      AV(IZ)=V(J1)
  438 CONTINUE
      II1=II1+D
  439 CONTINUE
      DO  441 I1=1,D
      I2=KX+I1
      AV(I2)=W1(I1)
  441 CONTINUE
C     CI=G*V; CONTROLLER INPUT
C     COMMON SUBROUTINE CALL
cc      CALL MULVER(G,V,CI,R,KD,MJD,MJKD)
      CALL MULVER(G,V,CI,R,KD)
C     BCN=BC*CI
C     COMMON SUBROUTINE CALL
cc      CALL MULVER(BC,CI,BCN,KD,R,MJKD,MJD)
      CALL MULVER(BC,CI,BCN,KD,R)
C     RANDOM VECTOR SI GENERATION
      DO 302 I=1,KDR
      BDMN=CSTM6
      DO 303 JRN=1,12
cc  303 BDMN=BDMN+RANDOM(0)
cxx  303 BDMN=BDMN+RANDM(0,KK1,KK2,KK3,KK4)
      BDMN=BDMN+RANDM(0,KK1,KK2,KK3,KK4)
  303 CONTINUE
cxx  302 BDN(I)=BDMN
      BDN(I)=BDMN
  302 CONTINUE
C     RANDOM NORMAL VECTOR BDN GENERATION
C     COMMON SUBROUTINE CALL
cc      CALL LTRVEC(S,BDN,SI,KDR,KDR,MJD,MJD)
      CALL LTRVEC(S,BDN,SI,KDR,KDR)
C     COMMON SUBROUTINE CALL
cc      CALL MULVER(BD,SI,BDN,KD,KDR,MJKD,MJD)
      CALL MULVER(BD,SI,BDN,KD,KDR)
C     V=AV+BCN+BDN
      DO  309 I=1,KD
cxx  309 V(I) = AV(I)+BCN(I)+BDN(I)
      V(I) = AV(I)+BCN(I)+BDN(I)
  309 CONTINUE
      DO  310 I=1,D
cxx  310 Y(I,J)=V(I)
      Y(I,J)=V(I)
  310 CONTINUE
  500 CONTINUE
C
C     ************************************************
C     MEAN, VARIANCE AND STANDARD DEVIATION COMPUTATION
C     ************************************************
      AL=L
      AL=CST1/AL
      DO  600 I=1,D
      SUM=CST0
      DO  501 J=1,L
cxx  501 SUM=SUM+Y(I,J)
      SUM=SUM+Y(I,J)
  501 CONTINUE
cc      AV(I)=AL*SUM
      AVY(I)=AL*SUM
      SUM=CST0
      DO  502 J=1,L
cc  502 SUM=SUM+(Y(I,J)-AV(I))**2
cxx  502 SUM=SUM+(Y(I,J)-AVY(I))**2
      SUM=SUM+(Y(I,J)-AVY(I))**2
  502 CONTINUE
      SI(I)=AL*SUM
      S2(I)= DSQRT(SI(I))
  600 CONTINUE
cc      WRITE(6,902)
cc      WRITE(6,904)
cc      DO  610 I=1,D
cc  610 WRITE(6,905) I,AV(I),SI(I),S2(I)
C
cc      CALL FLCLS2(NFL)
cc  999 CONTINUE
      RETURN
cxx  800 FORMAT(6I5)
cxx  900 FORMAT('1  PROGRAM 74.3.2. OPTIMAL CONTROLLER DESIGN')
cxx  901 FORMAT(1H ,'D (DIMENSION)=',I2,', K (ORDER)=',I3,', H (HORIZON)=',
cxx     A       I3,', L (LENGTH OF EXPERIMENTAL PERIOD)=',I5,
cxx     A       ', R (DIMENSION OF CONTROL INPUT)=',I5)
cxx  902 FORMAT(//1H ,'OPTIMAL CONTROL SIMULATION')
cxx  903 FORMAT(////1H ,'COTROLLER GAIN G(',I3,',',I3,')')
cxx  904 FORMAT(1H ,' AVERAGE VALUE OF I-TH COMPONENT OF Y',9X,
cxx     A'VARIANCE',20X,'STANDARD DEVIATION')
cxx  905 FORMAT(1H ,'      I = ',I4,D20.10,8X,D20.10,8X,D20.10)
cxx  700 FORMAT(' MATRIX  B(',I3,')')
cxx  701 FORMAT(' MATRIX  BX')
cxx  702 FORMAT(' MATRIX  BC')
cxx  703 FORMAT(' MATRIX  BD')
cxx  704 FORMAT(' MATRIX  QX')
cxx  706 FORMAT(' S: COVARIANCE MATRIX OF INNOVATION')
      END
C
cc      SUBROUTINE MULTRX(X,MX,NX,MJ1,MJ2,Y,MY,NY,MJ3,MJ4,
cc     A                  Z,MZ,NZ,MJ5,MJ6,IS)
      SUBROUTINE MULTRX(X,MX,NX,Y,MY,NY,Z,MZ,NZ,IS)
C     MATRIX MULTIPLICATION
C     X: MX*NX, ABSOLUTE DIMENSION MJ1*MJ2
C     Y: MY*NY, ABSOLUTE DIMENSION MJ3*MJ4
C     Z: MZ*NZ, ABSOLUTE DIMENSION MJ5*MJ6
C     IS=1: Z=X*Y
C     IS=2: Z=X'*Y
C     IS=3: Z=X*Y'
cxx      IMPLICIT REAL*8 (A-H,O-Z)
cc      DIMENSION X(MJ1,MJ2),Y(MJ3,MJ4),Z(MJ5,MJ6)
cxx      DIMENSION X(MX,NX),Y(MY,NY),Z(MZ,NZ)
      INTEGER :: MX, NX, MY, NY, MZ, NZ, IS
      REAL(8) :: X(MX,NX), Y(MY,NY), Z(MZ,NZ)
      REAL(8) :: CST0
      CST0=0.0D-00
      IF  (IS.EQ.2) GO TO 3050
      IF  (IS.EQ.3) GO TO 3100
cc      MZ=MX
cc      NZ=NY
      DO  3009 I=1,MX
      DO  3008 J=1,NY
      Z(I,J)=CST0
      DO  3007 K=1,NX
cxx 3007 Z(I,J)=Z(I,J)+X(I,K)*Y(K,J)
      Z(I,J)=Z(I,J)+X(I,K)*Y(K,J)
 3007 CONTINUE
 3008 CONTINUE
 3009 CONTINUE
      GO TO 3200
cc 3050 MZ=NX
cc      NZ=NY
 3050 CONTINUE
      DO  3059 I=1,NX
      DO  3058 J=1,NY
      Z(I,J)=CST0
      DO  3057 K=1,MX
cxx 3057 Z(I,J)=Z(I,J)+X(K,I)*Y(K,J)
      Z(I,J)=Z(I,J)+X(K,I)*Y(K,J)
 3057 CONTINUE
 3058 CONTINUE
 3059 CONTINUE
      GO TO 3200
cc 3100 MZ=MX
cc      NZ=MY
 3100 CONTINUE
      DO  3159 I=1,MX
      DO  3158 J=1,MY
      Z(I,J)=CST0
      DO  3157 K=1,NX
cxx 3157 Z(I,J)=Z(I,J)+X(I,K)*Y(J,K)
      Z(I,J)=Z(I,J)+X(I,K)*Y(J,K)
 3157 CONTINUE
 3158 CONTINUE
 3159 CONTINUE
 3200 RETURN
      END
C
cc      SUBROUTINE INVDET(X,XDET,MM,MJ)
      SUBROUTINE INVDETS(X,XDET,MM)
C     COMMON SUBROUTINE
C     THIS SUBROUTINE COMPUTES THE INVERSE AND DETERMINANT OF
C     UPPER LEFT MM X MM OF X.
C     X: ORIGINAL MATRIX
C     MM: DIMENSION OF UPPER LEFT OF X (SHOULD BE LESS THAN 11)
C     XDET: DETERMINANT OF UPPER LEFT MM X MM OF X
C     MJ: ABSOLUTE DIMENSION OF X IN THE MAIN ROUTINE
C     THE INVERSE MATRIX IS OVERWRITTEN ON THE ORIGINAL.
C     NEXT STATEMENT SHOULD BE REPLACED BY
C     IMPLICIT COMPLEX*16(X)
C     FOR COMPLEX VERSION.  ALSO STATEMENT NO.1 NEEDS MODIFICATION.
cxx      IMPLICIT REAL*8(X)
cc      DIMENSION X(MJ,MJ)
cc      DIMENSION IDS(10)
cxx      DIMENSION X(MM,MM)
cxx      DIMENSION IDS(MM)
      INTEGER :: MM
      REAL(8) :: X(MM,MM), XDET
      INTEGER :: IDS(MM)
      REAL(8) :: CST0, CST1, XMAXP, XC
      CST0=0.0D-00
      CST1=1.0D-00
      XDET=CST1
      DO 10 L=1,MM
C     PIVOTING AT L-TH STAGE
      XMAXP=0.10000D-10
      MAXI=0
      DO 110 I=L,MM
C     FOR COMPLEX VERSION NEXT STATEMENT SHOULD BE REPLACED BY
C     IF(CDABS(XMAXP).GE.CDABS(X(I,L))) GO TO 110
cxx    1 IF(DABS(XMAXP).GE.DABS(X(I,L))) GO TO 110
      IF(DABS(XMAXP).GE.DABS(X(I,L))) GO TO 110
      XMAXP=X(I,L)
      MAXI=I
  110 CONTINUE
      IDS(L)=MAXI
      IF(MAXI.EQ.L) GO TO 120
      IF(MAXI.GT.0) GO TO 121
      XDET=CST0
      GO TO 140
C     ROW INTERCHANGE
  121 DO 14 J=1,MM
      XC=X(MAXI,J)
      X(MAXI,J)=X(L,J)
cxx   14 X(L,J)=XC
      X(L,J)=XC
   14 CONTINUE
      XDET=-XDET
  120 XDET=CST1
      XC=CST1/XMAXP
      X(L,L)=CST1
      DO 11 J=1,MM
cxx   11 X(L,J)=X(L,J)*XC
      X(L,J)=X(L,J)*XC
   11 CONTINUE
      DO 12 I=1,MM
      IF(I.EQ.L) GO TO 12
      XC=X(I,L)
      X(I,L)=CST0
      DO 13 J=1,MM
cxx   13 X(I,J)=X(I,J)-XC*X(L,J)
      X(I,J)=X(I,J)-XC*X(L,J)
   13 CONTINUE
   12 CONTINUE
   10 CONTINUE
      IF(MM.GT.1) GO TO 123
      GO TO 140
C     COLUMN INTERCHANGE
  123 MM1=MM-1
      DO 130 J=1,MM1
      MMJ=MM-J
      JJ=IDS(MMJ)
      IF(JJ.EQ.MMJ) GO TO 130
      DO 131 I=1,MM
      XC=X(I,JJ)
      X(I,JJ)=X(I,MMJ)
cxx  131 X(I,MMJ)=XC
      X(I,MMJ)=XC
  131 CONTINUE
  130 CONTINUE
  140 RETURN
      END


integer n
write "Give n = "
read n
end
integer function fibonacci(integer number)
    if(number .eq. 0) fibonacci = 0
    if(number .eq. 1) fibonacci = 1
    fibonacci = fibonacci(number - 1) + fibonacci(number-2)
end


program select_class
    use, intrinsic :: iso_fortran_env, only : error_unit, input_unit
    use :: stats_mod
    use :: median_stats_mod
    implicit none
    integer :: nr_values
    class(descriptive_stats_t), allocatable :: stats
    integer :: value_nr = 0, istat
    character(len=2048) :: msg, stats_type
    real :: data_value

    call get_command_llne_values(nr_values, stats_type)
    if (stats_type == 'median') then
        allocate (stats, source=median_stats_t(nr_values))
    else
        allocate (stats, source=descriptive_stats_t())
    end if
    do while (value_nr < nr_values)
        read (unit=input_unit, fmt=*, iostat=istat, iomsg=msg) data_value
        if (istat == -1) then
            write (unit=error_unit, fmt='(2(A, I0))') &
                'warning: read ', stats%get_nr_values(), &
                ' values, expected ', nr_values
            exit
        end if
        if (istat /= 0) then
            write (unit=error_unit, fmt='(2A)') 'warning: ', trim(msg)
            cycle
        end if
        call stats%add_value(data_value)
        value_nr = value_nr + 1
    end do
    print '(A, I0)', 'n      = ', stats%get_nr_values()
    print '(A, F10.3)', 'mean   = ', stats%get_mean()
    select type (stats)
        class is (median_stats_t)
            print '(A, F10.3)', 'median   = ', stats%get_median()
    end select
    print '(A, F10.3)', 'stddev = ', stats%get_stddev()

    deallocate (stats)

contains

    subroutine get_command_llne_values(nr_values, stats_type)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        integer, intent(out) :: nr_values
        character(len=*), intent(out) :: stats_type
        integer :: istat
        character(len=1024) :: buffer, msg

        if (command_argument_count() < 1) then
            write (unit=error_unit, fmt='(A)') &
                'error: number of values required as argument'
            stop 5
        end if
        call get_command_argument(1, buffer)
        read (buffer, fmt=*, iostat=istat, iomsg=msg) nr_values
        if (istat /= 0) then
            write (unit=error_unit, fmt='(2A)') 'error: ', trim(msg)
            stop 6
        end if
        stats_type = 'simple'
        if (command_argument_count() >= 2) then
            call get_command_argument(2,stats_type)
            if (trim(stats_type) /= 'median') stats_type = 'simple'
        end if
    end subroutine get_command_llne_values

end program select_class