       subroutine antialias_ellipse(radius,ricen,rjcen,aspect_ratio,array,ni,nj,iverbose)

!      radius        radius in pixels of ellipse vertical axis        I
!      ricen         location in pixels of ellipse center             I
!      ni,nj         half size of pixel box to evaluate               I
!      array         fractional area of pixels inside ellipse         O

       real array(-ni:ni,-nj:nj)
       real m,k

       a = radius * aspect_ratio
       b = radius
       area_sum = 0.

       r_missing_data = 1e37

       do i = -ni,+ni
       do j = -nj,+nj

!        Subdivide grid box into horizontal lines
         sum = 0.
         xlo = float(i) - 0.5
         xhi = float(i) + 0.5

         do jsub = 0,9
           y = float(j) + float(jsub)/10. - 0.45
           c = y
           m = 0.
           h = ricen
           k = rjcen
           call line_ellipse(m,c,h,k,a,b,r_missing_data,x1,x2,y1,y2)
           call get_overlap(x1,x2,xlo,xhi,r_missing_data,icond,overlap,x1o,x2o)
           if(iverbose .ge. 2)write(6,1)i,j,y,xlo,xhi,x1,x2,overlap,icond,radius,aspect_ratio
1          format(2i4,f9.2,2f9.2,2f9.4,f9.4,i3,2f9.2)
           sum = sum + overlap
         enddo ! isub

         area = sum / float(10)

         if(iverbose .ge. 1)write(6,2)i,j,ricen,rjcen,area
2        format(' i/j/ricen/rjcen/area (sq pix)',2x,2i3,2x,2f7.2,f10.4)

         array(i,j) = area

         area_sum = area_sum + area

       enddo ! j
       enddo ! i

       if(iverbose .ge. 1)then
         pi = 3.14159
         area_theo = (pi * radius**2) * aspect_ratio
         write(6,3)radius,aspect_ratio,area_sum,area_theo
3        format(' sum of illuminated area (sq pix): rad/asp/area_sum/theo = ',4f9.5)
       endif

       return
       end

       subroutine get_overlap(x1,x2,xlo,xhi,r_missing_data,icond,overlap,x1o,x2o)

       if(x1 .le. xlo .and. x2 .ge. xhi)then
         icond = 1
         overlap = 1.0
         x1o = xlo
         x2o = xhi
       elseif(x2 .le. xlo .or. x1 .ge. xhi)then
         icond = 2
         overlap = 0.0
         x1o = r_missing_data
         x2o = r_missing_data
       elseif(x1 .le. xlo .and. x2 .ge. xlo)then
         icond = 3
         overlap = x2 - xlo
         x1o = xlo
         x2o = x2
       elseif(x1 .le. xhi .and. x2 .ge. xhi)then
         icond = 4
         overlap = xhi - x1
         x1o = x1
         x2o = xhi
       elseif(x1 .eq. r_missing_data .or. x2 .eq. r_missing_data)then
         icond = 5
         overlap = 0.0
         x1o = r_missing_data
         x2o = r_missing_data
       elseif(x1 .ge. xlo .and. x2 .le. xhi)then
         icond = 6
         overlap = x2-x1
         x1o = x1
         x2o = x2
       else
         icond = 7
         overlap = r_missing_data
         x1o = r_missing_data
         x2o = r_missing_data
       endif

       return
       end

       subroutine line_ellipse(m,c,h,k,a,b,r_missing_data,x1,x2,y1,y2)

!      http://www.ambrsoft.com/TrigoCalc/Circles2/Ellipse/EllipseLine.htm

!      Find intersection of line and circle
!      Line is defined as y = mx + c

       real m,k

       e = c-k
       d = c + m*h

       disc = a**2*m**2+b**2-d**2-k**2+2*d*k

       if(disc .lt. 0.)then
         x1 = r_missing_data
         x2 = r_missing_data
         y1 = r_missing_data
         y2 = r_missing_data
       else
         denom = a**2*m**2+b**2
         x1 = (b**2*h - m*a**2*e    - a*b*sqrt(disc))   / denom
         x2 = (b**2*h - m*a**2*e    + a*b*sqrt(disc))   / denom
         y1 = (b**2*d + k*a**2*m**2 - a*b*m*sqrt(disc)) / denom
         y2 = (b**2*d + k*a**2*m**2 + a*b*m*sqrt(disc)) / denom
       endif

       return
       end

       subroutine antialias_phase(radius,ricen,rjcen,aspect_ratio,alt_scale,azi_scale,va,rill,array,ni,nj,iverbose)

!      radius        radius in pixels of ellipse vertical axis        I
!      ricen         location in pixels of ellipse center             I
!      ni,nj         half size of pixel box to evaluate               I
!      aspect_ratio  circle projected onto alt/az grid                I
!      va            vertex angle of center of illuminated limb       I
!                    (0 is up, 90 is left)
!      array         fractional area of pixels inside ellipse         O

       parameter (rpd = 3.14159/180.)

!      radius of ellipse with theta measured from a (major) axis
       rell(a,b,theta) = (a * b) / sqrt( (b*cos(theta))**2 + (a*sin(theta))**2 )
!      rell(a,b,theta) = sqrt( (b*cos(theta))**2 + (a*sin(theta))**2 )

       real array(-ni:ni,-nj:nj)
       real m,k

       xpix = ricen
       ypix = rjcen

       xdeg = xpix * azi_scale / aspect_ratio
       ydeg = ypix * alt_scale

       radpix = radius
       raddeg = sqrt(xdeg**2+ydeg**2)

       bb = radius
       area_sum = 0.

!      Ratio of terminator minor axis / major axis
       aspect2 = abs((2.*rill)-1.)

       r_missing_data = 1e37

       do i = -ni,+ni
       do j = -nj,+nj

!        Subdivide grid box into horizontal lines
         sum = 0.
         if(iverbose .ge. 2)write(6,*)'  i   j    xpix     ypix     rdeg  theta_minor rell1    rell2  aspect_rat rinc'
         do isub = 0,9
         do jsub = 0,9
           xpix = ricen + float(i) + float(isub)/10. - 0.45
           ypix = rjcen + float(j) + float(jsub)/10. - 0.45

           xdeg = xpix * azi_scale / aspect_ratio
           ydeg = ypix * alt_scale

           rdeg = sqrt(xdeg**2+ydeg**2)
           theta_up = atan2(xdeg,ydeg)
           theta_minor = theta_up + va*rpd
           theta_major=theta_minor+90.*rpd

!          Determine r_el1, r_el2 and compare
           rell1 = 0.25
           rell2 = rell(rell1,rell1*aspect2,theta_major)
           if(rdeg .lt. rell1)then
             if(rill .ge. 0.5)then ! gibbous
               if(cos(theta_minor).ge.0.)then ! illuminated half
                 rinc = 1.
               elseif(rdeg .lt. rell2)then
                 rinc = 1.
               else
                 rinc = 0.
               endif
             else
               if(cos(theta_minor).lt.0.)then ! unilluminated half
                 rinc = 0.
               elseif(rdeg .lt. rell2)then
                 rinc = 0.
               else
                 rinc = 1.
               endif
             endif
           else
             rinc = 0.
           endif
           if(iverbose .ge. 2)write(6,1)i,j,xpix,ypix,rdeg,theta_minor/rpd,rell1,rell2,aspect2,rinc
1          format(2i4,9f9.3)
           sum = sum + rinc
         enddo ! jsub
         enddo ! isub

         area = sum / float(100)

         if(iverbose .ge. 1)write(6,2)i,j,ricen,rjcen,rill,raddeg,area
2        format(' i/j/ricen/rjcen/rill/raddeg/area (sq pix)',2x,2i3,2x,4f7.2,f10.4)

         array(i,j) = area

         area_sum = area_sum + area

       enddo ! j
       enddo ! i

       if(iverbose .ge. 1)then
         pi = 3.14159
         area_theo = (pi * radius**2) * aspect_ratio
         write(6,3)area_sum,area_theo
3        format(' sum of illuminated area (sq pix): area_sum/theo = ',2f9.5)
       endif

       write(6,*)'array(0,0)=',array(0,0)

       return
       end


      program P0210
c>> 1997-06-20 Krogh Generate plots for ch02-02.tex
      integer MAXPT
      real RMAXPT, XA, XB, XSIZE, YSIZE
      real YMAX, YMIN
      parameter (MAXPT=101, RMAXPT=101.E0)
      parameter (XA = 0.0E0, XB = 1.6E0)
      parameter (XSIZE=3.2E0, YSIZE=2.5E0)
      parameter (YMAX=4.0E0, YMIN=-4.0E0)
      real DX, OPT(16), X(MAXPT), Y(MAXPT, 2)
      external SE1, SEI
      real SE1, SEI
      integer I
      character COPT*33
      real PLOUNI, PLOTXT, PLONY, PLOBOR, PLOYMX
      parameter (PLOUNI=1.E0, PLOTXT=14.E0, PLONY=2.E0, PLOBOR=4.E0,
     1   PLOYMX=9.E0 )
      data OPT / 0.E0, PLONY, RMAXPT, 2.E0, PLOTXT, 1.2E0, .5E0, 0.E0,
     1   PLOTXT, .8E0, 2.E0, 0.E0, PLOYMX, YMIN, YMAX,
     2   0.E0 /
      data COPT /'F{pl02-10.tex}{$E_1(x)$}{$Ei(x)$}'/
c
      DX = (XB - XA) / (MAXPT-1)
      do 100 I = 1, MAXPT
         X(I) = real(I-1) * DX
         if (X(I) .eq. 0) X(I) = 1.E-3
         Y(I,1) = min(SE1(X(I)), YMAX + 1.E0)
         Y(I,2) = max(SEI(X(I)), YMIN - 1.E0)
  100 continue
      call SPLOT(XSIZE, YSIZE, X, MAXPT, Y, OPT, COPT)
      stop
      end


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
!	check that passing intrinsics works
!	with or without interface blocks
!
	program tp0023
	intrinsic sin, cos
	real pi, res(4), exp(4)
	data exp/0.0,1.0,0.0,1.0/
	interface
	    subroutine  SUBR(RF1, ARG, RES )
	       real  ARG, RES
	       interface
		 function  RF1(RX)
		   real  RF1
		   real  RX
		 end function
	       end interface
	    end subroutine
	end interface

	pi = acos(1.0)
	call subr(sin, pi, res(1))
	call subr(cos, pi, res(2))
	call subs(sin, pi, res(3))
	call subs(cos, pi, res(4))
	call check(res,exp,4)
	end

	subroutine  SUBR( RF1, ARG, RES )
	  real  ARG, RES
	  interface
	    function  RF1(RX)
	      real  RF1
	      real  RX
	    end function
	  end interface
	  RES = RF1(ARG)
	end subroutine
	subroutine  SUBS( RF1, ARG, RES )
	  real  ARG, RES
	  external RF1
	  RES = RF1(ARG)
	end subroutine


c     **********
c
c     this program tests the ability of chkder to detect
c     inconsistencies between functions and their first derivatives.
c     fourteen test function vectors and jacobians are used. eleven of
c     the tests are false(f), i.e. there are inconsistencies between
c     the function vectors and the corresponding jacobians. three of
c     the tests are true(t), i.e. there are no inconsistencies. the
c     driver reads in data, calls chkder and prints out information
c     required by and received from chkder.
c
c     subprograms called
c
c       minpack supplied ... chkder,errjac,initpt,vecfcn
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,ldfjac,lnp,mode,n,nprob,nread,nwrite
      integer na(14),np(14)
      logical a(14)
      double precision cp,one
      double precision diff(10),err(10),errmax(14),errmin(14),
     *                 fjac(10,10),fvec1(10),fvec2(10),x1(10),x2(10)
c
c     logical input unit is assumed to be number 5.
c     logical output unit is assumed to be number 6.
c
      data nread,nwrite /5,6/
