*DK rzbrickg
      subroutine rzbrickg(cgeom , icount ,
     *  nx , ny , nz ,
     *  xi , yi , zi ,
     *  xf , yf , zf ,
     *  ixz , iyz , izz ,
     *  ixratio , iyratio , izratio ,
     *  xrz , yrz , zrz ,
     *  ipxic, ipyic, ipzic)
C
C#######################################################################
C
C      PURPOSE -
C
C     this routine is used to ratio zone a region of space
C
C
C     FORMAT: RZ/igeom/nx,ny,nz/xi,yi,zi/xf,yf,zf                      &
C     FORMAT:         /ixz/iyz/izz/ixratio/iyratio/izratio/xrz/yrz/zr
C
C
C
C      INPUT ARGUMENTS -
C
C      igeom = 0(or xyz) ==> x , y , z cartesian geometry
C      igeom = 1(or rtz) ==> r , theta , z ==> cylindrical geometry
C      igeom = 2(or rtp) ==> r , theta , phi  ==> spherical geometry
C
C
C
C      nx -- IS THE NUMBER OF NODES (POINTS) IN THE X-DIRECTION.
C               > 0 ==> GENERATE POINTS IN A LINED UP FASHION.
C               < 0 ==> GENERARE POINTS IN A STAGGERED PATTEREN.
C      ny -- IS THE NUMBER OF NODES (POINTS) IN THE Y-DIRECTION.
C               > 0 ==> GENERATE POINTS IN A LINED UP FASHION.
C               < 0 ==> GENERARE POINTS IN A STAGGERED PATTEREN.
C      nz -- IS THE NUMBER OF NODES (POINTS) IN THE Z-DIRECTION.
C               > 0 ==> GENERATE POINTS IN A LINED UP FASHION.
C               < 0 ==> GENERARE POINTS IN A STAGGERED PATTEREN.
C
C
C                   cartesian  cylinderical       spherical
C                     x-y-z      r-theta-z       r-theta-phi
C                   *********  ************      ***********
C
C                          NOTE: ANGLES ARE IN DEGREES
C
C      xi -- minimum    x            r               r
C      yi -- minimum    y      theta(xy-plane)   theta(z-axis)
C      zi -- minimum    z            z           phi(x-axis,xy-plane)
C
C
C      xf -- maximum    x            r               r
C      yf -- maximum    y      theta(xy-plane)   theta(z-axis)
C      zf -- maximum    z            z           phi(x-axis,xy-plane)
C
C
C
C
C     THE REFLECTIVE OR ABSOLUTE ZONING SWITCHES:
C         THESE SWITCH INDICATE WHETHER POINTS ARE GENERATED AT
C            CELL CENTERES (REFLECTIVE POINTS) OR AT CELL VERTICES
C            (ABSOLUTE POINTS).
C
C         ixz = 0 ==> MIN AND MAX X-VALULE ARE USED AS REFLECTIVE
C                        BEGINNING AND ENDDING POINTS.
C         ixz = 1 ==> MIN AND MAX X-VALUES ARE USED AS ABSOLUTE
C                        BEGINNING AND ENDDING POINTS.
C
C         iyz = 0 ==> MIN AND MAX Y-VALULE ARE USED AS REFLECTIVE
C                        BEGINNING AND ENDDING POINTS.
C         iyz = 1 ==> MIN AND MAX Y-VALUES ARE USED AS ABSOLUTE
C                        BEGINNING AND ENDDING POINTS.
C
C         izz = 0 ==> MIN AND MAX Z-VALULE ARE USED AS REFLECTIVE
C                        BEGINNING AND ENDDING POINTS.
C         izz = 1 ==> MIN AND MAX Z-VALUES ARE USED AS ABSOLUTE
C                        BEGINNING AND ENDDING POINTS.
C
C     THE RATIO ZONING SWITCHES.
C
C         ixratio = 0  ==> NO RATIO ZONING IN THE X-DIRECTION.
C         ixratio = 1  ==> RATIO ZONING IN THE X-DIRECTION.
C
C         iyratio = 0  ==> NO RATIO ZONING IN THE Y-DIRECTION.
C         iyratio = 1  ==> RATIO ZONING IN THE Y-DIRECTION.
C
C         izratio = 0  ==> NO RATION ZONING IN THE Z-DIRECTION.
C         izratio = 1  ==> RATIO ZONING IN THE Z-DIRECTION.
C
C
C     THE RATIO ZONE VALUES (I.E., THE ZONING INCREASES OR DECREASES
C                                  BY THIS PERCENTAGE FROM ZONE TO
C                                  ZONE.)
C
C        xrz = THE RATIO ZONING VALUE FOR THE X-DIRECTION.
C        yrz = THE RATIO ZONING VALUE FOR THE Y-DIRECTION.
C        zrz = THE RATIO ZONING VALUE FOR THE Z-DIRECTION.
C
C      OUTPUT ARGUMENTS -
C
C         NONE
C
C
C      CHANGE HISTORY -
C
C         HT0106AC-87, HT0404AB-87, JP0803AA-87, HT1023AA-87
C         HT1117AA-87
C
C        $Log: rzbrickg.f,v $
C        Revision 2.00  2007/11/09 20:04:02  spchu
C        Import to CVS
C
C
CPVCS
CPVCS       Rev 1.21   02 Oct 2007 12:40:28   spchu
CPVCS    original version
C
C#######################################################################
C
      implicit real*8 (a-h, o-z)
      include 'chydro.h'
