dl_slices Subroutine

public subroutine dl_slices(a, inx, inz, nx, nz, alpha, beta, xh, yh, zh, iflag, iaxis, xt, nxt, xastart, xaend, nmx, nnx, mlx, tsx, ndx, smx, yt, nyt, nmy, nny, mly, tsy, ndy, smy, zt, nzt, zastart, zaend, nmz, nnz, mlz, tsz, ndz, smz, aminin, amaxin, icol, maxsize)

Arguments

Type IntentOptional Attributes Name
real :: a
integer :: inx
integer :: inz
integer :: nx
integer :: nz
real :: alpha
real :: beta
real :: xh
real :: yh
real :: zh
integer :: iflag
integer :: iaxis
character(len=*) :: xt
integer :: nxt
real :: xastart
real :: xaend
integer :: nmx
integer :: nnx
integer :: mlx
real :: tsx
integer :: ndx
real :: smx
character(len=*) :: yt
integer :: nyt
integer :: nmy
integer :: nny
integer :: mly
real :: tsy
integer :: ndy
real :: smy
character(len=*) :: zt
integer :: nzt
real :: zastart
real :: zaend
integer :: nmz
integer :: nnz
integer :: mlz
real :: tsz
integer :: ndz
real :: smz
real :: aminin
real :: amaxin
integer :: icol
integer, intent(in), optional :: maxsize

Contents

Source Code


Source Code

subroutine dl_slices(a,inx,inz,nx,nz,alpha,beta,xh,yh,zh,iflag,iaxis,xt,nxt,xastart,xaend,nmx,nnx,mlx,tsx,ndx,smx,&
     &      yt,nyt,nmy,nny,mly,tsy,ndy,smy, zt,nzt,zastart,zaend,nmz,nnz,mlz,tsz,ndz,smz, aminin,amaxin,icol,maxsize)