c
      data a(1),a(2),a(3),a(4),a(5),a(6),a(7),a(8),a(9),a(10),a(11),
     *     a(12),a(13),a(14)
     *     /.false.,.false.,.false.,.true.,.false.,.false.,.false.,
     *      .true.,.false.,.false.,.false.,.false.,.true.,.false./
      data cp,one /1.23d-1,1.0d0/
      ldfjac = 10
   10 continue
         read (nread,60) nprob,n
         if (nprob .le. 0) go to 40
         call initpt(n,x1,nprob,one)
         do 20 i = 1, n
            x1(i) = x1(i) + cp
            cp = -cp
   20       continue
         write (nwrite,70) nprob,n,a(nprob)
         mode = 1
         call chkder(n,n,x1,fvec1,fjac,ldfjac,x2,fvec2,mode,err)
         mode = 2
         call vecfcn(n,x1,fvec1,nprob)
         call errjac(n,x1,fjac,ldfjac,nprob)
         call vecfcn(n,x2,fvec2,nprob)
         call chkder(n,n,x1,fvec1,fjac,ldfjac,x2,fvec2,mode,err)
         errmin(nprob) = err(1)
         errmax(nprob) = err(1)
         do 30 i = 1, n
            diff(i) = fvec2(i) - fvec1(i)
            if (errmin(nprob) .gt. err(i)) errmin(nprob) = err(i)
            if (errmax(nprob) .lt. err(i)) errmax(nprob) = err(i)
   30       continue
         np(nprob) = nprob
         lnp = nprob
         na(nprob) = n
         write (nwrite,80) (fvec1(i), i = 1, n)
         write (nwrite,90) (diff(i), i = 1, n)
         write (nwrite,100) (err(i), i = 1, n)
         go to 10
   40 continue
      write (nwrite,110) lnp
      write (nwrite,120)
      do 50 i = 1, lnp
         write (nwrite,130) np(i),na(i),a(i),errmin(i),errmax(i)
   50    continue
      stop
   60 format (2i5)
   70 format ( /// 5x, 8h problem, i5, 5x, 15h with dimension, i5, 2x,
     *         5h is  , l1)
   80 format ( // 5x, 25h first function vector    // (5x, 5d15.7))
   90 format ( // 5x, 27h function difference vector // (5x, 5d15.7))
  100 format ( // 5x, 13h error vector // (5x, 5d15.7))
  110 format (12h1summary of , i3, 16h tests of chkder /)
  120 format (46h nprob   n    status     errmin         errmax /)
  130 format (i4, i6, 6x, l1, 3x, 2d15.7)
c
c     last card of derivative check test driver.
c
      end


!     gfortran -ffree-line-length-none -O2 -static -static-libgfortran -finit-local-zero -fopenmp -o test1 test1.f90
!     pgf90 -O2 -mcmodel=medium -Mbounds -mp -o test1 test1.f90
!     ifort -g -mcmodel=medium  -Bstatic -assume byterecl -qopenmp -o test1 test1.f90

!Warning: best to check if the parallel loop size >  # of threads. When they r equal, strange things happen on gcc.
!Accroding to some ref, dynamic arrays (alloc) can only be shared

      module glbl
      implicit none

      integer, save :: n
      real*8, save, allocatable :: a2d(:,:)
      end module

      program main
      use glbl
      implicit none
      real*8, parameter :: a1=1
      real*8, parameter :: b1=-1
      integer :: i,j,tid,nth,nth0,omp_get_thread_num,omp_get_num_threads,icount, & !,icount(2)
     &imax,jmax,imax2,jmax2
      real*8 :: sum1,sum2,rmax1,rmax2,rmax3
      real*8, allocatable :: aa(:,:),bb(:),cc(:),dd(:,:),ee(:),ff(:),ww(:,:)
      real*8 :: tau(3),tmp1

!     Find # of threads
!$OMP parallel default(shared)
!$OMP master
!$      nth0=omp_get_num_threads()
!$OMP end master
!$OMP end parallel

      n=5
      allocate(aa(3,n),bb(n),cc(3),dd(n,n),ee(n),ff(n*n),a2d(n,10),ww(3,n))
      bb=-1.
      do j=1,10
        do i=1,n
          a2d(i,j)=i-2*j
        enddo !i
      enddo !j

      sum1=0; sum2=0
!$OMP parallel if(n>nth0) default(shared) private(i,j,tid,nth,imax2,jmax2,rmax2,tau)
!$      tid=omp_get_thread_num()
!$      nth=omp_get_num_threads() !=1 if n<=nth0!!
!        if(nth/=nth0) then
!          print*, '# of threads mismatch,',nth,nth0
!          stop
!        endif
!$      print*, 'from thread ',tid,nth

!     The following can be init'ed outside parallel region also
!     Since they are shared, they become known to all threads after this
!$OMP master
      rmax1=-huge(1.d0)
      rmax3=rmax1
      icount=0
      imax=-1; jmax=-1
!no implied barriers for master construct
!$OMP end master
!$OMP barrier

!     Although the outer loop is parallel (and executed in random order), the inner loop is serial and
!     is executed in the intended order for correctness
!$OMP do
      do i=1,n
        ww(1,i)=-i !bottom
        do j=2,3
          ww(j,i)=ww(j-1,i)+1
        enddo !j
      enddo !i
!$OMP end do

!$OMP do reduction(+: sum1,sum2)
      !reduction vars cannot be an elem of an array e.g. rmax1(3)
      do i=1,n
        do j=1,3
          tau(j)=i+j
          print*, 'each thread',tid,i,j,tau(j)

          if(i<4.and.j<2) then
            aa(j,i)=bb(i)-n-i+j+a1
            sum1=sum1+aa(j,i)
          else
            aa(j,i)=i+j-b1
            sum2=sum2+aa(j,i)
          endif
        enddo !j
      enddo !i
!$OMP end do nowait

!$OMP workshare
      bb(1:n:2)=bb(1:n:2)-1; tmp1=maxval(abs(ww))
!$OMP end workshare

!$OMP do reduction(max: rmax1)
      do i=1,n
        imax2=-1; jmax2=-1;  rmax2=-huge(1.d0)
        do j=1,3
          if(i<5.and.j/=3) then
            rmax1=max(rmax1,aa(j,i))
!$OMP       atomic
!            icount(1)=icount(1)+1 <-atomic option cannot be applied to array elem!
            icount=icount+1

            !Find loc in non-parallel dimension first
            if(aa(j,i)>rmax2) then
              rmax2=aa(j,i)
              imax2=i; jmax2=j
            endif
          endif !i<5.a
        enddo !j

!$OMP   critical
        if(i<5.and.rmax2>rmax3) then
          rmax3=rmax2
          imax=imax2; jmax=jmax2
        endif !aa
!$OMP   end critical
      enddo !i
!$OMP end do

!$OMP end parallel

!     Only master thread in serial portion
       print*, 'max(ww)=',maxval(abs(ww)),tmp1
      do i=1,n
        print*, i,'ww=',ww(:,i)
        print*, i,'aa=',aa(:,i)
      enddo !i
      print*, 'sum1,2=',sum1,sum2,sum(aa)
      print*, 'max, loc=',rmax1,rmax3,icount,imax,jmax

      print*, 'bb=',bb

!     Matrix-vector product
      call mxv(3,n,aa,bb,cc)

      print*, 'aa*bb=',cc

!     Another Matrix-vector product (no race condition)
!$OMP parallel default(shared) private(i,j,nth)
!$      nth=omp_get_num_threads()
!$      print*, 'nth(new)=',nth
!$OMP workshare
      ff=(/((i-j,i=1,n),j=1,n)/)
      dd(:,:)=reshape(ff,(/n,n/)) !transpose of the final matrix D for cache efficiency
      ee(:)=0
!$OMP end workshare

!$OMP master
      do i=1,n
        print*, i,'dd(,i)=',dd(:,i)
      enddo !i
!$OMP end master
!no implied barriers for master construct

!$OMP do schedule(guided)
      do i=1,n
        do j=1,n
          !Note the order of indices for dd; no race
          ee(i)=ee(i)+dd(j,i)*bb(j)
        enddo !j
      enddo !i
!$OMP end do
!$OMP end parallel

      print*, 'transpose(dd)*bb=',ee

!     Routine call
!$OMP parallel default(private) shared(n,ee)
      nth=omp_get_num_threads()
      tid=omp_get_thread_num()
!$OMP do
      do i=1,n
        print*, 'tst2:',tid,i
        call tst2(i,tid,ee)
      enddo !i
!$OMP end do
!$OMP end parallel

!     Nested loop
      bb=0
!$OMP parallel default(shared) private(j,i)
      do j=1,5
!$OMP   do
        do i=1,n
          bb(i)=bb(i)+i-j
        enddo !i
!$OMP   end do
      enddo !j
!$OMP end parallel

!     Compare with serial
      ee=0
      do j=1,5
        do i=1,n
          ee(i)=ee(i)+i-j
        enddo !i
      enddo !j

      print*, 'After nested loop:',bb
      print*, 'After nested loop (serial):',ee

      stop
      end

      subroutine tst2(i,tid,ee)
      use glbl
      implicit none
      integer, intent(in) :: i,tid
      real*8, intent(in) :: ee(n)

      integer :: i2,j

      i2=i*i
      write(99,*)'output from tst2 and thread ',tid,i,n,ee
      write(99,*)'i2=',i2 !still private
      do j=1,n
        write(99,*)j,'a2d:',a2d(j,:) !global a2d accesible, but better not to write to it!
      enddo !j

      end subroutine tst2

      subroutine mxv(m,n,aa,bb,cc)
      implicit none
      integer, intent(in) :: m,n
      real*8, intent(in) :: aa(m,n),bb(n)
      real*8, intent(out) :: cc(m)

      integer :: i,j

!$OMP parallel default(shared) private(i,j)
!$OMP workshare
      cc(:)=0
!$OMP end workshare

!array reduction - each thread takes a chunk of j and do array sum (1:m)
!$OMP do reduction(+: cc)
      do j=1,n
!        do i=1,m
        cc(1:m)=cc(1:m)+aa(1:m,j)*bb(j)
!        enddo !i
      enddo !j
!$OMP end parallel

      end subroutine mxv


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

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

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

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

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

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


module geom

  type point
     real(8), private  :: x = 0
     real(8), private  :: y = 0
   contains
     procedure, public :: get_x
     procedure, public :: get_y
     procedure, public :: set_x
     procedure, public :: set_y
     procedure, public :: print => print_point
     procedure, pass :: copy_point
     !overloaded assignment operator
     generic, public :: assignment(=) => copy_point
  end type point

  type, extends(point) :: circle
     real(8), private  :: r = 0
   contains
     procedure, public :: get_r
     procedure, public :: set_r
     procedure, public :: print => print_circle
     procedure, pass :: copy_circle
     !overloaded assignment operator
     generic, public :: assignment(=) => copy_circle
  end type circle

  ! constructor interface
  interface circle
  module procedure circle_constructor
  end interface circle
  ! constructor interface
  interface point
  module procedure point_constructor
  end interface point

contains

  real(8) function get_x(this)
    class(point), intent(in) :: this
    get_x = this%x
  end function get_x

  real(8) function get_y(this)
    class(point), intent(in) :: this
    get_y = this%y
  end function get_y

  subroutine set_x(this, val)
    class(point), intent(inout) :: this
    real(8), intent(in)         :: val
    this%x = val
  end subroutine set_x

  subroutine set_y(this, val)
    class(point), intent(inout) :: this
    real(8), intent(in)         :: val
    this%y = val
  end subroutine set_y

  subroutine print_point(this)
    class(point), intent(in) :: this
    write(*,'(2(a,f0.4),a)') 'Point(',this%x,', ',this%y,')'
  end subroutine print_point

  real(8) function get_r(this)
    class(circle), intent(in) :: this
    get_r = this%r
  end function get_r

  subroutine set_r(this, val)
    class(circle), intent(inout) :: this
    real(8), intent(in)          :: val
    this%r = val
  end subroutine set_r

  subroutine print_circle(this)
    class(circle), intent(in) :: this
    write(*,'(3(a,f0.4),a)') 'Circle(',this%x,', ',this%y,'; ',this%r,')'
  end subroutine print_circle

  subroutine copy_point(this, rhs)
      class(point), intent(inout) :: this
      type(point), intent(in) :: rhs
      this%x = rhs%x
      this%y = rhs%y
  end subroutine copy_point

  subroutine copy_circle(this, rhs)
      class(circle), intent(inout) :: this
      type(circle), intent(in) :: rhs
      this%x = rhs%x
      this%y = rhs%y
      this%r = rhs%r
  end subroutine copy_circle

! non-default constructor to init private components
  type(point) function point_constructor(x,y)
  real(8), intent(in) :: x,y
  point_constructor%x = x
  point_constructor%y = y
  end function point_constructor
! non-default constructor to init private components
  type(circle) function circle_constructor(x,y,r)
  real(8), intent(in) :: x,y,r
  circle_constructor%x = x
  circle_constructor%y = y
  circle_constructor%r = r
  end function circle_constructor

end module geom

program inh
  use geom

  type(point)  :: p, p_copy
  type(circle) :: c, c_copy

  p = point(2.0d0, 3.0d0)
  call p%print
  p_copy = p
  call p_copy%print

  c = circle(3.0d0, 4.0d0, 5.0d0)
  call c%print
  c_copy = c
  call c_copy%print

end program inh


      SUBROUTINE chsone(bins,ebins,nbins,knstrn,df,chsq,prob)
      INTEGER knstrn,nbins
      REAL chsq,df,prob,bins(nbins),ebins(nbins)
CU    USES gammq
      INTEGER j
      REAL gammq
      df=nbins-knstrn
      chsq=0.
      do 11 j=1,nbins
        if(ebins(j).le.0.)pause 'bad expected number in chsone'
        chsq=chsq+(bins(j)-ebins(j))**2/ebins(j)
11    continue
      prob=gammq(0.5*df,0.5*chsq)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/chsone.for


!=============================================================================!
        subroutine solve1bc( nsys, n, nblk, mat, rhs, bc, mult, fact )
!=============================================================================!
!
!  Solves a block tridiagonal system of equations without pivoting.
!  Vectorized over the first index.
!
!  This routine has been modified to allow for high-order boundary
!  conditions.
!
!  WARNING: Since pivoting is not done, this algorithm could fail
!
!  WARNING: This routine works for nblk = 5 only!
!
!  input:
!    nsys       : number of systems to vectorize over
!    n          : number of rows in the systems
!    nblk       : dimension of the blocks in each row
!
!  inout:
!    mat        : the block tridiagonal matrix to be solved
!    rhs        : the right hand side
!    bc         : the bc array
!=============================================================================!
        implicit none

        integer, intent(in) :: n, nblk, nsys
        real, intent(inout) :: mat(nsys,n,nblk,nblk*3), rhs(nsys,n,nblk)
        real, intent(inout) :: bc(nsys,nblk,nblk,14)
        real, intent(inout) :: mult(nsys), fact(nsys)

!.... useful constants

        real, parameter :: zero = 0.0, one = 1.0

!.... local variables

        integer :: nc, nr, i, j, l, m, p, q, s, r, t, iv
!=============================================================================!
!                     F O R W A R D   E L I M I N A T I O N
!=============================================================================!

!.... first 3 rows are special due to boundary conditions

        i = 1

        do nc = 1, nblk - 1

          j = nblk + nc

          do m = nc, nblk - 1
            l = m + 1
            mult(:) = -mat(:,i,l,j) / mat(:,i,nc,j)
            do q = nc + nblk + 1, nblk * 2
              mat(:,i,l,q) = mat(:,i,l,q) + mult(:) * mat(:,i,nc,q)
            end do

            do iv = 1, nsys
              mat(iv,i,l,11) = mat(iv,i,l,11) + mult(iv) * mat(iv,i,nc,11)
              mat(iv,i,l,12) = mat(iv,i,l,12) + mult(iv) * mat(iv,i,nc,12)
              mat(iv,i,l,13) = mat(iv,i,l,13) + mult(iv) * mat(iv,i,nc,13)
              mat(iv,i,l,14) = mat(iv,i,l,14) + mult(iv) * mat(iv,i,nc,14)
              mat(iv,i,l,15) = mat(iv,i,l,15) + mult(iv) * mat(iv,i,nc,15)

              bc(iv,l,1,1) = bc(iv,l,1,1) + mult(iv) * bc(iv,nc,1,1)
              bc(iv,l,2,1) = bc(iv,l,2,1) + mult(iv) * bc(iv,nc,2,1)
              bc(iv,l,3,1) = bc(iv,l,3,1) + mult(iv) * bc(iv,nc,3,1)
              bc(iv,l,4,1) = bc(iv,l,4,1) + mult(iv) * bc(iv,nc,4,1)
              bc(iv,l,5,1) = bc(iv,l,5,1) + mult(iv) * bc(iv,nc,5,1)

              bc(iv,l,1,2) = bc(iv,l,1,2) + mult(iv) * bc(iv,nc,1,2)
              bc(iv,l,2,2) = bc(iv,l,2,2) + mult(iv) * bc(iv,nc,2,2)
              bc(iv,l,3,2) = bc(iv,l,3,2) + mult(iv) * bc(iv,nc,3,2)
              bc(iv,l,4,2) = bc(iv,l,4,2) + mult(iv) * bc(iv,nc,4,2)
              bc(iv,l,5,2) = bc(iv,l,5,2) + mult(iv) * bc(iv,nc,5,2)

              bc(iv,l,1,3) = bc(iv,l,1,3) + mult(iv) * bc(iv,nc,1,3)
              bc(iv,l,2,3) = bc(iv,l,2,3) + mult(iv) * bc(iv,nc,2,3)
              bc(iv,l,3,3) = bc(iv,l,3,3) + mult(iv) * bc(iv,nc,3,3)
              bc(iv,l,4,3) = bc(iv,l,4,3) + mult(iv) * bc(iv,nc,4,3)
              bc(iv,l,5,3) = bc(iv,l,5,3) + mult(iv) * bc(iv,nc,5,3)

              rhs(iv,i,l) = rhs(iv,i,l) + mult(iv) * rhs(iv,i,nc)
            end do

          end do

        end do  ! end of loop on nc

!.... for all columns

        p = i + 1
        r = i + 2

        do nc = 1, nblk

          j = nc + nblk
          fact(:) = one / mat(:,i,nc,j)

          do m = 1, nblk

!.... second row

            mult(:) = -mat(:,p,m,nc) * fact(:)

            do q = nc + 1, nblk
              l = q + nblk
              mat(:,p,m,q) = mat(:,p,m,q) + mult(:) * mat(:,i,nc,l)
            end do

            do iv = 1, nsys
              mat(iv,p,m, 6) = mat(iv,p,m, 6) + mult(iv) * mat(iv,i,nc,11)
              mat(iv,p,m, 7) = mat(iv,p,m, 7) + mult(iv) * mat(iv,i,nc,12)
              mat(iv,p,m, 8) = mat(iv,p,m, 8) + mult(iv) * mat(iv,i,nc,13)
              mat(iv,p,m, 9) = mat(iv,p,m, 9) + mult(iv) * mat(iv,i,nc,14)
              mat(iv,p,m,10) = mat(iv,p,m,10) + mult(iv) * mat(iv,i,nc,15)

              mat(iv,p,m,11) = mat(iv,p,m,11) + mult(iv) * bc(iv,nc,1,1)
              mat(iv,p,m,12) = mat(iv,p,m,12) + mult(iv) * bc(iv,nc,2,1)
              mat(iv,p,m,13) = mat(iv,p,m,13) + mult(iv) * bc(iv,nc,3,1)
              mat(iv,p,m,14) = mat(iv,p,m,14) + mult(iv) * bc(iv,nc,4,1)
              mat(iv,p,m,15) = mat(iv,p,m,15) + mult(iv) * bc(iv,nc,5,1)

              bc(iv,m,1,4)  = bc(iv,m,1,4)  + mult(iv) * bc(iv,nc,1,2)
              bc(iv,m,2,4)  = bc(iv,m,2,4)  + mult(iv) * bc(iv,nc,2,2)
              bc(iv,m,3,4)  = bc(iv,m,3,4)  + mult(iv) * bc(iv,nc,3,2)
              bc(iv,m,4,4)  = bc(iv,m,4,4)  + mult(iv) * bc(iv,nc,4,2)
              bc(iv,m,5,4)  = bc(iv,m,5,4)  + mult(iv) * bc(iv,nc,5,2)

              bc(iv,m,1,5)  = bc(iv,m,1,5)  + mult(iv) * bc(iv,nc,1,3)
              bc(iv,m,2,5)  = bc(iv,m,2,5)  + mult(iv) * bc(iv,nc,2,3)
              bc(iv,m,3,5)  = bc(iv,m,3,5)  + mult(iv) * bc(iv,nc,3,3)
              bc(iv,m,4,5)  = bc(iv,m,4,5)  + mult(iv) * bc(iv,nc,4,3)
              bc(iv,m,5,5)  = bc(iv,m,5,5)  + mult(iv) * bc(iv,nc,5,3)

              rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
            end do

!.... third row

            mult(:) = -bc(:,m,nc,7) * fact(:)

            do q = nc + 1, nblk
              l = q + nblk
              bc(:,m,q,7) = bc(:,m,q,7) + mult(:) * mat(:,i,nc,l)
            end do

            do iv = 1, nsys
              mat(iv,r,m, 1) = mat(iv,r,m, 1) + mult(iv) * mat(iv,i,nc,11)
              mat(iv,r,m, 2) = mat(iv,r,m, 2) + mult(iv) * mat(iv,i,nc,12)
              mat(iv,r,m, 3) = mat(iv,r,m, 3) + mult(iv) * mat(iv,i,nc,13)
              mat(iv,r,m, 4) = mat(iv,r,m, 4) + mult(iv) * mat(iv,i,nc,14)
              mat(iv,r,m, 5) = mat(iv,r,m, 5) + mult(iv) * mat(iv,i,nc,15)

              mat(iv,r,m, 6) = mat(iv,r,m, 6) + mult(iv) * bc(iv,nc,1,1)
              mat(iv,r,m, 7) = mat(iv,r,m, 7) + mult(iv) * bc(iv,nc,2,1)
              mat(iv,r,m, 8) = mat(iv,r,m, 8) + mult(iv) * bc(iv,nc,3,1)
              mat(iv,r,m, 9) = mat(iv,r,m, 9) + mult(iv) * bc(iv,nc,4,1)
              mat(iv,r,m,10) = mat(iv,r,m,10) + mult(iv) * bc(iv,nc,5,1)

              mat(iv,r,m,11) = mat(iv,r,m,11) + mult(iv) * bc(iv,nc,1,2)
              mat(iv,r,m,12) = mat(iv,r,m,12) + mult(iv) * bc(iv,nc,2,2)
              mat(iv,r,m,13) = mat(iv,r,m,13) + mult(iv) * bc(iv,nc,3,2)
              mat(iv,r,m,14) = mat(iv,r,m,14) + mult(iv) * bc(iv,nc,4,2)
              mat(iv,r,m,15) = mat(iv,r,m,15) + mult(iv) * bc(iv,nc,5,2)

              bc(iv,m,1,6)  = bc(iv,m,1,6)  + mult(iv) * bc(iv,nc,1,3)
              bc(iv,m,2,6)  = bc(iv,m,2,6)  + mult(iv) * bc(iv,nc,2,3)
              bc(iv,m,3,6)  = bc(iv,m,3,6)  + mult(iv) * bc(iv,nc,3,3)
              bc(iv,m,4,6)  = bc(iv,m,4,6)  + mult(iv) * bc(iv,nc,4,3)
              bc(iv,m,5,6)  = bc(iv,m,5,6)  + mult(iv) * bc(iv,nc,5,3)

              rhs(iv,r,m) = rhs(iv,r,m) + mult(iv) * rhs(iv,i,nc)
            end do
          end do

        end do  ! end of loop on nc

!.... second special row

        i = 2

        do nc = 1, nblk - 1

          j = nblk + nc

          do m = nc, nblk - 1
            l = m + 1
            mult(:) = -mat(:,i,l,j) / mat(:,i,nc,j)
            do q = nc + nblk + 1, nblk * 2
              mat(:,i,l,q) = mat(:,i,l,q) + mult(:) * mat(:,i,nc,q)
            end do

            do iv = 1, nsys
              mat(iv,i,l,11) = mat(iv,i,l,11) + mult(iv) * mat(iv,i,nc,11)
              mat(iv,i,l,12) = mat(iv,i,l,12) + mult(iv) * mat(iv,i,nc,12)
              mat(iv,i,l,13) = mat(iv,i,l,13) + mult(iv) * mat(iv,i,nc,13)
              mat(iv,i,l,14) = mat(iv,i,l,14) + mult(iv) * mat(iv,i,nc,14)
              mat(iv,i,l,15) = mat(iv,i,l,15) + mult(iv) * mat(iv,i,nc,15)

              bc(iv,l,1,4) = bc(iv,l,1,4) + mult(iv) * bc(iv,nc,1,4)
              bc(iv,l,2,4) = bc(iv,l,2,4) + mult(iv) * bc(iv,nc,2,4)
              bc(iv,l,3,4) = bc(iv,l,3,4) + mult(iv) * bc(iv,nc,3,4)
              bc(iv,l,4,4) = bc(iv,l,4,4) + mult(iv) * bc(iv,nc,4,4)
              bc(iv,l,5,4) = bc(iv,l,5,4) + mult(iv) * bc(iv,nc,5,4)

              bc(iv,l,1,5) = bc(iv,l,1,5) + mult(iv) * bc(iv,nc,1,5)
              bc(iv,l,2,5) = bc(iv,l,2,5) + mult(iv) * bc(iv,nc,2,5)
              bc(iv,l,3,5) = bc(iv,l,3,5) + mult(iv) * bc(iv,nc,3,5)
              bc(iv,l,4,5) = bc(iv,l,4,5) + mult(iv) * bc(iv,nc,4,5)
              bc(iv,l,5,5) = bc(iv,l,5,5) + mult(iv) * bc(iv,nc,5,5)

              rhs(iv,i,l) = rhs(iv,i,l) + mult(iv) * rhs(iv,i,nc)
            end do
          end do

        end do  ! end of loop on nc

!.... for all columns

        p  = i + 1

        do nc = 1, nblk

          j = nc + nblk
          fact(:) = one / mat(:,i,nc,j)

          do m = 1, nblk
            mult(:) = -mat(:,p,m,nc) * fact(:)

            do q = nc + 1, nblk
              l = q + nblk
              mat(:,p,m,q) = mat(:,p,m,q) + mult(:) * mat(:,i,nc,l)
            end do

            do iv = 1, nsys
              mat(iv,p,m, 6) = mat(iv,p,m, 6) + mult(iv) * mat(iv,i,nc,11)
              mat(iv,p,m, 7) = mat(iv,p,m, 7) + mult(iv) * mat(iv,i,nc,12)
              mat(iv,p,m, 8) = mat(iv,p,m, 8) + mult(iv) * mat(iv,i,nc,13)
              mat(iv,p,m, 9) = mat(iv,p,m, 9) + mult(iv) * mat(iv,i,nc,14)
              mat(iv,p,m,10) = mat(iv,p,m,10) + mult(iv) * mat(iv,i,nc,15)

              mat(iv,p,m,11) = mat(iv,p,m,11) + mult(iv) * bc(iv,nc,1,4)
              mat(iv,p,m,12) = mat(iv,p,m,12) + mult(iv) * bc(iv,nc,2,4)
              mat(iv,p,m,13) = mat(iv,p,m,13) + mult(iv) * bc(iv,nc,3,4)
              mat(iv,p,m,14) = mat(iv,p,m,14) + mult(iv) * bc(iv,nc,4,4)
              mat(iv,p,m,15) = mat(iv,p,m,15) + mult(iv) * bc(iv,nc,5,4)

              bc(iv,m,1,6)  = bc(iv,m,1,6)  + mult(iv) * bc(iv,nc,1,5)
              bc(iv,m,2,6)  = bc(iv,m,2,6)  + mult(iv) * bc(iv,nc,2,5)
              bc(iv,m,3,6)  = bc(iv,m,3,6)  + mult(iv) * bc(iv,nc,3,5)
              bc(iv,m,4,6)  = bc(iv,m,4,6)  + mult(iv) * bc(iv,nc,4,5)
              bc(iv,m,5,6)  = bc(iv,m,5,6)  + mult(iv) * bc(iv,nc,5,5)

              rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
            end do
          end do

        end do  ! end of loop on nc

!.... the third and final special row

        i = 3

        do nc = 1, nblk - 1

          j = nblk + nc

          do m = nc, nblk - 1
            l = m + 1
            mult(:) = -mat(:,i,l,j) / mat(:,i,nc,j)
            do q = nc + nblk + 1, nblk * 2
              mat(:,i,l,q) = mat(:,i,l,q) + mult(:) * mat(:,i,nc,q)
            end do

            do iv = 1, nsys
              mat(iv,i,l,11) = mat(iv,i,l,11) + mult(iv) * mat(iv,i,nc,11)
              mat(iv,i,l,12) = mat(iv,i,l,12) + mult(iv) * mat(iv,i,nc,12)
              mat(iv,i,l,13) = mat(iv,i,l,13) + mult(iv) * mat(iv,i,nc,13)
              mat(iv,i,l,14) = mat(iv,i,l,14) + mult(iv) * mat(iv,i,nc,14)
              mat(iv,i,l,15) = mat(iv,i,l,15) + mult(iv) * mat(iv,i,nc,15)

              bc(iv,l,1,6) = bc(iv,l,1,6) + mult(iv) * bc(iv,nc,1,6)
              bc(iv,l,2,6) = bc(iv,l,2,6) + mult(iv) * bc(iv,nc,2,6)
              bc(iv,l,3,6) = bc(iv,l,3,6) + mult(iv) * bc(iv,nc,3,6)
              bc(iv,l,4,6) = bc(iv,l,4,6) + mult(iv) * bc(iv,nc,4,6)
              bc(iv,l,5,6) = bc(iv,l,5,6) + mult(iv) * bc(iv,nc,5,6)

              rhs(iv,i,l) = rhs(iv,i,l) + mult(iv) * rhs(iv,i,nc)
            end do
          end do

        end do  ! end of loop on nc

!.... for all columns

        p  = i + 1

        do nc = 1, nblk

          j = nc + nblk
          fact(:) = one / mat(:,i,nc,j)

          do m = 1, nblk
            mult(:) = -mat(:,p,m,nc) * fact(:)

            do q = nc + 1, nblk
              l = q + nblk
              mat(:,p,m,q) = mat(:,p,m,q) + mult(:) * mat(:,i,nc,l)
            end do

            do iv = 1, nsys
              mat(iv,p,m, 6) = mat(iv,p,m, 6) + mult(iv) * mat(iv,i,nc,11)
              mat(iv,p,m, 7) = mat(iv,p,m, 7) + mult(iv) * mat(iv,i,nc,12)
              mat(iv,p,m, 8) = mat(iv,p,m, 8) + mult(iv) * mat(iv,i,nc,13)
              mat(iv,p,m, 9) = mat(iv,p,m, 9) + mult(iv) * mat(iv,i,nc,14)
              mat(iv,p,m,10) = mat(iv,p,m,10) + mult(iv) * mat(iv,i,nc,15)

              mat(iv,p,m,11) = mat(iv,p,m,11) + mult(iv) * bc(iv,nc,1,6)
              mat(iv,p,m,12) = mat(iv,p,m,12) + mult(iv) * bc(iv,nc,2,6)
              mat(iv,p,m,13) = mat(iv,p,m,13) + mult(iv) * bc(iv,nc,3,6)
              mat(iv,p,m,14) = mat(iv,p,m,14) + mult(iv) * bc(iv,nc,4,6)
              mat(iv,p,m,15) = mat(iv,p,m,15) + mult(iv) * bc(iv,nc,5,6)

              rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
            end do
          end do

        end do  ! end of loop on nc

!.... the rest of the matrix is a standard tridiagonal up to the other boundary

        do i = 4, n - 5

!.... do the first four columns

          do nc = 1, nblk - 1

            j = nblk + nc

            do m = nc, nblk - 1
              l = m + 1
              mult(:) = -mat(:,i,l,j) / mat(:,i,nc,j)
              do q = nc + nblk + 1, nblk * 2
                mat(:,i,l,q) = mat(:,i,l,q) + mult(:) * mat(:,i,nc,q)
              end do

              do iv = 1, nsys
                mat(iv,i,l,11) = mat(iv,i,l,11) + mult(iv) * mat(iv,i,nc,11)
                mat(iv,i,l,12) = mat(iv,i,l,12) + mult(iv) * mat(iv,i,nc,12)
                mat(iv,i,l,13) = mat(iv,i,l,13) + mult(iv) * mat(iv,i,nc,13)
                mat(iv,i,l,14) = mat(iv,i,l,14) + mult(iv) * mat(iv,i,nc,14)
                mat(iv,i,l,15) = mat(iv,i,l,15) + mult(iv) * mat(iv,i,nc,15)

                rhs(iv,i,l) = rhs(iv,i,l) + mult(iv) * rhs(iv,i,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          p  = i + 1

          do nc = 1, nblk

            j = nc + nblk
            fact(:) = one / mat(:,i,nc,j)

            do m = 1, nblk
              mult(:) = -mat(:,p,m,nc) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                mat(:,p,m,q) = mat(:,p,m,q) + mult(:) * mat(:,i,nc,l)
              end do

              do iv = 1, nsys
                mat(iv,p,m, 6) = mat(iv,p,m, 6) + mult(iv) * mat(iv,i,nc,11)
                mat(iv,p,m, 7) = mat(iv,p,m, 7) + mult(iv) * mat(iv,i,nc,12)
                mat(iv,p,m, 8) = mat(iv,p,m, 8) + mult(iv) * mat(iv,i,nc,13)
                mat(iv,p,m, 9) = mat(iv,p,m, 9) + mult(iv) * mat(iv,i,nc,14)
                mat(iv,p,m,10) = mat(iv,p,m,10) + mult(iv) * mat(iv,i,nc,15)

                rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
              end do
            end do

          end do        ! end of loop on nc

        end do          ! end of loop on i

!.... do the FIFTH to the last row

        i = n - 4

!.... first four columns

          do nc = 1, nblk - 1

            j = nblk + nc

            do m = nc, nblk - 1
              l = m + 1
              mult(:) = -mat(:,i,l,j) / mat(:,i,nc,j)
              do q = nc + nblk + 1, nblk * 2
                mat(:,i,l,q) = mat(:,i,l,q) + mult(:) * mat(:,i,nc,q)
              end do

              do iv = 1, nsys
                mat(iv,i,l,11) = mat(iv,i,l,11) + mult(iv) * mat(iv,i,nc,11)
                mat(iv,i,l,12) = mat(iv,i,l,12) + mult(iv) * mat(iv,i,nc,12)
                mat(iv,i,l,13) = mat(iv,i,l,13) + mult(iv) * mat(iv,i,nc,13)
                mat(iv,i,l,14) = mat(iv,i,l,14) + mult(iv) * mat(iv,i,nc,14)
                mat(iv,i,l,15) = mat(iv,i,l,15) + mult(iv) * mat(iv,i,nc,15)

                rhs(iv,i,l) = rhs(iv,i,l) + mult(iv) * rhs(iv,i,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          p = i + 1
          r = i + 2
          s = i + 3
          t = i + 4

          do nc = 1, nblk

            j = nc + nblk
            fact(:) = one / mat(:,i,nc,j)

            do m = 1, nblk
              mult(:) = -mat(:,p,m,nc) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                mat(:,p,m,q) = mat(:,p,m,q) + mult(:) * mat(:,i,nc,l)
              end do

              do iv = 1, nsys
                mat(iv,p,m, 6) = mat(iv,p,m, 6) + mult(iv) * mat(iv,i,nc,11)
                mat(iv,p,m, 7) = mat(iv,p,m, 7) + mult(iv) * mat(iv,i,nc,12)
                mat(iv,p,m, 8) = mat(iv,p,m, 8) + mult(iv) * mat(iv,i,nc,13)
                mat(iv,p,m, 9) = mat(iv,p,m, 9) + mult(iv) * mat(iv,i,nc,14)
                mat(iv,p,m,10) = mat(iv,p,m,10) + mult(iv) * mat(iv,i,nc,15)

                rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
              end do

!.... eliminate the boundary conditions: bc(8)

              mult(:) = -bc(:,m,nc,8) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                bc(:,m,q,8) = bc(:,m,q,8) + mult(:) * mat(:,i,nc,l)
              end do

              do iv = 1, nsys
                mat(iv,r,m, 1) = mat(iv,r,m, 1) + mult(iv) * mat(iv,i,nc,11)
                mat(iv,r,m, 2) = mat(iv,r,m, 2) + mult(iv) * mat(iv,i,nc,12)
                mat(iv,r,m, 3) = mat(iv,r,m, 3) + mult(iv) * mat(iv,i,nc,13)
                mat(iv,r,m, 4) = mat(iv,r,m, 4) + mult(iv) * mat(iv,i,nc,14)
                mat(iv,r,m, 5) = mat(iv,r,m, 5) + mult(iv) * mat(iv,i,nc,15)

                rhs(iv,r,m) = rhs(iv,r,m) + mult(iv) * rhs(iv,i,nc)
              end do

!.... eliminate the boundary conditions: bc(10)

              mult(:) = -bc(:,m,nc,10) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                bc(:,m,q,10) = bc(:,m,q,10) + mult(:) * mat(:,i,nc,l)
              end do

              do iv = 1, nsys
                bc(iv,m, 1,11) = bc(iv,m, 1,11) + mult(iv) * mat(iv,i,nc,11)
                bc(iv,m, 2,11) = bc(iv,m, 2,11) + mult(iv) * mat(iv,i,nc,12)
                bc(iv,m, 3,11) = bc(iv,m, 3,11) + mult(iv) * mat(iv,i,nc,13)
                bc(iv,m, 4,11) = bc(iv,m, 4,11) + mult(iv) * mat(iv,i,nc,14)
                bc(iv,m, 5,11) = bc(iv,m, 5,11) + mult(iv) * mat(iv,i,nc,15)

                rhs(iv,s,m) = rhs(iv,s,m) + mult(iv) * rhs(iv,i,nc)
              end do

!.... eliminate the boundary conditions: bc(12)

              mult(:) = -bc(:,m,nc,12) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                bc(:,m,q,12) = bc(:,m,q,12) + mult(:) * mat(:,i,nc,l)
              end do

              do iv = 1, nsys
                bc(iv,m, 1,13) = bc(iv,m, 1,13) + mult(iv) * mat(iv,i,nc,11)
                bc(iv,m, 2,13) = bc(iv,m, 2,13) + mult(iv) * mat(iv,i,nc,12)
                bc(iv,m, 3,13) = bc(iv,m, 3,13) + mult(iv) * mat(iv,i,nc,13)
                bc(iv,m, 4,13) = bc(iv,m, 4,13) + mult(iv) * mat(iv,i,nc,14)
                bc(iv,m, 5,13) = bc(iv,m, 5,13) + mult(iv) * mat(iv,i,nc,15)

                rhs(iv,t,m) = rhs(iv,t,m) + mult(iv) * rhs(iv,i,nc)
              end do

            end do

          end do        ! end of loop on nc

!.... do the FOURTH to the last row

        i = n - 3

!.... first four columns

          do nc = 1, nblk - 1

            j = nblk + nc

            do m = nc, nblk - 1
              l = m + 1
              mult(:) = -mat(:,i,l,j) / mat(:,i,nc,j)
              do q = nc + nblk + 1, nblk * 2
                mat(:,i,l,q) = mat(:,i,l,q) + mult(:) * mat(:,i,nc,q)
              end do

              do iv = 1, nsys
                mat(iv,i,l,11) = mat(iv,i,l,11) + mult(iv) * mat(iv,i,nc,11)
                mat(iv,i,l,12) = mat(iv,i,l,12) + mult(iv) * mat(iv,i,nc,12)
                mat(iv,i,l,13) = mat(iv,i,l,13) + mult(iv) * mat(iv,i,nc,13)
                mat(iv,i,l,14) = mat(iv,i,l,14) + mult(iv) * mat(iv,i,nc,14)
                mat(iv,i,l,15) = mat(iv,i,l,15) + mult(iv) * mat(iv,i,nc,15)

                rhs(iv,i,l) = rhs(iv,i,l) + mult(iv) * rhs(iv,i,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          p = i + 1
          r = i + 2
          s = i + 3

          do nc = 1, nblk

            j = nc + nblk
            fact(:) = one / mat(:,i,nc,j)

            do m = 1, nblk
              mult(:) = -mat(:,p,m,nc) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                mat(:,p,m,q) = mat(:,p,m,q) + mult(:) * mat(:,i,nc,l)
              end do

              do iv = 1, nsys
                mat(iv,p,m, 6) = mat(iv,p,m, 6) + mult(iv) * mat(iv,i,nc,11)
                mat(iv,p,m, 7) = mat(iv,p,m, 7) + mult(iv) * mat(iv,i,nc,12)
                mat(iv,p,m, 8) = mat(iv,p,m, 8) + mult(iv) * mat(iv,i,nc,13)
                mat(iv,p,m, 9) = mat(iv,p,m, 9) + mult(iv) * mat(iv,i,nc,14)
                mat(iv,p,m,10) = mat(iv,p,m,10) + mult(iv) * mat(iv,i,nc,15)

                rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
              end do

!.... eliminate the boundary conditions: bc(11)

              mult(:) = -bc(:,m,nc,11) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                bc(:,m,q,11) = bc(:,m,q,11) + mult(:) * mat(:,i,nc,l)
              end do

              do iv = 1, nsys
                mat(iv,r,m, 1) = mat(iv,r,m, 1) + mult(iv) * mat(iv,i,nc,11)
                mat(iv,r,m, 2) = mat(iv,r,m, 2) + mult(iv) * mat(iv,i,nc,12)
                mat(iv,r,m, 3) = mat(iv,r,m, 3) + mult(iv) * mat(iv,i,nc,13)
                mat(iv,r,m, 4) = mat(iv,r,m, 4) + mult(iv) * mat(iv,i,nc,14)
                mat(iv,r,m, 5) = mat(iv,r,m, 5) + mult(iv) * mat(iv,i,nc,15)

                rhs(iv,r,m) = rhs(iv,r,m) + mult(iv) * rhs(iv,i,nc)
              end do

!.... eliminate the boundary conditions: bc(13)

              mult(:) = -bc(:,m,nc,13) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                bc(:,m,q,13) = bc(:,m,q,13) + mult(:) * mat(:,i,nc,l)
              end do

              do iv = 1, nsys
                bc(iv,m, 1,14) = bc(iv,m, 1,14) + mult(iv) * mat(iv,i,nc,11)
                bc(iv,m, 2,14) = bc(iv,m, 2,14) + mult(iv) * mat(iv,i,nc,12)
                bc(iv,m, 3,14) = bc(iv,m, 3,14) + mult(iv) * mat(iv,i,nc,13)
                bc(iv,m, 4,14) = bc(iv,m, 4,14) + mult(iv) * mat(iv,i,nc,14)
                bc(iv,m, 5,14) = bc(iv,m, 5,14) + mult(iv) * mat(iv,i,nc,15)

                rhs(iv,s,m) = rhs(iv,s,m) + mult(iv) * rhs(iv,i,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... do the THIRD to the last row

        i = n - 2

!.... first four columns

          do nc = 1, nblk - 1

            j = nblk + nc

            do m = nc, nblk - 1
              l = m + 1
              mult(:) = -mat(:,i,l,j) / mat(:,i,nc,j)
              do q = nc + nblk + 1, nblk * 2
                mat(:,i,l,q) = mat(:,i,l,q) + mult(:) * mat(:,i,nc,q)
              end do

              do iv = 1, nsys
                mat(iv,i,l,11) = mat(iv,i,l,11) + mult(iv) * mat(iv,i,nc,11)
                mat(iv,i,l,12) = mat(iv,i,l,12) + mult(iv) * mat(iv,i,nc,12)
                mat(iv,i,l,13) = mat(iv,i,l,13) + mult(iv) * mat(iv,i,nc,13)
                mat(iv,i,l,14) = mat(iv,i,l,14) + mult(iv) * mat(iv,i,nc,14)
                mat(iv,i,l,15) = mat(iv,i,l,15) + mult(iv) * mat(iv,i,nc,15)

                bc(iv,l, 1,9) = bc(iv,l, 1,9) + mult(iv) * bc(iv,nc,1,9)
                bc(iv,l, 2,9) = bc(iv,l, 2,9) + mult(iv) * bc(iv,nc,2,9)
                bc(iv,l, 3,9) = bc(iv,l, 3,9) + mult(iv) * bc(iv,nc,3,9)
                bc(iv,l, 4,9) = bc(iv,l, 4,9) + mult(iv) * bc(iv,nc,4,9)
                bc(iv,l, 5,9) = bc(iv,l, 5,9) + mult(iv) * bc(iv,nc,5,9)

                rhs(iv,i,l) = rhs(iv,i,l) + mult(iv) * rhs(iv,i,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          p = i + 1
          r = i + 2

          do nc = 1, nblk

            j = nc + nblk
            fact(:) = one / mat(:,i,nc,j)

            do m = 1, nblk
              mult(:) = -mat(:,p,m,nc) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                mat(:,p,m,q) = mat(:,p,m,q) + mult(:) * mat(:,i,nc,l)
              end do

              do iv = 1, nsys
                mat(iv,p,m, 6) = mat(iv,p,m, 6) + mult(iv) * mat(iv,i,nc,11)
                mat(iv,p,m, 7) = mat(iv,p,m, 7) + mult(iv) * mat(iv,i,nc,12)
                mat(iv,p,m, 8) = mat(iv,p,m, 8) + mult(iv) * mat(iv,i,nc,13)
                mat(iv,p,m, 9) = mat(iv,p,m, 9) + mult(iv) * mat(iv,i,nc,14)
                mat(iv,p,m,10) = mat(iv,p,m,10) + mult(iv) * mat(iv,i,nc,15)

                mat(iv,p,m,11) = mat(iv,p,m,11) + mult(iv) * bc(iv,nc,1,9)
                mat(iv,p,m,12) = mat(iv,p,m,12) + mult(iv) * bc(iv,nc,2,9)
                mat(iv,p,m,13) = mat(iv,p,m,13) + mult(iv) * bc(iv,nc,3,9)
                mat(iv,p,m,14) = mat(iv,p,m,14) + mult(iv) * bc(iv,nc,4,9)
                mat(iv,p,m,15) = mat(iv,p,m,15) + mult(iv) * bc(iv,nc,5,9)

                rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
              end do

!.... eliminate the boundary condition:  bc(14)

              mult(:) = -bc(:,m,nc,14) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                bc(:,m,q,14) = bc(:,m,q,14) + mult(:) * mat(:,i,nc,l)
              end do

              do iv = 1, nsys
                mat(iv,r,m, 1) = mat(iv,r,m, 1) + mult(iv) * mat(iv,i,nc,11)
                mat(iv,r,m, 2) = mat(iv,r,m, 2) + mult(iv) * mat(iv,i,nc,12)
                mat(iv,r,m, 3) = mat(iv,r,m, 3) + mult(iv) * mat(iv,i,nc,13)
                mat(iv,r,m, 4) = mat(iv,r,m, 4) + mult(iv) * mat(iv,i,nc,14)
                mat(iv,r,m, 5) = mat(iv,r,m, 5) + mult(iv) * mat(iv,i,nc,15)

                mat(iv,r,m, 6) = mat(iv,r,m, 6) + mult(iv) * bc(iv,nc,1,9)
                mat(iv,r,m, 7) = mat(iv,r,m, 7) + mult(iv) * bc(iv,nc,2,9)
                mat(iv,r,m, 8) = mat(iv,r,m, 8) + mult(iv) * bc(iv,nc,3,9)
                mat(iv,r,m, 9) = mat(iv,r,m, 9) + mult(iv) * bc(iv,nc,4,9)
                mat(iv,r,m,10) = mat(iv,r,m,10) + mult(iv) * bc(iv,nc,5,9)

                rhs(iv,r,m) = rhs(iv,r,m) + mult(iv) * rhs(iv,i,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... do the SECOND to the last row (which is normal tridiagonal)

        i = n - 1

!.... first four columns

          do nc = 1, nblk - 1

            j = nblk + nc

            do m = nc, nblk - 1
              l = m + 1
              mult(:) = -mat(:,i,l,j) / mat(:,i,nc,j)
              do q = nc + nblk + 1, nblk * 2
                mat(:,i,l,q) = mat(:,i,l,q) + mult(:) * mat(:,i,nc,q)
              end do

              do iv = 1, nsys
                mat(iv,i,l,11) = mat(iv,i,l,11) + mult(iv) * mat(iv,i,nc,11)
                mat(iv,i,l,12) = mat(iv,i,l,12) + mult(iv) * mat(iv,i,nc,12)
                mat(iv,i,l,13) = mat(iv,i,l,13) + mult(iv) * mat(iv,i,nc,13)
                mat(iv,i,l,14) = mat(iv,i,l,14) + mult(iv) * mat(iv,i,nc,14)
                mat(iv,i,l,15) = mat(iv,i,l,15) + mult(iv) * mat(iv,i,nc,15)

                rhs(iv,i,l) = rhs(iv,i,l) + mult(iv) * rhs(iv,i,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          p = i + 1

          do nc = 1, nblk

            j = nc + nblk
            fact(:) = one / mat(:,i,nc,j)

            do m = 1, nblk
              mult(:) = -mat(:,p,m,nc) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                mat(:,p,m,q) = mat(:,p,m,q) + mult(:) * mat(:,i,nc,l)
              end do

              do iv = 1, nsys
                mat(iv,p,m, 6) = mat(iv,p,m, 6) + mult(iv) * mat(iv,i,nc,11)
                mat(iv,p,m, 7) = mat(iv,p,m, 7) + mult(iv) * mat(iv,i,nc,12)
                mat(iv,p,m, 8) = mat(iv,p,m, 8) + mult(iv) * mat(iv,i,nc,13)
                mat(iv,p,m, 9) = mat(iv,p,m, 9) + mult(iv) * mat(iv,i,nc,14)
                mat(iv,p,m,10) = mat(iv,p,m,10) + mult(iv) * mat(iv,i,nc,15)

                rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... do the last row

        i = n

        do nc = 1, nblk - 1

          j = nblk + nc

          do m = nc, nblk - 1
            l = m + 1
            mult(:) = -mat(:,i,l,j) / mat(:,i,nc,j)
            do q = nc + nblk + 1, nblk * 2
              mat(:,i,l,q) = mat(:,i,l,q) + mult(:) * mat(:,i,nc,q)
            end do
            rhs(:,i,l) = rhs(:,i,l) + mult(:) * rhs(:,i,nc)
          end do

        end do  ! end of loop on nc

!=============================================================================!
!                   B A C K W A R D   S U B S T I T U T I O N
!=============================================================================!

!.... do the LAST row first

        i = n

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(:,i,m) = rhs(:,i,m) - rhs(:,i,q) * mat(:,i,m,l)
          end do
          rhs(:,i,m) = rhs(:,i,m) / mat(:,i,m,j)
        end do

!.... do the SECOND to the last row (normal row)

        i = n - 1
        p = i + 1

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(:,i,m) = rhs(:,i,m) - rhs(:,i,q) * mat(:,i,m,l)
          end do

          do iv = 1, nsys
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,1) * mat(iv,i,m,11)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,2) * mat(iv,i,m,12)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,3) * mat(iv,i,m,13)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,4) * mat(iv,i,m,14)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,5) * mat(iv,i,m,15)

            rhs(iv,i,m) = rhs(iv,i,m) / mat(iv,i,m,j)
          end do
        end do

!.... do the THIRD to the last row

        i = n - 2
        p = i + 1
        r = i + 2

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(:,i,m) = rhs(:,i,m) - rhs(:,i,q) * mat(:,i,m,l)
          end do

          do iv = 1, nsys
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,1) * mat(iv,i,m,11)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,2) * mat(iv,i,m,12)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,3) * mat(iv,i,m,13)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,4) * mat(iv,i,m,14)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,5) * mat(iv,i,m,15)

            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,1) * bc(iv,m,1,9)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,2) * bc(iv,m,2,9)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,3) * bc(iv,m,3,9)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,4) * bc(iv,m,4,9)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,5) * bc(iv,m,5,9)

            rhs(iv,i,m) = rhs(iv,i,m) / mat(iv,i,m,j)
          end do

        end do