C
C
      character cgeom*(*)
C
      pointer (ipxic, xic)
      pointer (ipyic, yic)
      pointer (ipzic, zic)
      dimension xic(10000000), yic(10000000), zic(10000000)
C
C#######################################################################
C
C
C     ******************************************************************
C
C     CONVERT ANGLES TO RADIANS.
C
      degtorad=pie/180.0
      radtodeg=180.0/pie
C
C     ******************************************************************
C
C     TO ALLOW FOR AN "OLD" GENERATION OPTION WE CAN SPECIFY THE
C        GENERATION COORDINATE SYSTEM BY NUMBER (1=XYZ, 2=RTZ, 3=RTP).
C
      igeom2=0
      if(cgeom(1:3).eq.'xyz') igeom2=1
      if(cgeom(1:3).eq.'rtz') igeom2=2
      if(cgeom(1:3).eq.'rtp') igeom2=3
C
C     ******************************************************************
C
C     FOR CYLINDRICAL COORDINATES WE CONVERT THE THETA ANGLE FROM
C        DEGREES TO RADIANS.
C
      if(igeom2.eq.2) then
         yi=yi*pie/180.0
         yf=yf*pie/180.0
      endif
C
C     ******************************************************************
C
C     FOR SPHERICAL COORDINATES WE CONVERT THE THETA AND PHI ANGLES FROM
C        DEGREES TO RADIANS.
C
      if(igeom2.eq.3) then
         yi=yi*pie/180.0
         yf=yf*pie/180.0
         zi=zi*pie/180.0
         zf=zf*pie/180.0
      endif
C
C     ******************************************************************
C
C     FILTER THE ZONING FLAGS AND MULTIPLIES TO ALLOW ONLY THE
C        PROPER VALUES.
C
      if(ixz.ne.0.and.ixz.ne.1) ixz=0
      if(iyz.ne.0.and.iyz.ne.1) iyz=0
      if(izz.ne.0.and.izz.ne.1) izz=0
      if(xrz.le.0.0) xrz=1.0
      if(yrz.le.0.0) yrz=1.0
      if(zrz.le.0.0) zrz=1.0
      if(ixratio.eq.0) xrz=1.0
      if(iyratio.eq.0) yrz=1.0
      if(izratio.eq.0) zrz=1.0

C
C     ******************************************************************
C
C     SETUP THE STARTING VALUE AND DELTA FOR THE X-DIRECTION.
C
      nx1=iabs(nx)
      if(ixz.eq.0) then
         if(nx1.eq.1) then
            rsum=0.0
         else
            rsum=0.0
            do 10 i1=1,nx1-1
               rsum=rsum+xrz**float(i1)
 10         continue
         endif
         rsumx=0.5+rsum+0.5*xrz**float(nx1+1)
         dxrel1=(xf-xi)/rsumx
         dx1=dxrel1
         x11=xi-0.5*dx1
      else
         if(nx1.lt.2) nx1=2
         if(nx1.eq.2) then
            rsum=0.0
         else
            rsum=0.0
            do 15 i1=1,nx1-2
               rsum=rsum+xrz**float(i1)
 15         continue
         endif
         rsumx=1.0+rsum
         dxabs1=(xf-xi)/rsumx
         dx1=dxabs1/xrz
         x11=xi-dx1
      endif
      x12=x11+0.5*dx1
