RMAGEN84/SRC84/RMAGEN.F90

!IPK  LAST UPDATE SEP 23 2015  ADD TESTING FOR CHNAGED ELEMENTS/NODES OR REORDERING
!     Last change:  IPK  13 Jan 98   10:01 am
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      SUBROUTINE RMAGEN(MENUS,N1,N2,N3,N4,N5,N6,N7,N8,N9)
!
!
!
!                     RMAGEN Version 4.2
!       
!                   Release date   Jan 13 1998
!
!
! Changes in this version include:
! (1)  Revisions to operate in a graphical mode, reducing the amount of
!      DOS screen input.
! (2)  Addition of options for both the node move operation and refine 
!      options to allow the user to stop preservation or automatic 
!      interpolation of bottom elevations from the corner node values.
!      This option is a user setting.  The default initial setting 
!      retains the value for the move operation and interpolaton during
!      refinement.
! (3)  Input of "geo" has been made more flexible.  The model 
!      automatically detects binary files with and without headers.  Note
!      that this option is only relevant for PC versions.
! (4)  The screen now displays compilation limits on startup.
! 
!
!                     RMAGEN Version 4.1(a)
!       
!                   Release date   Nov 18 1997
!
!
!
! Changes in this version include:
! (1)  Revised interpolation scheme for computing bottom elevations from
!      map file data.
! (2)  More consistent backup
! (3)  Addition of option to split triangles when refining
!
!                     RMAGEN Version 4.1
!
!                   Release date   Oct 19 1996
 
! Changes in this version include:
! (1)  New options that allow selective drawing of maps in different
!      colours
! (2)  An option that allows construction of continuity lines from the 
!      map screen
 
!                     RMAGEN Version 3.3
 
!                   Release date   April 1 1994
 
! Changes in this version include:
! (1) Incorporation of the ability to record and play scripts.
! (2) Correction to correctly operate in the top half inch of the network
 
!                     RMAGEN Version 3.2
 
!                   Release date   March 1 1994
 
! Changes in this version include:
! (1) Modification to the save options to enter a menu of save choices.
! (2) Addition of the capability to save a binary version of the map file.
! (3) Correction to the "backup file" to make it work consistently.
! (4) Changes to the algorithm of the bottom elevation generation routine
!     to improve reliability.
! (5) Removal of an implied limitation of 32000 lines for the map file by
!     deleting some INTEGER*2 variable to INTEGER*4.
 
!                    RMAGEN Version 3.1(a)
  
!                   Release date   Aug 1 1993
 
! Changes in this version include:
! (1) Correction to colurs that make them more readable.
! (2) Additions to the SELECT options that permit more flexible choice
!     of elements.
 
!                     RMAGEN Version 3.1 
 
!                   Release date   March 1 1993
 
! Changes in this version include:
! (1) Correction in fill operation to ensure correct fill when there are
!     a number of gaps in the nodal sequence.
! (2) Additions to the NODE-DELETE options that permit more flexible 
!     deletion options such as all mid-side nodes, all exact mid-side
!     location nodes or all unused nodes.  The fill option has added
!     flexibility.
 
 
!         Version 3.0(c)  August 1 1992
 
! Changes in this version include:
! (1) Revisions to incorporate REGIS graphics capability
! (2) Block of routines available to use DEC 340 REGIS graphics
!     terminal with unix system
 
 
!         Version 3.0(b)  May 20 1992
 
!   Changes in this version include:
!   (1) Renaming of all colours for compatibility with Silicon Graphics
!   (2) Modification of nodal delete so that when a mid-side node is 
!       selected for deletion it is removed and the associated reference
!       in the element is set to zero.  The element is no longer deleted.
!   (3) Cleanup of array subscripts in SUBROUTINE HEDRC
 
!         Version 3.0(a) April 1992
 
!         Changes to a number of routines to correct minor errors
!         and nuisances.
 
!         Version 3.0   January 1992
 
!         This version revises the naming of input and output files.
!         Output files may be generated in ASCII or BINARY form.
!         The binary file is designed to bypass RMA-1.
!         This file optionally may contain element reordering numbers
!         New capabilities include:
!         (1)   Automatic filling of zero's in element connection arrays.
!         (2)   Input of reordering sequences and executing the reordering
!               process.
 
 
      USE BLKMAP
      USE BLK1MOD