!.... now do the rest of the rows in reverse order upto the boundary

        do i = n - 3, 4, -1

          p = i + 1

          do m = nblk, 1, -1
            j = m + nblk
            do q = m+1, nblk
              l = q + nblk
              rhs(:,i,m) = rhs(:,i,m) - rhs(:,i,q) * mat(:,i,m,l)
            end do

            do iv = 1, nsys
              rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,1) * mat(iv,i,m,11)
              rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,2) * mat(iv,i,m,12)
              rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,3) * mat(iv,i,m,13)
              rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,4) * mat(iv,i,m,14)
              rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,5) * mat(iv,i,m,15)

              rhs(iv,i,m) = rhs(iv,i,m) / mat(iv,i,m,j)
            end do
          end do

        end do

!.... now do the boundary rows

        i = 3

        p = i + 1
        r = i + 2

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(:,i,m) = rhs(:,i,m) - rhs(:,i,q) * mat(:,i,m,l)
          end do

          do iv = 1, nsys
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,1) * mat(iv,i,m,11)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,2) * mat(iv,i,m,12)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,3) * mat(iv,i,m,13)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,4) * mat(iv,i,m,14)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,5) * mat(iv,i,m,15)

            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,1) * bc(iv,m,1,6)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,2) * bc(iv,m,2,6)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,3) * bc(iv,m,3,6)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,4) * bc(iv,m,4,6)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,5) * bc(iv,m,5,6)

            rhs(iv,i,m) = rhs(iv,i,m) / mat(iv,i,m,j)
          end do
        end do

        i = 2

        p = i + 1
        r = i + 2
        s = i + 3

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(:,i,m) = rhs(:,i,m) - rhs(:,i,q) * mat(:,i,m,l)
          end do

          do iv = 1, nsys
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,1) * mat(iv,i,m,11)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,2) * mat(iv,i,m,12)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,3) * mat(iv,i,m,13)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,4) * mat(iv,i,m,14)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,5) * mat(iv,i,m,15)

            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,1) * bc(iv,m,1,4)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,2) * bc(iv,m,2,4)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,3) * bc(iv,m,3,4)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,4) * bc(iv,m,4,4)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,5) * bc(iv,m,5,4)

            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,s,1) * bc(iv,m,1,5)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,s,2) * bc(iv,m,2,5)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,s,3) * bc(iv,m,3,5)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,s,4) * bc(iv,m,4,5)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,s,5) * bc(iv,m,5,5)

            rhs(iv,i,m) = rhs(iv,i,m) / mat(iv,i,m,j)
          end do
        end do

        i = 1

        p = i + 1
        r = i + 2
        s = i + 3
        t = i + 4

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(:,i,m) = rhs(:,i,m) - rhs(:,i,q) * mat(:,i,m,l)
          end do

          do iv = 1, nsys
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,1) * mat(iv,i,m,11)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,2) * mat(iv,i,m,12)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,3) * mat(iv,i,m,13)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,4) * mat(iv,i,m,14)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,5) * mat(iv,i,m,15)

            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,1) * bc(iv,m,1,1)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,2) * bc(iv,m,2,1)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,3) * bc(iv,m,3,1)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,4) * bc(iv,m,4,1)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,5) * bc(iv,m,5,1)

            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,s,1) * bc(iv,m,1,2)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,s,2) * bc(iv,m,2,2)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,s,3) * bc(iv,m,3,2)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,s,4) * bc(iv,m,4,2)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,s,5) * bc(iv,m,5,2)

            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,t,1) * bc(iv,m,1,3)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,t,2) * bc(iv,m,2,3)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,t,3) * bc(iv,m,3,3)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,t,4) * bc(iv,m,4,3)
            rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,t,5) * bc(iv,m,5,3)

            rhs(iv,i,m) = rhs(iv,i,m) / mat(iv,i,m,j)
          end do
        end do