C
C     ******************************************************************
C
C     SETUP THE STARTING VALUE AND DELTA FOR THE Y-DIRECTION.
C
      ny1=iabs(ny)
      if(iyz.eq.0) then
         if(ny1.eq.1) then
            rsum=0.0
         else
            rsum=0.0
            do 20 i1=1,ny1-1
               rsum=rsum+yrz**float(i1)
 20         continue
         endif
         rsumy=0.5+rsum+0.5*yrz**float(ny1+1)
         dyrel1=(yf-yi)/rsumy
         dy1=dyrel1
         y11=yi-0.5*dy1
      else
         if(ny1.lt.2) ny1=2
         if(ny1.eq.2) then
            rsum=0.0
         else
            rsum=0.0
            do 25 i1=1,ny1-2
               rsum=rsum+yrz**float(i1)
 25         continue
         endif
         rsumy=1.0+rsum
         dyabs1=(yf-yi)/rsumy
         dy1=dyabs1/yrz
         y11=yi-dy1
      endif
      y12=y11+0.5*dy1
C
C     ******************************************************************
C
C     SETUP THE STARTING VALUE AND DELTA FOR THE Z-DIRECTION.
C
      nz1=iabs(nz)
      if(izz.eq.0) then
         if(nz1.eq.1) then
            rsum=0.0
         else
            rsum=0.0
            do 30 i1=1,nz1-1
               rsum=rsum+zrz**float(i1)
 30         continue
         endif
         rsumz=0.5+rsum+0.5*zrz**float(nz1+1)
         dzrel1=(zf-zi)/rsumz
         dz1=dzrel1
         z11=zi-0.5*dz1
      else
         if(nz1.lt.2) nz1=2
         if(nz1.eq.2) then
            rsum=0.0
         else
            rsum=0.0
            do 35 i1=1,nz1-2
               rsum=rsum+zrz**float(i1)
 35         continue
         endif
         rsumz=1.0+rsum
         dzabs1=(zf-zi)/rsumz
         dz1=dzabs1/zrz
         z11=zi-dz1
      endif
      z12=z11+0.5*dz1
C
C     ******************************************************************
C
C     NOW GO TO THE CORRECT GEOMETRY ROUTINE.
C
      goto (100 , 200 , 300) igeom2
      goto 9999
C
C     ******************************************************************
C
C     DEFINE THE XYZ- COORDINATE SETUP. THE GENERATION ORDER IS:
C        1) INNER  LOOP IS FOR THE X-COORDINATES.
C        2) MIDDLE LOOP IS FOR THE Y-COORDINATES.
C        3) OUTER  LOOP IS FOR THE Z-COORDINATES.
C
 100  continue
      z1=z11
      z2=z12
      dz=dz1
      do 110 iz=1,nz1
         z1=z1+dz
         if(ny.lt.0) then
            if(mod(iz,2).ne.0) then
               ny2=ny1
               y1=y11
            else
               ny2=ny1-1
               y1=y12
            endif
         else
            ny2=ny1
            y1=y11
         endif
         dy=dy1
         do 120 iy=1,ny2
            y1=y1+dy
            if(nx.lt.0) then
               if(mod(iy,2).ne.0) then
                  nx2=nx1
                  x1=x11
               else
                  nx2=nx1-1
                  x1=x12
               endif
            else
               nx2=nx1
               x1=x11
            endif
            dx=dx1
            do 130 ix=1,nx2
               x1=x1+dx
               icount=icount+1
C*****         call flgrid(2,icount,x1,y1,z1,0.0,0.0,0.0)
               xic(icount)=x1
               yic(icount)=y1
               zic(icount)=z1
               dx=cvmgtr(dx*xrz,dx,ixratio.eq.1)
 130        continue
            dy=cvmgtr(dy*yrz,dy,iyratio.eq.1)
 120     continue
         dz=cvmgtr(dz*zrz,dz,izratio.eq.1)
 110  continue
      goto 9999
C
C     ******************************************************************
C
C     DEFINE THE RTZ-COORDINATE SETUP FOR CYLINDRICAL GEOMETRY. THE
C        GENERATION ORDER IS:
C           1) INNER  LOOP IS FOR THE RADIAL-COORDINATES.
C           2) MIDDLE LOOP IS FOR THE  THETA-COORDINATES.
C           3) OUTER  LOOP IS FOR THE      Z-COORDINATES.
C
 200  continue
      ri=xi
      rf=xf
      thi=yi
      thf=yf
      r11 =x11
      r12 =x12
      dr1 =dx1
      th11=y11
      th12=y12
      dth1=dy1
      z1  =z11
      z2  =z12
      dz  =dz1
      do 210 iz=1,nz1
         z1=z1+dz
         if(ny.lt.0) then
            if(mod(iz,2).ne.0) then
               ny2=ny1
               th1=th11
            else
               ny2=ny1-1
               if(thf.eq.2.0*pie) nx2=nx1
               th1=th12
            endif
         else
            ny2=ny1
            th1=th11
         endif
         dth=dth1
         do 220 iy=1,ny2
            th1=th1+dth
            if(nx.lt.0) then
               if(mod(iy,2).ne.0) then
                  nx2=nx1
                  r1=r11
               else
                  nx2=nx1-1
                  r1=r12
               endif
            else
               nx2=nx1
               r1=r11
            endif
            dr=dr1
            do 230 ix=1,nx2
               r1=r1+dr
               x1=r1*cos(th1)
               y1=r1*sin(th1)
               icount=icount+1