!      INCLUDE 'BLK1.COM'

      INCLUDE 'BFILES.I90'


      INCLUDE 'TXFRM.COM'
!IPK MAY02       COMMON  /TXFRM/  XS, YS, TXSCAL 
  
!ipk oct96
      character*64 fnams
      character*25 mesg
      CHARACTER*1   ANS,ANSW(0:9),ansx(0:9)
      DATA ANSW/'e','n','o','h','s','l','t','z','r','q'/
      data ansx/'s','b','m','p',2*' ','h','z','r','q'/
 
      DATA  IFIRST / 1 /
 
      IF(N3 .EQ. 1) GO TO 101

	  ISWTAGN=0
	  ISWTINTP=0
	  WIDSCL=1.0
	  WIDEL=0.0
	  IPW1=1
      IMP=N1
      IIN=N2
      IOT=N4
      IOT1=N5
      IGFG=N6
	  ITRIAN=N7
!ipk jul98
      LCROSS=.FALSE.
      ICRS=0
      DFACTOR=50.
      ZREF=5.

!iPK JAN98
      IDELV=0
      IRESTT=0
    1 CONTINUE
      IFIRST=1
      IECHG=0
      NELAST=1
      NPLAST=1
      NLST=0
      NENTRY=0
      TXSCAL = 1.
      XS=0.
      YS=0.
      VDX  = - 1.0E+10
      VOID = - 1.0E+20
 
      IPSW(1)=0
      IPSW(2)=0
      IPSW(3)=0
      IPSW(4)=1
      IPSW(5)=0
      IPSW(6)=0
      IPSW(7)=0
      IPSW(8)=0
      IPSW(9)=0
      IPSW(12)=0
!      IF(N8 .GT. 100000) THEN
!        IPSW(2)=1
!        IPSW(4)=0
!      ENDIF
      MAXPTS=MAXPL
!ipk jan98
      call file(1)
 

      write(90,*) 'rmagen',iot,iot1

!  Initialize plot
 
!!      CALL GINIT
 
!  Startup files
      WRITE(MESG,6010) 
 6010 FORMAT(' Going to initialisation ')
	  CALL SYMBL(1.1,6.3,0.15,mesg,0.0,25)
 
      CALL FILE(2)

      WRITE(MESG,6011) 
 6011 FORMAT(' Back from initialisation')
	  CALL SYMBL(1.1,5.3,0.15,mesg,0.0,25)
 
      IF(MENUS .EQ. -1)      CALL DEMOS

      IF(IIN .EQ. 0) IPSW(1)=1
 
!  Initialize plot
 
!ipk jan98      CALL GINIT
 
      IF(IMP .GT. 0) THEN

!  Read map file
         WRITE(90,*) 'GOING TO READ MAP'
         CALL RDMAP(0,0,0,0)
         IF (IFIRST .EQ. 1)  THEN

!  Find max and min

            XMIN = 1.E+20
            XMAX = -XMIN
            YMIN = 1.E+20
            YMAX = -YMIN

            DO 8 J=1,MAXPTS
            IF (CMAP(J,1) .LT. VDX)  GOTO  8
            IF (CMAP(J,1) .LT. XMIN)  XMIN = CMAP(J,1)
            IF (CMAP(J,1) .GT. XMAX)  XMAX = CMAP(J,1)
            IF (CMAP(J,2) .LT. YMIN)  YMIN = CMAP(J,2)
            IF (CMAP(J,2) .GT. YMAX)  YMAX = CMAP(J,2)
    8          CONTINUE
    9       CONTINUE
         ENDIF
      ENDIF

!  Read in header lines

      ISET=1
      WRITE(90,*) 'GOING TO HEADIN'
      CALL HEADIN(IIN,ISET)

!  Read in existing elements
      WRITE(90,*) 'GOING TO RDELEM'
      CALL RDELEM(IIN)

!  Read in nodal coordinates

      WRITE(90,*) 'GOING TO RDCORD'
      CALL RDCORD(IIN)

      WRITE(90,*) 'RMAGEN-243  NCLM',NCLM