!=============================================================================!
        return
        end


      SUBROUTINE KTRBSC (IOPT)
C
C     BASIC BENDING TRIANGLE  ELEMENT ROUTINE
C
C     IOPT = 0   IMPLIES DO COMPLETE BASIC BENDING TRIANGLE.
C                INSERTING THREE (6X6) MATRICES FOR A PIVOT POINT.
C     IOPT = 1   IMPLIES COMPUTE ONLY THE NINE (3X3)MATRICES
C                WHICH FORM THE 9X9 K SUPER U - MATRIX.
C     IOPT = 2   SAME AS IOPT = 1, BUT SAVE H-INVERSE AND S
C
C     CALLS FROM THIS ROUTINE ARE MADE TO -
C
C           MAT    - MATERIAL DATA ROUTINE
C           SMA1B  - INSERTION ROUTINE
C           TRANSD - DOUBLE PRECISION TRANSFORMATION SUPPLIER
C           INVERD - DOUBLE PRECISION INVERSE ROUTINE
C           GMMATD - DOUBLE PRECISION MATRIX MULTIPLY AND TRANSPOSE
C           MESAGE - ERROR MESSAGE WRITER
C
      INTEGER          SUBSCA,SUBSCB
      DOUBLE PRECISION A,E,XSUBB,TEMP,XSUBC,D,YSUBC,XCYC,XCSQ,DETERM,
     1                 YCSQ,XBSQ,G2X2,TITE,TJTE,S,TI,J2X2,AREA,XBAR,
     2                 YBAR,PX2,PY2,PXY2,XBAR3,YBAR2,YBAR3,PROD9,TEMP9,
     3                 G
      DIMENSION        D(9),G2X2(4),J2X2(4),S(18),ECPT(25),G(9),
     1                 TJTE(18),TITE(18),TI(9)
      COMMON /CONDAS/  CONSTS(5)
      COMMON /SMA1IO/  DUM1(10),IFKGG,DUM2(1),IF4GG,DUM3(23)
      COMMON /SMA1CL/  IOPT4,K4GGSW,NPVT,DUMCL(7),LINK(10),IDETCK,
     1                 DODET,NOGO
      COMMON /MATIN /  MATID,INFLAG,ELTEMP,STRESS,SINTH,COSTH
      COMMON /MATOUT/  G11,G12,G13,G22,G23,G33,RHO,ALPHA1,ALPHA2,ALP12,
     1                 T SUB 0, G SUB E, SIGTEN, SIGCOM, SIGSHE,
     2                 G2X211, G2X212, G2X222
      COMMON /SMA1ET/  NECPT(1),NGRID(3),ANGLE,MATID1,EYE,MATID2,T2,FMU,
     1                 Z11,Z22,DUMMY1,X1,Y1,Z1,DUMMY2,X2,Y2,Z2,DUMMY3,
     2                 X3,Y3,Z3,DUMB(76)
      COMMON /SMA1DP/  A(225),PROD9(9),TEMP9(9),XSUBB,XSUBC,YSUBC,E(18),
     1                 TEMP,XBAR,AREA,XCSQ,YBAR2,YCSQ,YBAR,XBSQ,PX2,
     2                 XCYC,PY2,PXY2,XBAR3,YBAR3,DETERM,NSIZED,
     3                 DUMDUM(4),NPIVOT,THETA,NSUBC,ISING,SUBSCA,SUBSCB,
     4                 NBEGIN,DUMMY(30)
      EQUIVALENCE      (CONSTS(4),DEGRA),(D(1),G(1),A(79)),
     1                 (ECPT(1),NECPT(1)),(G2X2(1),A(88)),
     2                 (TJTE(1),A(100)),(TITE(1),S(1),A(82)),
     3                 (J2X2(1),A(92)),(TI(1),A(118))