C*****         call flgrid(2,icount,x1,y1,z1,0.0,0.0,0.0)
               xic(icount)=x1
               yic(icount)=y1
               zic(icount)=z1
               dr=cvmgtr(dr*xrz,dr,ixratio.eq.1)
 230        continue
            dth=cvmgtr(dth*yrz,dth,iyratio.eq.1)
 220     continue
         dz=cvmgtr(dz*zrz,dz,izratio.eq.1)
 210  continue
      goto 9999
C
C     ******************************************************************
C
C     DEFINE THE RTP-COORDINATE SETUP FOR SPHERICAL GEOMETRY. THE
C        GENERATION ORDER IS:
C           1) INNER  LOOP IS FOR THE RADIAL-COORDINATES.
C           2) MIDDLE LOOP IS FOR THE  THETA-COORDINATES.
C           3) OUTER  LOOP IS FOR THE    PHI-COORDINATES.
C
 300  continue
      ri=xi
      rf=xf
      thi=yi
      thf=yf
      phi=zi
      phf=zf
      r11 =x11
      dr1 =dx1
      th11=y11
      th12=y12
      dth1=dy1
      ph11=z11
      ph12=z12
      ph1=z11
      dph1=dz1
      r1=r11
      r2=r12
      dph=dph1
      do 310 iz=1,nz1
         ph1=ph1+dph
         if(ny.lt.0) then
            if(mod(ix,2).ne.0) then
               ny2=ny1
               th1=th11
            else
               ny2=ny1-1
               if(thf.eq.2.0*pie) ny2=ny1
               th1=th12
            endif
         else
            ny2=ny1
            th1=th11
         endif
         dth=dth1
         do 320 iy=1,ny2
            th1=th1+dth
            if(nx.lt.0) then
               if(mod(iy,2).ne.0) then
                  nx2=nx1
                  r1=r11
               else
                  nx2=nx1-1
C*****************if(phf.eq.2.0*pie) nz2=nz1
                  r1=r12
               endif
            else
               nx2=nx1
               r1=r11
            endif
            dr=dr1
            do 330 ix=1,nx2
               r1=r1+dr
               x1=r1*sin(th1)*cos(ph1)
               y1=r1*sin(th1)*sin(ph1)
               z1=r1*cos(th1)
               icount=icount+1
C*****         call flgrid(2,icount,x1,y1,z1,0.0,0.0,0.0)
               xic(icount)=x1
               yic(icount)=y1
               zic(icount)=z1
               dr=cvmgtr(dr*xrz,dr,ixratio.eq.1)
 330        continue
            dth=cvmgtr(dth*yrz,dth,iyratio.eq.1)
 320     continue
         dph=cvmgtr(dph*zrz,dph,izratio.eq.1)
 310  continue
C
C     ******************************************************************
C
C     SET UP THE USUAL CFT IMMUNE STATEMENT 9999 IN CASE DDT IS NEEDED.
C
      goto 9999
 9999 continue
C
C     ******************************************************************
C
      return
      end


c     comment section
c
c     fm099
c
c     this routine tests various mathematical functions where both the
c     function type and arguments are real.  the real variables and
c     constants contain both positive and negative values.  the
c     functions tested in fm099 include
c
c                                                     type of
c       function                    name       argument     function
c       ----------------            ----        --------    --------
c         exponential               exp        real         real
c         natural logarithm         alog       real         real
c         common logarithm          alog10     real         real
c         square root               sqrt       real         real
c         trigonometric sine        sin        real         real
c         trigonometric cosine      cos        real         real
c         hyperbolic tangent        tanh       real         real
c         arctangent                atan       real         real
c                                   atan2      real         real
c
c      references
c        american national standard programming language fortran,
c              x3.9-1978
c
c        section 8.7, external statement
c        section 15.5.2, function reference
c
c
c      **********************************************************
c
c         a compiler validation system for the fortran language
c     based on specifications as defined in american national standard
c     programming language fortran x3.9-1978, has been developed by the
c     federal cobol compiler testing service.  the fortran compiler
c     validation system (fcvs) consists of audit routines, their related
c     data, and an executive system.  each audit routine is a fortran
c     program, subprogram or function which includes tests of specific
c     language elements and supporting procedures indicating the result
c     of executing these tests.
c
c         this particular program/subprogram/function contains features
c     found only in the subset as defined in x3.9-1978.
c
c         suggestions and comments should be forwarded to -
c
c                  department of the navy
c                  federal cobol compiler testing service
c                  washington, d.c.  20376
c
c      **********************************************************
c
c
c
c     initialization section
c
c     initialize constants
c      **************
c     i01 contains the logical unit number for the card reader.
      i01 = 5