!
!     CREATED BY D. LONG     APR, 1984 AT JPL
!     REVISED BY D. LONG     MAY, 1986
!     +REDUCED REDUNDANT PEN MOTIONS AND CORRECTED SOME MINOR BUGS
!
!     ROUTINE TO PLOT DATA IN 3-D OVERLAY FORM
!
!     COORDINATE SYSTEM IS:  Y  Z
!              NAMES:   |/
!                  \X
!
!     A REAL ARRAY A(INX,INZ) CONTAINING VERTICAL HEIGHT DATA
!     INX,INZ INTEGERS DIMENSION OF A ARRAY
!     NX,NZ INTEGERS INDICATING SIZE OF A ARRAY TO PLOT
!     ALPHA REAL ANGLE (IN DEGREES) OF X AXIS (NX) FROM HORIZONTAL
!     BETA  REAL ANGLE (IN DEGREES) OF Z AXIS (NZ) FROM HORIZONTAL
!     XH,YH,ZH REAL LENGTH OF EACH AXIS
!     IFLAG INTEGER
!     (ONE'S DIGIT)      = 2 USE PEN COLOR CONTROL ARRAY
!                        = 1 DO NOT USE PEN COLOR ARRAY
!     (TEN'S DIGIT)      = 0 PLOT SIDE PLATES
!                        = 1 DO NOT PLOT SIDE PLATES
!     IAXIS INTEGER AXIS OPTION FLAG
!           = 0 DO NOT PLOT AXIS--FOLLOWING VARIABLES NOT ACCESSED
!           < 0 PLOT AXIS, USE INPUT Y AXIS SCALE--FOLLOWING VARIABLES ACCESSED
!           > 0 PLOT AXIS, USE COMPUTED Y AXIS SCALE--FOLLOWING VARIABLES ACCESSED
!     (ONE'S DIGIT)  = 1 PLOT AXIS, Y AXIS SCALE--VARIABLES ACCESSED
!           = 2 PLOT AXIS, AUTO SCALE Y AXIS--VARIABLES ACCESSED
!     (TEN'S DIGIT)  = 0 DEFAULT AXIS PARAMETERS
!           = 1 SPECIALIZED DL_AXISB PARAMETERS
!     XT,YT,ZT CHAR STRINGS FOR AXIS TITLES
!     NXT,NYT,NZT INT  LENGTH OF AXIS TITLES
!                IF ZERO THEN THAT AXIS NOT PLOTTED
!     XASTART,ZASTART   REAL AXIS START VALUES
!     XAEND,ZAEND REAL AXIS END VALUES
!
! FOLLOWING ONLY ACCESSED IF TEN'S DIGIT OF IFLAG=1
!     NMX,NMY,NMZ INT NUMBER OF MINOR TICKS BETWEEN MAJOR TICKS
!     NNX,NNY,NNZ INT HIGHLIGHT LENGTH OF NNX-TH MINOR TICK ON AXIS
!     MLX,MLY,MLZ INT NUMBER OF MAJOR TICK MARKS ON AXIS
!     TSX,TSY,TSZ REAL SIZE OF TITLE AND NUMBERS OF AXIS
!             IF LESS THAN ZERO DO NOT AUTO-SCALE BY (x10^POWER)
!     NDX,NDY,NDZ INT NUMBER OF DIGITS TO RIGHT OF DECIMAL POINT
!     SMX,SMY,SMZ REAL MAJOR TICK LENGTH
!     AMININ,AMAXIN  REAL YAXIS SCALING FACTORS (ONLY NEEDED IF IAXIS < 0)
!     ICOL    INTEGER COLOR CONTROL (ACCESSED IF MAG(IFLAG)=2)
!              ICOL(1) AXIS LINE
!              ICOL(2) AXIS NUMBERS
!              ICOL(3) AXIS TITLE
!              ICOL(4) AXIS EXPONENT
!              ICOL(5) PLOT
!
implicit none
real     :: a
real     :: alpha
real     :: amax
real     :: amaxin
real     :: amh
real     :: aminin
real     :: ang
real     :: as
real     :: beta
real     :: bh
real     :: daa
real     :: dx
real     :: dx1
real     :: dx2
real     :: dy
real     :: dy1
real     :: dy2
real     :: dz
real     :: hx1
real     :: hx2
real     :: hy1
real     :: hy2
integer  :: i
integer  :: iaf
integer  :: iaxis
integer  :: ic
integer  :: icol
integer  :: idct
integer  :: iflag
integer  :: iflag1
integer  :: iflag10
integer  :: ihct
integer  :: ihold
integer  :: ip
integer  :: ipct
integer  :: ipen
integer  :: ix
integer  :: iz
integer  :: mlx
integer  :: mly
integer  :: mlz
integer  :: n1
integer  :: n2
integer  :: nadd
integer  :: ndx
integer  :: ndy
integer  :: ndz
integer  :: nmx
integer  :: nmy
integer  :: nmz
integer  :: nnx
integer  :: nny
integer  :: nnz
integer  :: nx
integer  :: nxt
integer  :: nyt
integer  :: nz
integer  :: nzt
real     :: smx
real     :: smy
real     :: smz
real     :: tsx
real     :: tsy
real     :: tsz
real     :: x
real     :: x0
real     :: xaend
real     :: xastart
real     :: xh
real     :: xlen
real     :: xp
real     :: xp1
real     :: xp2
real     :: y
real     :: y0
real     :: yh
real     :: ylen
real     :: yp
real     :: yp1
real     :: yp2
real     :: zaend
real     :: zastart
real     :: zh
real     :: zlen
integer :: inx,inz
dimension a(inx,inz),as(2),icol(*),ic(4)
integer,intent(in),optional :: maxsize
integer                     :: maxsize_local
! PARAMETER (maxsize=204800)
! DIMENSION H(maxsize,2),P(maxsize_local,2)
real,allocatable :: h(:,:)
real,allocatable :: p(:,:)
character*(*) xt,yt,zt
logical flag,hhigh
real,parameter :: tpi= 3.141592654
      if(present(maxsize))then
         maxsize_local=maxsize
      else
         maxsize_local=204800
      endif

      if(allocated(h))deallocate(h)
      if(allocated(p))deallocate(p)
      allocate(h(maxsize_local,2))
      allocate(p(maxsize_local,2))
!
      alphq=alpha*tpi/180.0  ! X-AXIS INCLINATION 0-80 DEGS
      betq=beta*tpi/180.0    ! Z-AXIS ANGLE 5-80 DEGS
!
      if (iaxis.lt.0) then
         amax=amaxin
         aminq=aminin
      else
         amax=a(1,1)
         aminq=a(1,1)
         do iz=1,nz      ! DETERMINE MAX,MIN ARRAY VALUES
            do ix=1,nx
               amax=amax1(amax,a(ix,iz))
               aminq=amin1(aminq,a(ix,iz))
            enddo
         enddo
      endif
      if(alpha.lt.0..or.alpha.gt.88..or.beta.lt.1..or.beta.gt.90.)then
         write(*,'(*(g0))')'(" *** dl_slices INPUT ANGLE ERROR ***")ALPHA=',alpha,'(allowed 0 to 88) BETA=',beta,'(allowed 1 to 90)'
         return
      endif
      if (amax.eq.aminq) then
         write(*,'(" *** dl_slices SCALE ERROR *** MAX=MIN")')
         amax=aminq+1.0
      endif
!
      xlen=abs(xh)
      xscaleq=xlen/float(nx-1)
      zlen=abs(zh)
      zscaleq=zlen/float(nz-1)
      ylen=abs(yh)
      if (mod(iabs(iaxis),10).eq.2) then ! SMOOTH SCALE FACTORS
         as(1)=amax
         as(2)=aminq
         call dl_range(as,ylen,2,1,1,aminq,daa)
         amax=ylen*daa+aminq
      endif
      yscaleq=1.0
      if (amax-aminq.ne.0.0) yscaleq=ylen/(amax-aminq)
!
!     INITIALIZE PLOT PACKAGE
!
      iaf=iabs(iaxis)/10

      iflag1=iabs(iflag)
      iflag10=mod(iflag1,100)/10
      iflag1=mod(iflag1,10)

      if (iaxis.ne.0) then  ! PLOT AXIS LABELS
         nadd=0
         if (iflag1.eq.2) then
            ic(1)=icol(2)
            ic(2)=icol(3)
            ic(3)=icol(4)
            ic(4)=icol(5)
            nadd=100000 ! PEN COLOR
         endif
         call dl_vxpt3d(xp,yp,aminq,1,1,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
         dy=(amax-aminq)/ylen
         if (nyt.gt.0) then  ! PLOT Y AXIS
            if (iaf.eq.1) then
               call dl_axisb(xp,yp,yt,nyt+11000+nadd, ylen,90.,aminq,dy,nmy,nny,-iabs(mly), tsy,ndy,smy,ic)
            else
               call dl_axisa(xp,yp,yt,nyt+1000+nadd, ylen,90.,aminq,dy,n1,n2,ic)
            endif
         endif
         call dl_vxpt3d(xp1,yp1,aminq,nx,1,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
         dx=(xaend-xastart)/xlen
         ang=atan2(yp1-yp,xp1-xp)*180./tpi
         if (nxt.gt.0) then
            if (iaf.eq.1) then
               call dl_axisb(xp,yp,xt,-nxt-nadd-10000,xlen,ang,xastart,dx,nmx,nnx,-iabs(mlx),tsx,ndx,smx,ic)
            else
               call dl_axisa(xp,yp,xt,-nxt-nadd,xlen,ang,xastart,dx,n1,n2,ic)
            endif
         endif
         dz=(zaend-zastart)/zlen
         if (nzt.gt.0) then
            if (iaf.eq.1) then
               call dl_axisb(xp1,yp1,zt,-nzt-nadd-10000 ,zlen,beta,zastart,dz,nmz,nnz, -iabs(mlz),tsz,ndz,smz,ic)
            else
               call dl_axisa(xp1,yp1,zt,-nzt-nadd, zlen,beta,zastart,dz,n1,n2,ic)
            endif
         endif
      endif
      if (iflag1.eq.2) call dl_color(icol(5)) ! PEN COLOR
!
!     PLOT FRONT PLATE
!
      ipen=3
      do i=1,nx
         if (i.gt.maxsize_local) goto 999
         call dl_vxpt3d(h(i,1),h(i,2),a(i,1),i,1,nx) ! INITIALIZE HISTORY ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
         call dl_plot(h(i,1),h(i,2),ipen)   ! PLOT SIDE LINE
         ipen=2
      enddo
      ihold=nx
      if (beta.eq.90.0) goto 5

      if (iflag10.eq.1) goto 71   ! DON'T PLOT SIDE PLATES
      call dl_vxpt3d(xp,yp,aminq,nx,1,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
      call dl_draw(xp,yp)
      do i=1,nx-1      ! ADD SIDE LINES
         call dl_move(h(i,1),h(i,2))
         call dl_vxpt3d(xp,yp,aminq,i,1,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
         call dl_draw(xp,yp)
         call dl_vxpt3d(xp,yp,aminq,i+1,1,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
         call dl_draw(xp,yp)
      enddo
!
!     PLOT SIDE PLATE
!
71    continue
      call dl_move(h(nx,1),h(nx,2))
      do i=1,nz        ! PLOT RIGHT SIDE CURVE
         if (nx+i.gt.maxsize_local) goto 999
         call dl_vxpt3d(xp,yp,a(nx,i),nx,i,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
         h(nx+i,1)=xp
         h(nx+i,2)=yp
         call dl_draw(xp,yp)
      enddo
      call dl_vxpt3d(xp,yp,aminq,nx,1,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
      call dl_move(xp,yp)
      ihold=nx+nz        ! NUMBER OF H VALUES
      if (iflag10.ne.1) then! DON'T PLOT SIDE PLATES
         do i=2,nz        ! ADD SIDE LINES
            call dl_vxpt3d(xp2,yp2,aminq,nx,i,nx)  ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
            call dl_draw(xp2,yp2)
            call dl_vxpt3d(xp,yp,a(nx,i),nx,i,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
            call dl_draw(xp,yp)
            call dl_move(xp,yp2)
         enddo
      endif
!
!     BEGIN MAIN LOOP
      ip=3
5     continue
      mainloop: do iz=2,nz      ! OVER Z DIMENSION TOWARD REAR
         ipct=1
         idct=1
         ihct=1
!        DETERMINE START POINT LOCATION
         call dl_vxpt3d(xp1,yp1,a(idct,iz),1,iz,nx) ! LEFT-MOST DATA POINT ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
         if (xp1.lt.h(1,1)) then  ! DATA TO LEFT OF HISTORY ARRAY
!           IF (IPCT.GT.maxsize_local) GOTO 999
!           P(IPCT,1)=XP1
!           P(IPCT,2)=YP1
!           IPCT=IPCT+1
            call dl_move(xp1,yp1)
            do i=1,nx  ! (VERY RARE)
               call dl_vxpt3d(xp1,yp1,a(i,iz),i,iz,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
               if (xp1.gt.h(1,1)) then
                  idct=i-1
                  call dl_vxpt3d(dx1,dy1,a(idct,iz),idct,iz,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
                  hhigh=.false.
                  hx1=h(1,1)
                  hy1=h(1,2)
                  hx2=h(2,1)
                  hy2=h(2,2)
                  idct=idct+1
                  ihct=ihct+2
                  call dl_vxpt3d(dx2,dy2,a(idct,iz),idct,iz,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
                  idct=idct+1
                  goto 100
               endif
               if (ipct.gt.maxsize_local) goto 999
               p(ipct,1)=xp1
               p(ipct,2)=yp1
               ipct=ipct+1
               call dl_draw(xp1,yp1)
            enddo
         endif
         idct=2
         call dl_vxpt3d(dx1,dy1,a(1,iz-1),1,iz-1,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
         call dl_vxpt3d(dx2,dy2,a(1,iz),1,iz,nx)     ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
!C       CALL dl_move(H(1,1),H(1,2))
         x0=h(1,1)
         y0=h(1,2)
         ip=3
         if (ipct.gt.maxsize_local) goto 999
         p(ipct,1)=h(1,1)
         p(ipct,2)=h(1,2)
         ipct=ipct+1
         do i=2,ihold
            if (h(i,1).gt.dx1) exit
               if (ipct.gt.maxsize_local) goto 999
               p(ipct,1)=h(i,1)
               p(ipct,2)=h(i,2)
               ipct=ipct+1
!C             CALL dl_draw(H(I,1),H(I),2)
               x0=h(i,1)
               y0=h(i,2)
         enddo
8        continue
         ihct=i-1
         hx1=h(ihct,1)
         hy1=h(ihct,2)
         hx2=h(ihct+1,1)
         hy2=h(ihct+1,2)
         ihct=ihct+2
         hhigh=.true.
         if (hx1.eq.hx2) then
            if (ihct.eq.ihold) goto 100
            ihct=ihct+1
            goto 8
         endif
         amh=(hy2-hy1)/(hx2-hx1)
         bh=hy1-hx1*amh
         yp=amh*dx1+bh
         if (yp.le.dy1) hhigh=.false.
         if (hy1.eq.dy1.and.hx1.eq.dx1) then
            hhigh=.true.
            yp=amh*dx2+bh
            if (yp.lt.dy2) hhigh=.false.
         endif
!
!     TOP OF INNER LOOP
!
100      continue
            call dl_intersect(flag,x,y,hx1,hy1,hx2,hy2,dx1,dy1,dx2,dy2,hhigh)
            if (flag) then  ! SEGMENTS INTERSECT
               hx1=x    ! DRAW SEGMENT WITH
               hy1=y    ! HIGHEST START POINT
               dx1=x    ! TO THE INTERSECTION
               dy1=y
               if (ipct.gt.maxsize_local) goto 999
               p(ipct,1)=x
               p(ipct,2)=y
               ipct=ipct+1
               if (ip.eq.2) call dl_draw(x,y)
               x0=x
               y0=y
               goto 100
            endif
!
            if (hx2.le.dx2) then ! CHECKED ALL H SEGS OVER D SEGS
               if (hhigh) then ! DRAW HIGHEST SEGMENT
                  if (ipct.gt.maxsize_local) goto 999
                  p(ipct,1)=hx2
                  p(ipct,2)=hy2
                  ipct=ipct+1
                  if (ip.eq.3) call dl_move(x0,y0)
                  call dl_draw(hx2,hy2)
                  x0=hx2
                  y0=hy2
                  ip=2
               endif
               hx1=hx2
               hy1=hy2
               hx2=h(ihct,1)
               hy2=h(ihct,2)
               ihct=ihct+1
               if (ihct.gt.ihold+1) then
 34               continue
                  if (idct.le.nx+1) then
                     call dl_vxpt3d(x,y,a(idct-1,iz),idct-1,iz,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
                     if(ipct.gt.maxsize_local)goto 999
                     p(ipct,1)=x
                     p(ipct,2)=y
                     ipct=ipct+1
                  if (ip.eq.3) call dl_move(x0,y0)
                     ip=2
                     call dl_draw(x,y)
                     idct=idct+1
                     goto 34
                  endif
                  goto 200 ! DONE WITH H'S
               endif
               if (hx1.eq.dx2) then
                  dx1=dx2  ! NEXT DATA POINT
                  dy1=dy2
                  x0=dx1
                  y0=dy1
!C                IF (.NOT.HHIGH)CALL dl_draw(DX1,DY1)
                  !write(*,*)' I IDCT,IZ=',idct,iz,inx,inz,nx,nz
                  if(idct.gt.nx)then
                     dx2=dx1
                     dy2=aminq
                  else
                     call dl_vxpt3d(dx2,dy2,a(idct,iz),idct,iz,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
                  endif
                  idct=idct+1
                  if (idct.gt.nx+2) goto 235 ! DONE WITH DATA
                  hhigh=.true.
                  if (dy1.gt.hy1) hhigh=.false.
               endif
               goto 100
            else
               if (.not.hhigh) then ! PLOT DATA THAT IS HIGHEST
                  if (ipct.gt.maxsize_local) goto 999
                  p(ipct,1)=dx2
                  p(ipct,2)=dy2
                  ipct=ipct+1
                  if (ip.eq.3) call dl_move(x0,y0)
                  call dl_draw(dx2,dy2)
                  ip=2
                  x0=dx2
                  y0=dy2
               endif
               dx1=dx2  ! NEXT DATA POINT
               dy1=dy2
               !write(*,*)'II IDCT,IZ=',idct,iz,inx,inz,nx,nz
               if(idct.gt.nx)then
                  dx2=dx1
                  dy2=aminq
               else
                  call dl_vxpt3d(dx2,dy2,a(idct,iz),idct,iz,nx) ! DETERMINE X,Y VALUE OF A POINT ON 3-D SURFACE
               endif
               idct=idct+1
               if (idct.gt.nx+2) goto 235 ! DONE WITH DATA
            endif
!
!     DONE WITH INNER LOOP
!
            goto 100
235   continue          ! FINISH H CURVE WHEN OUT OF DATA
      ihct=ihct-1
236   continue
      if (ihct.gt.ihold) goto 200
         x=h(ihct,1)
         y=h(ihct,2)
         ihct=ihct+1
         if (ipct.gt.maxsize_local) goto 999
         p(ipct,1)=x
         p(ipct,2)=y
         ipct=ipct+1
!C       CALL dl_draw(X,Y)
         idct=idct+1
      goto 236
!
200      continue
         ihold=ipct-1     ! STORE NEW HISTORY
         do i=1,ipct
            h(i,1)=p(i,1)
            h(i,2)=p(i,2)
         enddo
!
      enddo mainloop
!
520   call dl_move(0.,0.)   ! PEN UP
      return
999   continue
      write(*,3002)
3002  format(' *** dl_slices INTERNAL MEMORY OVERFLOW ERROR ***')
      goto 520
end subroutine dl_slices