C
C     ECPT LIST FOR BASIC BENDING TRIANGLE             NAME IN
C                                                      THIS
C     ECPT                                             ROUTINE    TYPE
C     =====================================            ========  =======
C     ECPT( 1) = ELEMENT ID                            NECPT(1)  INTEGER
C     ECPT( 2) = GRID POINT A                          NGRID(1)  INTEGER
C     ECPT( 3) = GRID POINT B                          NGRID(2)  INTEGER
C     ECPT( 4) = GRID POINT C                          NGRID(3)  INTEGER
C     ECPT( 5) = THETA = ANGLE OF MATERIAL             ANGLE     REAL
C     ECPT( 6) = MATERIAL ID 1                         MATID1    INTEGER
C     ECPT( 7) = I = MOMENT OF INERTIA                 EYE       REAL
C     ECPT( 8) = MATERIAL ID 2                         MATID2    INTEGER
C     ECPT( 9) = T2                                    T2        REAL
C     ECPT(10) = NON-STRUCTURAL-MASS                   FMU       REAL
C     ECPT(11) = Z1                                    Z11       REAL
C     ECPT(12) = Z2                                    Z22       REAL
C     ECPT(13) = COORD. SYSTEM ID 1                    NECPT(13) INTEGER
C     ECPT(14) = X1                                    X1        REAL
C     ECPT(15) = Y1                                    Y1        REAL
C     ECPT(16) = Z1                                    Z1        REAL
C     ECPT(17) = COORD. SYSTEM ID 2                    NECPT(17) INTEGER
C     ECPT(18) = X2                                    X2        REAL
C     ECPT(19) = Y2                                    Y2        REAL
C     ECPT(20) = Z2                                    Z2        REAL
C     ECPT(21) = COORD. SYSTEM ID 3                    NECPT(21) INTEGER
C     ECPT(22) = X3                                    X3        REAL
C     ECPT(23) = Y3                                    Y3        REAL
C     ECPT(24) = Z3                                    Z3        REAL
C     ECPT(25) = ELEMENT TEMPERATURE                   ELTEMP    REAL
C
      NTYPE = 0
      IF (IOPT .GT. 0) NTYPE = 1
      IF (NTYPE .EQ. 1) GO TO 455
      ELTEMP = ECPT(25)