c     i02 contains the logical unit number for the printer.
      i02 = 6
c     system environment section
c
cx010    this card is replaced by contents of fexec x-010 control card.
c     the cx010 card is for overriding the program default i01 = 5
c     (unit number for card reader).
cx011    this card is replaced by contents of fexec x-011 control card.
c     the cx011 card is for systems which require additional
c     fortran statements for files associated with cx010 above.
c
cx020    this card is replaced by contents of fexec x-020 control card.
c     the cx020 card is for overriding the program default i02 = 6
c     (unit number for printer).
cx021    this card is replaced by contents of fexec x-021 control card.
c     the cx021 card is for systems which require additional
c     fortran statements for files associated with cx020 above.
c
      ivpass=0
      ivfail=0
      ivdele=0
      iczero=0
c
c     write page headers
      write (i02,90000)
      write (i02,90001)
      write (i02,90002)
      write (i02, 90002)
      write (i02,90003)
      write (i02,90002)
      write (i02,90004)
      write (i02,90002)
      write (i02,90011)
      write (i02,90002)
      write (i02,90002)
      write (i02,90005)
      write (i02,90006)
      write (i02,90002)
c
c     test section
c
c     test 939 through test 942 contain function tests for exponential
c     functions where the argument and function are real
c
      ivtnum = 939
c
c      ****  test 939  ****
c
      if (iczero) 39390, 9390, 39390
 9390 continue
      rvon01 = 0.0
      rvcomp = exp (rvon01)
      go to 49390
39390 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49390, 9401, 49390
49390 if (rvcomp - 0.95) 29390,19390,49391
49391 if (rvcomp - 1.05) 19390,19390,29390
19390 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9401
29390 ivfail = ivfail + 1
      rvcorr = 1.00
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9401 continue
      ivtnum = 940
c
c      ****  test 940  ****
c
      if (iczero) 39400, 9400, 39400
 9400 continue
      rvcomp = exp (0.5)
      go to 49400
39400 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49400, 9411, 49400
49400 if (rvcomp - 1.60) 29400,19400,49401
49401 if (rvcomp - 1.70) 19400,19400,29400
19400 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9411
29400 ivfail = ivfail + 1
      rvcorr = 1.65
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9411 continue
      ivtnum = 941
c
c      ****  test 941  ****
c
      if (iczero) 39410, 9410, 39410
 9410 continue
      rvon01 = .1e1
      rvcomp = exp (rvon01)
      go to 49410
39410 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49410, 9421, 49410
49410 if (rvcomp - 2.67) 29410,19410,49411
49411 if (rvcomp - 2.77) 19410,19410,29410
19410 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9421
29410 ivfail = ivfail + 1
      rvcorr = 2.72
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9421 continue
      ivtnum = 942
c
c      ****  test 942  ****
c
      if (iczero) 39420, 9420, 39420
 9420 continue
      rvon01 = -1.0
      rvcomp = exp (rvon01)
      go to 49420
39420 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49420, 9431, 49420
49420 if (rvcomp - 0.363) 29420,19420,49421
49421 if (rvcomp - 0.373) 19420,19420,29420
19420 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9431
29420 ivfail = ivfail + 1
      rvcorr = 0.368
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9431 continue
c
c     test 943 through test 945 contain function tests for natural
c     logarithm functions where the argument and function are real
c
      ivtnum = 943
c
c      ****  test 943  ****
c
      if (iczero) 39430, 9430, 39430
 9430 continue
      rvon01 = 5e1
      rvcomp = alog (rvon01)
      go to 49430
39430 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49430, 9441, 49430
49430 if (rvcomp - 3.9115) 29430,19430,49431
49431 if (rvcomp - 3.9125) 19430,19430,29430
19430 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9441
29430 ivfail = ivfail + 1
      rvcorr = 3.9120
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9441 continue
      ivtnum = 944