!ipk may03
      ichg=1

!  Close input file

      if(iin .ne. 0) then
        CLOSE(IIN)
      endif

!  Scale for plotting

      IF (IFIRST .EQ. 1)  THEN
         IF (IMP .EQ. 0) THEN
            XMIN = 1.E+20
            XMAX = -XMIN
            YMIN = 1.E+20
            YMAX = -YMIN
         ENDIF

!         do j=1,ne
!           if(nop(j,1) .eq. 0) cycle
!           do k=1,8,2
!             if(nop(j,k) .eq. 0) cycle
!             if(wd(nop(j,k)) .gt. 27.) go to 7110
!             if(wd(nop(j,k)) .lt. 22.) go to 7111
             
!           enddo
!7110       continue    
!           imat(j)=0
!           IESKP(J)=1
!           DO K=1,8
!             NOP(J,K)=0
!           ENDDO
!7111       continue    
!         enddo
         
         
         IF(NP .GT. 0) THEN
            DO 10  J=1,NP
               IF (CORD(J,1) .LT. VDX)  GOTO 10
               IF (CORD(J,1) .LT. XMIN)  XMIN = CORD(J,1)
               IF (CORD(J,1) .GT. XMAX)  XMAX = CORD(J,1)
               IF (CORD(J,2) .LT. YMIN)  YMIN = CORD(J,2)
               IF (CORD(J,2) .GT. YMAX)  YMAX = CORD(J,2)
   10       CONTINUE
         ENDIF

!   Check for background limits
         WRITE(90,*) 'NBKFL',NBKFL
         IF(NBKFL .GT. 0) THEN
           DO I=1,NBKFL
             IF(BFMINMAX(I,1) .LT. XMIN) XMIN=BFMINMAX(I,1)
             IF(BFMINMAX(I,2) .LT. YMIN) YMIN=BFMINMAX(I,2)
             IF(BFMINMAX(I,3) .GT. XMAX) XMAX=BFMINMAX(I,3)
             IF(BFMINMAX(I,4) .GT. YMAX) YMAX=BFMINMAX(I,4)
             WRITE(90,*) 'XX',XMIN,XMAX,YMIN,YMAX
             WRITE(90,*) 'BFMIN',(BFMINMAX(I,K4),K4=1,4)
           ENDDO
         ENDIF

!rrr
         WRITE(90,*) 'GOING TO PGRID'
         CALL PGRID
 
         AMAP=(XMAX-XMIN)*(YMAX-YMIN)
         XSCALE = (XMAX-XMIN)/(hsize-0.5)
         YSCALE = (YMAX-YMIN)/6.5
         PSCALE = MAX(XSCALE,YSCALE)

         XAVE = (XMIN + XMAX) /2.0
         YAVE = (YMIN + YMAX) /2.0
         XMIN = XAVE - hsize/2.*PSCALE
         YMIN = YAVE - 3.5*PSCALE
         XMAX = XAVE + (hsize-0.5)/2.*PSCALE
         YMAX = YAVE + 3.25*PSCALE
!        YMIN = YMIN - .01*PSCALE
!        XMIN = XMIN - .01*PSCALE

!  Reset values if STARTUP.DAT file is used

         IF(IS11 .GT. 0) THEN
           READ(IS11,5200) XS,YS,PSCALE
 5200      FORMAT(3F15.0)
           XMIN=-XS
           YMIN=-YS
         ENDIF

         IFIRST = 0

      ENDIF

!  Plot all data

      CALL PLOTSV(0)
!ipk nov97 add (1)
      CALL PLOTOT(1)
      GO TO 101

!  Top of loop  ********************************

  100 CONTINUE
  101 CONTINUE
      if(menus .gt. 9) go to 25
      IF(MENUS .GT. 0) THEN
        ANS=ANSW(MENUS-1)
        MENUS=0
        GO TO 130
      ENDIF

!  List options

   25 CONTINUE

!  Draw box around selections

      IF(MENUS .EQ. -3) THEN
        CALL PLOTOT(0)
        MENUS=-2
      ENDIF
      NHTP=1
      NMESS=0
      NBRR=0
      CALL HEDR