C
C     SET UP  I, J, K VECTORS STORING AS FOLLOWS AND ALSO CALCULATE
C     X-SUB-B, X-SUB-C, AND Y-SUB-C.
C
C     E(11), E(14), E(17) WILL BE THE I-VECTOR.
C     E(12), E(15), E(18) WILL BE THE J-VECTOR.
C     E( 1), E( 4), E( 7) WILL BE THE K-VECTOR.
C
C     FIND I-VECTOR = RSUBB - RUBA (NON-NORMALIZED)
C
      E(11) = DBLE(X2) - DBLE(X1)
      E(14) = DBLE(Y2) - DBLE(Y1)
      E(17) = DBLE(Z2) - DBLE(Z1)
C
C     FIND LENGTH = X-SUB-B COOR. IN ELEMENT SYSTEM
C
      XSUBB = DSQRT(E(11)**2 + E(14)**2 + E(17)**2)
      IF (XSUBB .GT. 1.0D-06) GO TO 20
      CALL MESAGE (30,31,ECPT(1))
C
C     SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO
C     ACCUMULATE
C
      NOGO = 1
      RETURN
C
C  20 NORMALIZE I-VECTOR WITH X-SUB-B
C
   20 E(11) = E(11)/XSUBB
      E(14) = E(14)/XSUBB
      E(17) = E(17)/XSUBB
C
C     TAKE RSUBC - RSUBA AND STORE TEMPORARILY IN E(2), E(5), E(8)
C
      E(2) = DBLE(X3) - DBLE(X1)
      E(5) = DBLE(Y3) - DBLE(Y1)
      E(8) = DBLE(Z3) - DBLE(Z1)
C
C     X-SUB-C = I . (RSUBC - RSUBA), THUS
C
      XSUBC = E(11)*E(2) + E(14)*E(5) + E(17)*E(8)
C
C     CROSSING I-VECTOR TO (RSUBC - RSUBA) GIVES THE K-VECTOR
C     (NON-NORMALIZED)
C
      E(1) = E(14)*E( 8) - E( 5)*E(17)
      E(4) = E( 2)*E(17) - E(11)*E( 8)
      E(7) = E(11)*E( 5) - E( 2)*E(14)
C
C     FIND LENGTH = Y-SUB-C COOR. IN ELEMENT SYSTEM
C
      YSUBC = DSQRT(E(1)**2 + E(4)**2 + E(7)**2)
      IF (YSUBC .GT. 1.0D-06) GO TO 25
      CALL MESAGE (30,32,ECPT(1))
C
C     SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO
C     ACCUMULATE
C
      NOGO = 1
      RETURN
C
C     NORMALIZE K-VECTOR WITH Y-SUB-C
C
   25 E(1) = E(1)/YSUBC
      E(4) = E(4)/YSUBC
      E(7) = E(7)/YSUBC
C
C     NOW HAVING I AND K VECTORS GET -- J = K CROSS I
C
      E(12) = E( 4)*E(17) - E(14)*E( 7)
      E(15) = E(11)*E( 7) - E( 1)*E(17)
      E(18) = E( 1)*E(14) - E(11)*E( 4)
C
C     NORMALIZE J-VECTOR FOR COMPUTER EXACTNESS JUST TO MAKE SURE
C
      TEMP = DSQRT(E(12)**2 + E(15)**2 + E(18)**2)
      E(12) = E(12)/TEMP
      E(15) = E(15)/TEMP
      E(18) = E(18)/TEMP
      E( 2) = 0.0D0
      E( 3) = 0.0D0
      E( 5) = 0.0D0
      E( 6) = 0.0D0
      E( 8) = 0.0D0
      E( 9) = 0.0D0
      E(10) = 0.0D0
      E(13) = 0.0D0
      E(16) = 0.0D0
C
C     CONVERT ANGLE FROM DEGREES TO RADIANS STORING IN THETA.
C
      THETA = ANGLE*DEGRA
      SINTH = SIN(THETA)
      COSTH = COS(THETA)
      IF (ABS(SINTH) .LT. 1.0E-06) SINTH = 0.0E0
C
C     SETTING UP G MATRIX
C
  455 INFLAG = 2
      MATID  = MATID1
      CALL MAT (ECPT(1))
C
C     FILL G-MATRIX WITH OUTPUT FROM MAT ROUTINE
C
      G(1) = G11
      G(2) = G12
      G(3) = G13
      G(4) = G12
      G(5) = G22
      G(6) = G23
      G(7) = G13
      G(8) = G23
      G(9) = G33
C
C     COMPUTATION OF D = I.G-MATRIX (EYE IS INPUT FROM THE ECPT)
C
      DO 90 I = 1,9
   90 D(I) = G(I)*DBLE(EYE)
C
      AREA = XSUBB*YSUBC/2.0D0
      XBAR =(XSUBB+XSUBC)/3.0D0
      YBAR = YSUBC/3.0D0