c
c      ****  test 944  ****
c
      if (iczero) 39440, 9440, 39440
 9440 continue
      rvon01 = 1.0
      rvcomp = alog (rvon01)
      go to 49440
39440 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49440, 9451, 49440
49440 if (rvcomp + .00005) 29440,19440,49441
49441 if (rvcomp - .00005) 19440,19440,29440
19440 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9451
29440 ivfail = ivfail + 1
      rvcorr = 0.00000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9451 continue
      ivtnum = 945
c
c      ****  test 945  ****
c
      if (iczero) 39450, 9450, 39450
 9450 continue
      rvcomp = alog (2.0)
      go to 49450
39450 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49450, 9461, 49450
49450 if (rvcomp - 0.688) 29450,19450,49451
49451 if (rvcomp - 0.698) 19450,19450,29450
19450 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9461
29450 ivfail = ivfail + 1
      rvcorr = 0.693
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9461 continue
c
c     test 946 through test 948 contain function tests for common
c     logarithm functions where the argument and function are real
c
      ivtnum = 946
c
c      ****  test 946  ****
c
      if (iczero) 39460, 9460, 39460
 9460 continue
      rvon01 = 2e2
      rvcomp = alog10 (rvon01)
      go to 49460
39460 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49460, 9471, 49460
49460 if (rvcomp - 2.296) 29460,19460,49461
49461 if (rvcomp - 2.306) 19460,19460,29460
19460 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9471
29460 ivfail = ivfail + 1
      rvcorr = 2.301
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9471 continue
      ivtnum = 947
c
c      ****  test 947  ****
c
      if (iczero) 39470, 9470, 39470
 9470 continue
      rvon01 = .3e+3
      rvcomp = alog10 (rvon01)
      go to 49470
39470 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49470, 9481, 49470
49470 if (rvcomp - 2.472) 29470,19470,49471
49471 if (rvcomp - 2.482) 19470,19470,29470
19470 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9481
29470 ivfail = ivfail + 1
      rvcorr = 2.477
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9481 continue
      ivtnum = 948
c
c      ****  test 948  ****
c
      if (iczero) 39480, 9480, 39480
 9480 continue
      rvon01 = 1350.0
      rvcomp = alog10 (rvon01)
      go to 49480
39480 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49480, 9491, 49480
49480 if (rvcomp - 3.125) 29480,19480,49481
49481 if (rvcomp - 3.135) 19480,19480,29480
19480 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9491
29480 ivfail = ivfail + 1
      rvcorr = 3.130
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9491 continue
c
c     test 949 through test 951 contain function tests for square root
c     functions where the argument and function are real
c
      ivtnum = 949
c
c      ****  test 949  ****
c
      if (iczero) 39490, 9490, 39490
 9490 continue
      rvon01 = 1.0
      rvcomp = sqrt (rvon01)
      go to 49490
39490 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49490, 9501, 49490
49490 if (rvcomp - 0.95) 29490,19490,49491
49491 if (rvcomp - 1.05) 19490,19490,29490
19490 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9501
29490 ivfail = ivfail + 1
      rvcorr = 1.00
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9501 continue
      ivtnum = 950
c
c      ****  test 950  ****
c
      if (iczero) 39500, 9500, 39500
 9500 continue
      rvcomp = sqrt (2.0)
      go to 49500
39500 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49500, 9511, 49500
49500 if (rvcomp - 1.36) 29500,19500,49501
49501 if (rvcomp - 1.46) 19500,19500,29500
19500 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9511
29500 ivfail = ivfail + 1
      rvcorr = 1.41
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9511 continue
      ivtnum = 951
c
c      ****  test 951  ****
c
      if (iczero) 39510, 9510, 39510
 9510 continue
      rvon01 = .229e1
      rvcomp = sqrt (rvon01)
      go to 49510
39510 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49510, 9521, 49510
49510 if (rvcomp - 1.46) 29510,19510,49511
49511 if (rvcomp - 1.56) 19510,19510,29510
19510 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9521
29510 ivfail = ivfail + 1
      rvcorr = 1.51
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9521 continue
c
c     test 952 through test 953 contain function tests for trigonometric
c     sine functions where the argument and function are real
c
      ivtnum = 952
c
c      ****  test 952  ****
c
      if (iczero) 39520, 9520, 39520
 9520 continue
      rvon01 = 0.00000
      rvcomp = sin (rvon01)
      go to 49520
39520 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49520, 9531, 49520
49520 if (rvcomp + .00005) 29520,19520,49521
49521 if (rvcomp - .00005) 19520,19520,29520
19520 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9531
29520 ivfail = ivfail + 1
      rvcorr = 0.00000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9531 continue
      ivtnum = 953