!  Get answer

      call xyloc(XPT,YPT,ANS,IBOX)
      IF(IRMAIN .EQ. 1) THEN
!ipk may94 add line
        CALL RESCAL
        IRMAIN=0
        GO TO 100
      ENDIF
      IF(ANS .EQ. 'c') THEN
        I=IBOX-1
        if(i .lt. 0) go to 25
        ANS=ANSW(I)
      ENDIF

  130 CONTINUE

!  Add elements

      IF (ANS .EQ. 'e')  THEN
         CALL ELTS
         IF(IRMAIN .EQ. 1) THEN
!ipk may94 add line
           CALL RESCAL
           IRMAIN=0
           GO TO 100
         ENDIF

!  Go to help facility

      ELSEIF (ANS .EQ. 'h')  THEN
         CALL HELPS(1)
         IF(IRMAIN .EQ. 1) THEN
!ipk may94 add line
           CALL RESCAL
           IRMAIN=0
           GO TO 100
         ENDIF

!  Process nodes

      ELSEIF (ANS .EQ. 'n')  THEN
         CALL ADDNOD
!ipk feb94  call for backup
         CALL WRTOUT(0)
         IF(IRMAIN .EQ. 1) THEN
!ipk may94 add line
           CALL RESCAL
           IRMAIN=0
           GO TO 100
         ENDIF

!  Add element reordering sequence

      ELSEIF (ANS .EQ. 'o')  THEN

!  Draw box around selections

  140   CONTINUE
        NHTP=3
        NMESS=0
        NBRR=0
        CALL PLOTORDS

        CALL HEDR

!  Get answer

        call xyloc(XPT,YPT,ANS,IBOX)
        CALL PLOTORDS
        IF(IRMAIN .EQ. 1) THEN
!ipk may94 add line
          CALL RESCAL
          IRMAIN=0
          GO TO 100
        ENDIF
        IF(ANS .EQ. 'c') THEN
          I=IBOX-1
        ELSE
          IF(ANS .EQ. 'l') THEN

!     Process current list including baseine order

            I=0
          ELSEIF(ANS .EQ. 'g') THEN

!     Add another order to the list

            I=1
          ELSEIF(ANS .EQ. 'p') THEN

!     Process the latest addition to the list

            I=2
          ELSEIF(ANS .EQ. 'o') THEN
            I=3
          ELSEIF(ANS .EQ. 't') THEN
            I=4
          ELSEIF(ANS .EQ. 'h') THEN
            I=5
          ELSEIF(ANS .EQ. 'z') THEN
            I=7
          ELSEIF(ANS .EQ. 'r') THEN
            I=8
          ELSEIF(ANS .EQ. 'q') THEN
            I=9
          ENDIF
        ENDIF
        IF(I .LT. 3) THEN

          CALL ADDORD(I)
          IF(IRMAIN .EQ. 1) THEN
!ipk may94 add line
            CALL RESCAL
            IRMAIN=0
            GO TO 100
          ENDIF
          GO TO 140
        ELSEIF(I .gt.  2  .and.  I .lt. 5) THEN
!
!       compact elements and nodes 
!
          call compact(i)
          go to 100

        ELSEIF(I .EQ. 5) THEN

!  Get help screen

          CALL HELPS(5)
          IF(IRMAIN .EQ. 1) THEN
!ipk may94 add line
            CALL RESCAL
            IRMAIN=0
            GO TO 100
          ENDIF

        ELSEIF(I .EQ. 9) THEN

!   Return to main  menu

          GO TO 100

        ELSE

!   Return to try for character again

        GO TO 140
        ENDIF
        GO TO 140 

!       ENDIF
!ipk oct96 add continuity lines

      ELSEIF (ANS .EQ. 'l') THEN
        CALL CCLINE(1)
          IF(IRMAIN .EQ. 1) THEN
!ipk may94 add line
            CALL RESCAL
            IRMAIN=0
            GO TO 100
          ENDIF

!ycw mar97 add cross section

      ELSEIF (ANS .EQ. 't') THEN
        CALL CRSECT 
          IF(IRMAIN .EQ. 1) THEN
            CALL RESCAL
            IRMAIN=0
            GO TO 100
          ENDIF