C
      XCSQ = XSUBC**2
      YCSQ = YSUBC**2
      XBSQ = XSUBB**2
      XCYC = XSUBC*YSUBC
      PX2 = (XBSQ+XSUBB*XSUBC+XCSQ)/6.0D0
      PY2 = YCSQ/6.0D0
      PXY2= YSUBC*(XSUBB+2.0D0*XSUBC)/12.0D0
      XBAR3 = 3.0D0*XBAR
      YBAR3 = 3.0D0*YBAR
      YBAR2 = 2.0D0*YBAR
C
C                 X
C     FILL THE  (K ) MATRIX STORING IN  A(1) THRU A(36)
C
      A( 1) = D( 1)
      A( 2) = D( 3)
      A( 3) = D( 2)
      A( 4) = D( 1)*XBAR3
      A( 5) = D( 2)*XBAR + YBAR2*D(3)
      A( 6) = D( 2)*YBAR3
      A( 7) = A( 2)
      A( 8) = D( 9)
      A( 9) = D( 6)
      A(10) = D( 3)*XBAR3
      A(11) = D( 6)*XBAR + YBAR2*D(9)
      A(12) = D( 6)*YBAR3
      A(13) = A( 3)
      A(14) = A( 9)
      A(15) = D( 5)
      A(16) = D( 2)*XBAR3
      A(17) = D( 5)*XBAR + YBAR2*D(6)
      A(18) = D( 5)*YBAR3
      A(19) = A( 4)
      A(20) = A(10)
      A(21) = A(16)
      A(22) = D( 1)*9.0D0*PX2
      A(23) = D( 2)*3.0D0*PX2 + 6.0D0*PXY2*D(3)
      A(24) = D( 2)*9.0D0*PXY2
      A(25) = A( 5)
      A(26) = A(11)
      A(27) = A(17)
      A(28) = A(23)
      A(29) = D( 5)*PX2 + 4.0D0*PXY2*D(6) + 4.0D0*PY2*D(9)
      A(30) = D( 5)*3.0D0*PXY2 + 6.0D0*PY2*D(6)
      A(31) = A( 6)
      A(32) = A(12)
      A(33) = A(18)
      A(34) = A(24)
      A(35) = A(30)
      A(36) = D( 5)*9.0D0*PY2
      TEMP  = 4.0D0*AREA
      DO 70 I = 1,36
   70 A(I)  = A(I)*TEMP
C
C     F1LL  (HBAR) MATRIX STORING AT A(37) THRU A(72)
C
      DO 130 I = 37,72
  130 A(I) = 0.0D0
C
      A(37) = XBSQ
      A(40) = XBSQ*XSUBB
      A(44) = XSUBB
      A(49) =-2.0D0*XSUBB
      A(52) =-3.0D0*XBSQ
      A(55) = XCSQ
      A(56) = XCYC
      A(57) = YCSQ
      A(58) = XCSQ*XSUBC
      A(59) = YCSQ*XSUBC
      A(60) = YCSQ*YSUBC
      A(62) = XSUBC
      A(63) = YSUBC*2.0D0
      A(65) = XCYC *2.0D0
      A(66) = YCSQ *3.0D0
      A(67) =-2.0D0*XSUBC
      A(68) =-YSUBC
      A(70) =-3.0D0*XCSQ
      A(71) =-YCSQ
C
      IF (T2 .EQ. 0.0E0) GO TO 500
C
C     ALL OF THE FOLLOWING OPERATIONS THROUGH STATEMENT LABEL 500
C     ARE NECESSARY IF T2 IS NON-ZERO.
C
C     GET THE G2X2 MATRIX
C
      MATID  = MATID2
      INFLAG = 3
      CALL MAT (ECPT(1))
      IF (G2X211.EQ.0. .AND. G2X212.EQ.0. .AND. G2X222.EQ.0.) GO TO 500
      G2X2(1) = G2X211*T2
      G2X2(2) = G2X212*T2
      G2X2(3) = G2X212*T2
      G2X2(4) = G2X222*T2
C
      DETERM  = G2X2(1)*G2X2(4) - G2X2(3)*G2X2(2)
      J2X2(1) = G2X2(4)/DETERM
      J2X2(2) =-G2X2(2)/DETERM
      J2X2(3) =-G2X2(3)/DETERM
      J2X2(4) = G2X2(1)/DETERM
C
C     (H  ) IS PARTITIONED INTO A LEFT AND RIGHT PORTION AND ONLY THE
C       YQ  RIGHT PORTION IS COMPUTED AND USED AS A  (2X3). THE LEFT
C           2X3 PORTION IS NULL.  THE RIGHT PORTION WILL BE STORED AT
C           A(73) THRU A(78) UNTIL NOT NEEDED ANY FURTHER.
C
      TEMP  =  2.0D0*D(2) + 4.0D0*D(9)
      A(73) = -6.0D0*(J2X2(1)*D(1) + J2X2(2)*D(3))
      A(74) = -J2X2(1)*TEMP - 6.0D0*J2X2(2)*D(6)
      A(75) = -6.0D0*(J2X2(1)*D(6) + J2X2(2)*D(5))
      A(76) = -6.0D0*(J2X2(2)*D(1) + J2X2(4)*D(3))
      A(77) = -J2X2(2)*TEMP - 6.0D0*J2X2(4)*D(6)
      A(78) = -6.0D0*(J2X2(2)*D(6) + J2X2(4)*D(5))
C
C     THE ABOVE 6 ELEMENTS NOW REPRESENT THE (H  ) MATRIX (2X3)
C                                              YQ
C
C     NOW FORMING  PRODUCT (G2X2)(H  ) AND STORING AS AN INTERMEDIATE
C     STEP.                        YQ
C
C
      CALL GMMATD (G2X2(1),2,2,0, A(73),2,3,0, A(79))
C
C                                                               Y
C     WITH LAST PRODUCT  FORM  LOWER RIGHT 3 X 3 PARTITION OF (K )
C
C              Y                   T
C     THUS   (K ) PARTITION = (H  ) (LAST PRODUCT)   STORE AT A(85)
C                               YQ
C
      CALL GMMATD (A(73),2,3,1, A(79),2,3,0, A(85))
C
C                                                     X
C     NOW ADD THE 9 ELEMENTS OF THIS 3X3 PORTION TO (K )
C     PER STEP 5 PAGE -16- MS-17                            Y
C     MULTIPLY IN AREA AT SAME TIME WHICH WAS LEFT OUT OF (K ) ABOVE.
C
      DO 60 I = 1,3
      A(I+21) = A(I+21) + A(I+84)*AREA
      A(I+27) = A(I+27) + A(I+87)*AREA
   60 A(I+33) = A(I+33) + A(I+90)*AREA
C
C     ADD TO 6 OF THE (HBAR) ELEMENTS THE RESULT OF (H  )(H  )
C                                                     UY   YQ
C     THE PRODUCT IS FORMED DIRECTLY IN THE ADDITION PROCESS BELOW.
C     NO (H  ) MATRIX IS ACTUALLY COMPUTED DIRECTLY.
C          UY
C
C     THE FOLLOWING IS THEN PER STEPS 6 AND 7 PAGE -16- MS-17.
C
      DO 75 I = 1,3
      A(I+39) = A(I+39) + XSUBB*A(I+72)
   75 A(I+57) = A(I+57) + XSUBC*A(I+72) + YSUBC*A(I+75)
C
C     THIS ENDS ADDED COMPUTATION FOR CASE OF T2 NOT ZERO
C
  500 CONTINUE
C
C     AT THIS POINT INVERT  (H) WHICH IS STORED AT A(37) THRU A(72)
C     STORE INVERSE BACK IN A(37) THRU A(72)
C     NO NEED TO COMPUTE DETERMINANT SINCE IT IS NOT USED SUBSEQUENTLY.
C
      ISING = -1
      CALL INVERD (6,A(37),6,A(73),0,DETERM,ISING,A(79))
C
C     CHECK TO SEE IF H WAS SINGULAR
C
      IF (ISING .NE. 2) GO TO 440
C
C     ISING = 2 IMPLIES SINGULAR MATRIX THUS ERROR CONDITION.
C
      CALL MESAGE (30,33,ECPT(1))
C
C     SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO
C     ACCUMULATE
C
      NOGO = 1
      RETURN
C
C              Q   -1
C 440 FORM   (K )(H  )  AND STORE AT  A(73) THRU A(108)
C
C                 X                     Q
C     NOTE THAT (K ) AT THIS POINT IS (K )
C
  440 CALL GMMATD (A(1),6,6,0, A(37),6,6,0, A(73))
C
C                    -1 T
C     FORM(K  ) = (H  ) (LAST PRODUCT) STORE AT A(109) THRU A(144)
C            II
C
      CALL GMMATD (A(37),6,6,1, A(73),6,6,0, A(109))
C
C     FILL S-MATRIX EQUIVALENCED TO A(82)  (S IS  6X3)
C
      IF (IOPT.NE.2) GO TO 700
C
C     SAVE H-INVERSE TO BE USED BY TRIANGULAR PLATE ROUTINE.
C
      DO 710 I = 37,72
  710 A(I+108) = A(I)
C
  700 S( 1) = 1.0D0
      S( 2) = 0.0D0
      S( 3) =-XSUBB
      S( 4) = 0.0D0
      S( 5) = 1.0D0
      S( 6) = 0.0D0
      S( 7) = 0.0D0
      S( 8) = 0.0D0
      S( 9) = 1.0D0
      S(10) = 1.0D0
      S(11) = YSUBC
      S(12) =-XSUBC
      S(13) = 0.0D0
      S(14) = 1.0D0
      S(15) = 0.0D0
      S(16) = 0.0D0
      S(17) = 0.0D0
      S(18) = 1.0D0
C
C                   T
C     FORM   K   = K   = -K   S  STORING AT A(46)   (K   IS 6X3)
C             IA    AI     II                         IA
C
      CALL GMMATD (A(109),6,6,0, S(1),6,3,0, A(46))
C
C     THIS PRODUCT IS MULTIPLIED BY SCALER -1 BELOW.
C
C                    T
C          (K  ) = (S )(-K  )
C            AA           IA
C
C     NOTE K    HAS NOT BEEN MULTIPLIED ABOVE BY -1, THUS IGNORE MINUS
C           IA                                                   HERE.
C
      CALL GMMATD (S(1),6,3,1, A(46),6,3,0, A(1))
C
C     NOW MULTIPLY  K   BY SCALER (-1)
C                    IA
C
      DO 190 I = 46,63
  190 A(I) = -A(I)
C
C     AT THIS POINT, STORED BY ROWS ARE
C
C                  K     (6X6) AT A(109) THRU A(144)
C                   II
C
C                  K     (6,3) AT  A(46) THRU A(63)
C                   IA
C
C                  K     (3X3) AT A(1) THRU A(9)
C                   AA
C
C     ARRANGE NINE 3X3 MATRICES OF K SUPER U
C
      DO 600 I = 28,36
  600 A(I) = A(I+18)
       A(10) = A(46)
       A(11) = A(49)
       A(12) = A(52)
       A(13) = A(47)
       A(14) = A(50)
       A(15) = A(53)
       A(16) = A(48)
       A(17) = A(51)
       A(18) = A(54)
       A(19) = A(55)
       A(20) = A(58)
       A(21) = A(61)
       A(22) = A(56)
       A(23) = A(59)
       A(24) = A(62)
       A(25) = A(57)
       A(26) = A(60)
       A(27) = A(63)
       A(37) = A(109)
       A(38) = A(110)
       A(39) = A(111)
       A(40) = A(115)
       A(41) = A(116)
       A(42) = A(117)
       A(43) = A(121)
       A(44) = A(122)
       A(45) = A(123)
       A(46) = A(112)
       A(47) = A(113)
       A(48) = A(114)
       A(49) = A(118)
       A(50) = A(119)
       A(51) = A(120)
       A(52) = A(124)
       A(53) = A(125)
       A(54) = A(126)
       A(64) = A(127)
       A(65) = A(128)
       A(66) = A(129)
       A(67) = A(133)
       A(68) = A(134)
       A(69) = A(135)
       A(70) = A(139)
       A(71) = A(140)
       A(72) = A(141)
       A(73) = A(130)
       A(74) = A(131)
       A(75) = A(132)
       A(76) = A(136)
       A(77) = A(137)
       A(78) = A(138)
       A(79) = A(142)
       A(80) = A(143)
       A(81) = A(144)
      IF (NTYPE .EQ. 1) RETURN
C
      DO 95 I = 1,3
      IF (NGRID(I) .NE. NPVT) GO TO 95
      NPIVOT = I
      GO TO 170
   95 CONTINUE
C
C     ERROR IF FALL THRU ABOVE LOOP
C
      CALL MESAGE (-30,34,ECPT(1))
C
C 170 AT THIS POINT START ASSEMBLY OF 3 6X6 MATRICES FOR I = PIVOT,
C     AND J =1,2,3  IN THE FOLLOWING EQUATION.
C
C                  T         U     T
C        (K  ) = (T  ) (E) (K  ) (E ) (T )
C          IJ      I         IJ         J
C
C
C     FIRST GET THE PRODUCT APPLICABLE TO ALL 3 K  .
C                                                IJ
C                  T
C              = (T  ) (E)    A 6X3 MATRIX.
C                  I
C
C     CHECK TO SEE IF TI-MATRIX IS NEEDED
C     IF THE CSID IS ZERO FOR THE PIVOT POINT SKIP TRANSFORMATION.
C
  170 IF (NECPT(4*NPIVOT+9) .EQ. 0) GO TO 250