c
c      ****  test 953  ****
c
      if (iczero) 39530, 9530, 39530
 9530 continue
      rvon01 = 0.5
      rvcomp = sin (rvon01)
      go to 49530
39530 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49530, 9541, 49530
49530 if (rvcomp - .474) 29530,19530,49531
49531 if (rvcomp - .484) 19530,19530,29530
19530 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9541
29530 ivfail = ivfail + 1
      rvcorr = .479
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9541 continue
      ivtnum = 954
c
c      ****  test 954  ****
c
      if (iczero) 39540, 9540, 39540
 9540 continue
      rvon01 = 4e0
      rvcomp = sin (rvon01)
      go to 49540
39540 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49540, 9551, 49540
49540 if (rvcomp + .762) 29540,19540,49541
49541 if (rvcomp + .752) 19540,19540,29540
19540 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9551
29540 ivfail = ivfail + 1
      rvcorr = -.757
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9551 continue
c
c     test 955 through test 957 contain function tests for trigonometric
c     cosine functions where the argument and function are real
c
      ivtnum = 955
c
c      ****  test 955  ****
c
      if (iczero) 39550, 9550, 39550
 9550 continue
      rvon01 = 0.00000
      rvcomp = cos (rvon01)
      go to 49550
39550 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49550, 9561, 49550
49550 if (rvcomp - .995) 29550,19550,49551
49551 if (rvcomp - 1.005) 19550,19550,29550
19550 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9561
29550 ivfail = ivfail + 1
      rvcorr = 1.000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9561 continue
      ivtnum = 956
c
c      ****  test 956  ****
c
      if (iczero) 39560, 9560, 39560
 9560 continue
      rvon01 = 1.0e0
      rvcomp = cos (rvon01)
      go to 49560
39560 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49560, 9571, 49560
49560 if (rvcomp - .535) 29560,19560,49561
49561 if (rvcomp - .545) 19560,19560,29560
19560 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9571
29560 ivfail = ivfail + 1
      rvcorr = 0.540
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9571 continue
      ivtnum = 957
c
c      ****  test 957  ****
c
      if (iczero) 39570, 9570, 39570
 9570 continue
      rvcomp = cos (4.0)
      go to 49570
39570 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49570, 9581, 49570
49570 if (rvcomp + .659) 29570,19570,49571
49571 if (rvcomp + .649) 19570,19570,29570
19570 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9581
29570 ivfail = ivfail + 1
      rvcorr = -0.654
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9581 continue
c
c     test 958 through test 960 contain function tests for hyperbolic
c     tangent functions where the argument and function are real
c
      ivtnum = 958
c
c      ****  test 958  ****
c
      if (iczero) 39580, 9580, 39580
 9580 continue
      rvcomp = tanh (0.0)
      go to 49580
39580 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49580, 9591, 49580
49580 if (rvcomp + .00005) 29580,19580,49581
49581 if (rvcomp - .00005) 19580,19580,29580
19580 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9591
29580 ivfail = ivfail + 1
      rvcorr = 0.00000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9591 continue
      ivtnum = 959
c
c      ****  test 959  ****
c
      if (iczero) 39590, 9590, 39590
 9590 continue
      rvon01 = .5e0
      rvcomp = tanh (rvon01)
      go to 49590
39590 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49590, 9601, 49590
49590 if (rvcomp - .457) 29590,19590,49591
49591 if (rvcomp - .467) 19590,19590,29590
19590 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9601
29590 ivfail = ivfail + 1
      rvcorr = 0.462
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9601 continue
      ivtnum = 960
c
c      ****  test 960  ****
c
      if (iczero) 39600, 9600, 39600
 9600 continue
      rvon01 = .25
      rvcomp = tanh (rvon01)
      go to 49600
39600 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49600, 9611, 49600
49600 if (rvcomp - .240) 29600,19600,49601
49601 if (rvcomp - .250) 19600,19600,29600
19600 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9611
29600 ivfail = ivfail + 1
      rvcorr = 0.245
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9611 continue
c
c     tests 961 and 962 contain tests for arctangent of the form
c     atan (a) where the argument and function are real
c
      ivtnum = 961
c
c      ****  test 961  ****
c
      if (iczero) 39610, 9610, 39610
 9610 continue
      rvcomp = atan (0.0)
      go to 49610
39610 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49610, 9621, 49610
49610 if (rvcomp + .00005) 29610,19610,49611
49611 if (rvcomp - .00005) 19610,19610,29610
19610 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9621
29610 ivfail = ivfail + 1
      rvcorr = 0.00000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9621 continue
      ivtnum = 962