!ycw
      ELSEIF (ANS .EQ. 'r') THEN
!  Save display parameters

         n1=nhtp
         n2=nmess
         n3=nbrr
         CALL RDRW(0)
         if(irmain .eq. 1) return

!  Restore display parameters

         nhtp=n1
         nmess=n2
         nbrr=n3
 
      ELSEIF (ANS .EQ. 's') THEN

!   Save files


!  Draw box around selections

  210   NHTP=11
        NMESS=0
        NBRR=0
        CALL HEDR

!  Get answer

        call xyloc(XPT,YPT,ANS,IBOX)
        IF(IRMAIN .EQ. 1) THEN
!ipk may94 add line
          CALL RESCAL
          IRMAIN=0
          GO TO 100
        ENDIF
        IF(ANS .EQ. 'c') THEN
          if(ibox .le. 0) go to 210
          I=IBOX-1
          ANS=ANSX(I)
        ENDIF

!   Save plot file

        IF (ANS .EQ. 'p') THEN

          CALL PLOTSV(1)
!ipk nov97 add(1)
          CALL PLOTOT(1)
          CALL NDPLSV

        ELSEIF (ANS .EQ. 'b') THEN

!   Save file in binary form

          CALL WRTOUT(2)

        ELSEIF (ANS .EQ. 'm') THEN

!   Save  map file

          CALL WRTMAP(0)

        ELSEIF (ANS .EQ. 's') THEN

!   Save file

          CALL WRTOUT(1)

!  Go to help facility

        ELSEIF (ANS .EQ. 'h')  THEN
          CALL HELPS(8)
          IF(IRMAIN .EQ. 1) THEN
!ipk may94 add line
            CALL RESCAL
            IRMAIN=0
            GO TO 100
          ENDIF
        ELSEIF (ANS .EQ. 'q')  THEN
          GO TO 100
        ENDIF
        GO TO 210  


      ELSEIF (ANS .EQ. 'q')  THEN

!   Quit program after checking

        
        CALL RQUIT(IYES)
		IF(IYES .EQ. 1) THEN
		  CALL Quit_Pgm
		  STOP
!!SEP02        CALL CLSCRN
!!SEP02        CALL SETD(23)
!ipk oct96 move to screen output
   
!!SEP02        WRITE(FNAMS,*) 'Do you really want to quit? (y) or (n)'
!!SEP02        CALL SYMBL(1.,7.20,0.20,FNAMS,0.,38)
!!SEP02        ndig=1
!!SEP02        call gtcharx(ans,ndig,6.,7.2)
!ipk oct96      READ(*,'(A)') ANS
!!SEP02        IF(ANS .EQ. 'y'  .OR.  ANS .EQ. 'Y') THEN
!!SEP02          CALL Quit_Pgm
!!SEP02          STOP
!!SEP02        ELSE
!!SEP02          WRITE(FNAMS,*)'Do you want to restart? (y) or (n)'
!!SEP02        CALL SYMBL(1.,6.20,0.20,FNAMS,0.,34)
!!SEP02        ndig=1
!!SEP02        call gtcharx(ans,ndig,6.,7.2)
!ipk oct96          READ(*,'(A)') ANS
!!SEP02          IF(ANS .EQ. 'y'  .OR.  ANS .EQ. 'Y') THEN
!!SEP02            IRESTT=1
!!SEP02            GO TO 1
!!SEP02          ENDIF
!!SEP02        CALL SETD(2)
        ENDIF

      ENDIF

      GOTO 100

      END


      SUBROUTINE RQUIT(IYES)

      USE WINTERACTER

      INCLUDE 'BFILES.I90'

      INCLUDE 'D.INC'

      IF(IRDONE .NE. 0) THEN
      CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you really wish to quit?'//&
                           CHAR(13)//' ','Quit option')
      ELSE
      CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'You have not reordered'//Char(13)//'Do you really wish to quit?'//&
                           CHAR(13)//' ','Quit option')
      ENDIF    
!
!   If answer 'No', return
!
       iyes=1
       IF (WInfoDialog(4).EQ.2) iyes=0
       return
       end