C
C     GET  TI AND MULTIPLY WITH E TO FILL TITE (THE COMMON PRODUCT)
C
      CALL TRANSD (NECPT(4*NPIVOT+9),TI)
C
C     TI IS EQUIVALENCED TO A(118) AND IS 3X3.
C
C     FORM TITE (UPPER AND LOWER) OK OK OK
C
      CALL GMMATD (TI(1),3,3,1,  E(1),3,3,0,  TITE(1))
      CALL GMMATD (TI(1),3,3,1, E(10),3,3,0, TITE(10))
C
      GO TO 280
C
C 250 COMING HERE IMPLIES TI NOT USED.
C     JUST SET TITE = E MATRIX
C
  250 DO 260 I = 1,18
  260 TITE(I) = E(I)
C
C                                                 T
C 280 AT THIS POINT COMMON PRODUCT IS COMPLETE =(T  )(E)  STORED IN TITE
C                                                 I
C
C     THE PIVOT I IS NPIVOT
  280 NPT1 = 1
      IF (NPIVOT .EQ. 1 ) NPT1 = 28
C
C     THE ABOVE SETS A POINTER, NPT1, TO POINT TO 18 FREE DOUBLE PREC.
C     CORE LOCATIONS IN THE A-ARRAY FOR STORAGE OF THE FOLLOWING
C     SUB-PRODUCT.
C                     U   T
C                  (K  )(E )(T )
C                    IJ       J
C
C
C     LOOP THRU FOR THE 3 - 6X6 K   ARRAYS.
C                                IJ
      DO 800 J = 1,3
C                          T
C     TAKE SUB PRODUCT = (E )(T )..     STORE IN TJTE MATRIX
C                              J
C
C     NOTE.. THE TRANSPOSE OF THE ABOVE IS BEING FOUND AND USED,
C                          T
C                      = (T  )(E),  AND STORED IN TJTE-MATRIX
C                          J        EQUIVALENCED TO A(100)
C
C
C     CHECK TO SEE IF TRANSFORMATION IS NEEDED.
C     IF NOT SKIP TO 850
C
      IF (NECPT(4*J+9) .EQ. 0) GO TO 850
C
      CALL TRANSD (NECPT(4*J+9),TI)
      CALL GMMATD (TI(1),3,3,1, E(1),3,3,0, TJTE(1))
      CALL GMMATD (TI(1),3,3,1, E(10),3,3,0, TJTE(10))
      GO TO 880
C
C 850 COMING HERE IF TRANSFORMATION NOT USED
C
C 850 SET TJTE = E
  850 DO 860 I = 1,18
  860 TJTE(I) = E(I)
C
C           T       T
C 880   ( (E )(T ) )  IS COMPLETE AND STORED BY ROWS IN TJTE-MATRIX.
C               J
C                     U   T
C     NOW FORM,    (K  )(E )(T ), STORING AT A(NPT1)
C                    IJ       J
C
C     NPT1 =  1  IF PIVOT IS GRID PT. 2 OR 3
C     NPT1 = 28  IF PIVOT IS GRID PT. 1
C                                  U
C     TO COMPUTE ABOVE USE 3X3   K
C                                 (NPIVOT,J)
C     COMPUTE POINTER TO THIS 3X3.
C
  880 NPT2 = 27*NPIVOT + 9*J - 35
C
      CALL GMMATD (A(NPT2),3,3,0, TJTE,6,3,1, A(NPT1))
C
C
C 950 AT THIS POINT,
C                      U    T
C                    (K  )(E )(T )  IS STORED AT A(NPT1), (3X6).
C                      IJ       J
C
C     AND,             T
C                    (T  )(E)      IS STORED AT TITE(1) = A(82)  (6X3)
C                      I
C
C     FORMING FINAL PRODUCT, AND STORING AT A(100) THE 6X6.
C
      CALL GMMATD (TITE(1),6,3,0, A(NPT1),3,6,0, A(100))
C
C     SHIP TO SMA1B
C
      CALL SMA1B (A(100),NECPT(J+1),-1,IFKGG,0.0D0)
      TEMP = G SUB E
      IF (IOPT4) 801,800,801
  801 IF (GSUBE) 802,800,802
  802 CALL SMA1B (A(100),NECPT(J+1),-1,IF4GG,TEMP)
      K4GGSW = 1
C
  800 CONTINUE
C
      RETURN
      END


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


subroutine medicaid_provision()
    use nrtype; use dimensions; use structural_p2; use structural_p1;use MD_reform
    implicit none
    integer::h_l,f_l,z_l,it
    real(SP)::g,R_max,R_min,u_g,R_g

        !Find hours of care and consumption floor provided by Medicaid
        !if no care from relatives to get to the floor for the different shocks
        do h_l=1,clusters
            !guess of max budget
            it=0
            g=1.0_sp
    1       R_max=(30.0_sp+p_fc*2.0_sp*365.0_sp*2.0_sp)*g
            call solve_intratemporal(p_fc,R_max,h_l,l_ic(1,h_l),u_g,l_bar(h_l),c_bar(h_l))
            if (u_g<u_bar_no_f(h_l) .and. it<2000) then
                g=g*2.0_sp
                it=it+1
                go to 1
            elseif (it==2000) then
                print*, 'Problem in medicaid provision'
            end if
            R_min=0.0_sp
            !Bisection
            it=0
    2       R_g=(R_max+R_min)/2.0_sp
            call solve_intratemporal(p_fc,R_g,h_l,l_ic(1,h_l),u_g,l_bar(h_l),c_bar(h_l))
            if (abs((u_g-u_bar_no_f(h_l))/u_bar_no_f(h_l))>0.0001_sp .and. it<2000) then
                if (u_g>u_bar_no_f(h_l)) then
                    R_max=R_g
                else
                    R_min=R_g
                end if
                it=it+1
                go to 2
            elseif (it==2000) then
                print*, 'medicaid provision not converged'
            end if
        end do

        if (ind_or==0) then
            l_bar=l_bar*1.20d0
        end if
        !Utility of medicaid for individuals
        do h_l=1,clusters; do f_l=1,f_t
            if (h_l==1) then

                u_bar(h_l,f_l)=c_bar(h_l)**(1.0_sp-sigma)/(1.0_sp-sigma)
            else
                if (subs_p==0.0_sp)then
                    u_bar(h_l,f_l)= c_bar(h_l)**(1.0_sp-sigma)/(1.0_sp-sigma)+mu(h_l)*(l_bar(h_l)**share_p+l_ic(f_l,h_l)**(1.0_sp-share_p))**(1.0_sp-nu)/(1.0_sp-nu)
                else
                    u_bar(h_l,f_l)= c_bar(h_l)**(1.0_sp-sigma)/(1.0_sp-sigma)+mu(h_l)*((share_p*l_bar(h_l)**subs_p+(1.0_sp-share_p)*l_ic(f_l,h_l)**subs_p)**(1.0_sp/subs_p))**(1.0_sp-nu)/(1.0_sp-nu)
                end if
            end if
        end do;end do

end subroutine


      program Ising2d_equilibrium_f77_withfunc
      use utility_m
      use benchmark_m
      implicit real(8) (a-h,o-z)
      parameter(nx=51, ny=50, N=nx*ny, noff=nx, nall=N+2*noff)
      parameter(ilb=-noff+1, iub=ilb+nall-1)
      parameter(nkbt=50, dkbt_beg=2.6d0, dkbt_end=2.0d0)
      parameter(mcs_relx=500000, mcs_smpl=500000)
      dimension Ising(ilb:iub)
      dimension exparr(-8:8)
      dimension dkbts(nkbt), dmagne(nkbt), energy(nkbt)
      dimension rnd(N)
      type(benchmark_t) :: bm
      write(6, '(a,i0)'     ) "# N = ", N
      write(6, '(a,i0)'     ) "# MCS(relaxation) = ", mcs_relx
      write(6, '(a,i0)'     ) "# MCS(sampling)   = ", mcs_smpl
      write(0, '(3(a, i0))' ) "nx", nx, " ny", ny
      write(0, '(a, f30.18)') "method: METROPOLIS"
      bm = benchmark_t()
c initialize dkbts, Ising, energy, dmagne.
      call linspace(nkbt, dkbt_beg, dkbt_end, dkbts)

      call random_number(rnd)
      call init_Ising(ilb, iub, N, noff, rnd, Ising)
c$$$      call print_Ising(ilb, iub, nx, ny, Ising)

c update norishiro.
      call norishiro(ilb, iub, n, noff, Ising)
c update Ising in each temperatures.
      exparr = 1.0d0
      energy = 0.0d0
      magne  = 0.0d0
      call bm%stamp("start update")
      do k = 1, nkbt
         dbeta = 1/dkbts(k)
         write(0, '(a, i7, es23.15)') "iterate: ", k, dkbts(k)
c        Initialize exparr.
         call init_exparr(dbeta, exparr)
c        relax Ising with Metropolis.
         do j = 1, mcs_relx
c           update Ising with checkerboard pattern.
            call Metropolis(ilb, iub, N, nx, noff, rnd, exparr, Ising)
         end do ! end j (1:mcs_relx)
c        relax Ising with Metropolis and calculate parameters.
         dm = 0.0d0
         e  = 0.0d0
         do j = 1, mcs_smpl
c           update Ising with checkerboard pattern.
            call Metropolis(ilb, iub, N, nx, noff, rnd, exparr, Ising)
            call calc_energy_magne(ilb, iub, nx, N, e_tmp, dm_tmp,Ising)
            e  = e  + e_tmp
            dm = dm + abs(dm_tmp)
         end do ! end j (1:mcs_smpl)
         dmagne(k) = dm / mcs_smpl
         energy(k) = e  / mcs_smpl
      end do ! end k (1:nkbt)
      call bm%stamp("end update")
c print parameters.
      write(6, '(a)') "# temperature, magne, energy"
      do k = 1, nkbt
         write(6, '(i0,a,i0," ",i0," ",*(es20.12))')
     &        nx, "x", ny,
     &        k, dkbts(k), dmagne(k), energy(k)
      end do
      call bm%dump()
      call destroy_benchmark_t(bm)
c print all spins including norishiro
c$$$      call print_Ising(ilb, iub, nx, ny, Ising)
      end program Ising2d_equilibrium_f77_withfunc
c
      subroutine linspace(n, beg, end, arr)
      implicit real(8) (a-h,o-z)
      dimension arr(n)
c internal division point.
      do i = 1, n
         arr(i) =
     &        ( (n-1-i+1)*beg
     &        + (i-1)    *end ) / (n-1)
      end do
      end subroutine
c
      subroutine init_Ising(ilb, iub, n, noff, rnd, Ising)
      implicit real(8) (a-h,o-z)
      dimension rnd(n), Ising(ilb:iub)
      do i = 1, N
         if (rnd(i) .lt. 0.5d0) then
            Ising(i) = +1
         else
            Ising(i) = -1
         end if
      end do
      call norishiro(ilb, iub, n, noff, Ising)
      end subroutine
c
      subroutine init_exparr(dbeta, exparr)
      implicit real(8) (a-h,o-z)
      dimension exparr(-8:8)
      do i = 1, 8
         exparr(i) = exp(-dbeta*i)
      end do
      end subroutine
c
      subroutine Metropolis(ilb, iub, n, nx, noff, rnd, exparr, Ising)
      implicit real(8) (a-h,o-z)
      dimension rnd(n), exparr(-8:8), Ising(ilb:iub)
      call random_number(rnd)
      do is = 1, 2
         do i = is, n, 2
            ide = 2*Ising(i)*
     &           (Ising(i+1)+Ising(i-1)+Ising(i+nx)+Ising(i-nx))
            if (rnd(i) .lt. exparr(ide)) Ising(i) = -Ising(i)
         end do
c        update norishiro.
         call norishiro(ilb, iub, n, noff, Ising)
      end do
      end subroutine
c
      subroutine norishiro(ilb, iub, n, noff, Ising)
      implicit real(8) (a-h,o-z)
      dimension Ising(ilb:iub)
      do i = 1, noff
         Ising(i-noff) = Ising(i+n-noff)
         Ising(i+n)    = Ising(i)
      end do
      end subroutine
c
      subroutine print_Ising(ilb, iub, nx, ny, Ising)
      implicit real(8) (a-h,o-z)
      dimension Ising(ilb:iub)
      do j = 0, ny+1
         write(0, '(i8, a)', advance="NO") j, ": "
         do i = 1, nx
            write(0, '(i3)', advance="NO") Ising((j-1)*nx+i)
         end do
         write(0, *)
      end do
      end subroutine
c
      subroutine calc_energy_magne(ilb, iub, nx, N, e_tmp, dm_tmp,Ising)
      implicit real(8) (a-h,o-z)
      dimension Ising(ilb:iub)
      magne   = 0
      ienergy = 0
      do i = 1, N
         ienergy = ienergy - Ising(i)*(Ising(i+1)+Ising(i+nx))
         magne   = magne   + Ising(i)
      end do
      e_tmp  = 1.0d0*ienergy / N
      dm_tmp = 1.0d0*magne   / N
      end subroutine