c
c      ****  test 962  ****
c
      if (iczero) 39620, 9620, 39620
 9620 continue
      rvon01 = 5e-1
      rvcomp = atan (rvon01)
      go to 49620
39620 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49620, 9631, 49620
49620 if (rvcomp - .459) 29620,19620,49621
49621 if (rvcomp - .469) 19620,19620,29620
19620 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9631
29620 ivfail = ivfail + 1
      rvcorr = 0.464
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9631 continue
c
c     tests 963 and 964 contain tests for arctangent of the form
c     atan2 (a1,a2) where the arguments and function are real
c
      ivtnum = 963
c
c      ****  test 963  ****
c
      if (iczero) 39630, 9630, 39630
 9630 continue
      rvon01 = 0.0
      rvon02 = 1e0
      rvcomp = atan2 (rvon01,rvon02)
      go to 49630
39630 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49630, 9641, 49630
49630 if (rvcomp + .00005) 29630,19630,49631
49631 if (rvcomp - .00005) 19630,19630,29630
19630 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9641
29630 ivfail = ivfail + 1
      rvcorr = 0.00000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9641 continue
      ivtnum = 964
c
c      ****  test 964  ****
c
      if (iczero) 39640, 9640, 39640
 9640 continue
      rvon01 = 2e1
      rvcomp = atan2 (-1.0,rvon01)
      go to 49640
39640 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49640, 9651, 49640
49640 if (rvcomp + .05001) 29640,19640,49641
49641 if (rvcomp + .04991) 19640,19640,29640
19640 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9651
29640 ivfail = ivfail + 1
      rvcorr = -.04996
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9651 continue
c
c     write page footings and run summaries
99999 continue
      write (i02,90002)
      write (i02,90006)
      write (i02,90002)
      write (i02,90002)
      write (i02,90007)
      write (i02,90002)
      write (i02,90008)  ivfail
      write (i02,90009) ivpass
      write (i02,90010) ivdele
c
c
c     terminate routine execution
      stop
c
c     format statements for page headers
90000 format (1h1)
90002 format (1h )
90001 format (1h ,10x,34hfortran compiler validation system)
90003 format (1h ,21x,11hversion 1.0)
90004 format (1h ,10x,38hfor official use only - copyright 1978)
90005 format (1h ,5x,4htest,5x,9hpass/fail, 5x,8hcomputed,8x,7hcorrect)
90006 format (1h ,5x,46h----------------------------------------------)
90011 format (1h ,18x,17hsubset level test)
c
c     format statements for run summaries
90008 format (1h ,15x,i5,19h errors encountered)
90009 format (1h ,15x,i5,13h tests passed)
90010 format (1h ,15x,i5,14h tests deleted)
c
c     format statements for test results
80001 format (1h ,4x,i5,7x,4hpass)
80002 format (1h ,4x,i5,7x,4hfail)
80003 format (1h ,4x,i5,7x,7hdeleted)
80004 format (1h ,4x,i5,7x,4hfail,10x,i6,9x,i6)
80005 format (1h ,4x,i5,7x,4hfail,4x,e12.5,3x,e12.5)
c
90007 format (1h ,20x,20hend of program fm099)
      end


!Dynamic Array
program Dynamic_Array
    implicit none

    INTEGER :: i, j
    INTEGER :: rows, columns
    INTEGER, DIMENSION(:, :), ALLOCATABLE :: array

    ! !Note:
    !DIMENSION(:,:)           -->Two dimension
    !DIMENSION(:,:,:)         -->Three dimension
    !DIMENSION(:,:,:,:)       -->Four dimension
    !DIMENSION(:,:,:,:,:)     -->Five dimension
    !DIMENSION(:,:,:,:,:,:)   -->Six dimension
    !DIMENSION(:,:,:,:,:,:,:) -->Seven dimension

    !In fortran, we can create upto 7 d array
    !ALLOCATABLE is important to make it dynamic array

    !Taking rows and column from user
    write (*, *) "Rows of matrix"
    read (*, *) rows
    write (*, *) "Columns of matrix"
    read (*, *) columns

    ALLOCATE (array(rows, columns))  !This will allocate the size of matrix

    !Assigning Value with a(ij) = i+j
    do i = 1, rows
        do j = 1, columns
            array(i, j) = i + j
        end do
    end do

    !Printing array
    Print *, "Array:"
    do i = 1, rows
        print *, (array(i, j), j=1, columns)
    end do

    DEALLOCATE (array) !Deallocating as it take memory

end program Dynamic_Array