You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
145 lines
3.0 KiB
Fortran
145 lines
3.0 KiB
Fortran
5 years ago
|
SUBROUTINE FORMGP
|
||
|
|
|
||
|
|
USE WINTERACTER
|
||
|
|
USE BLK1MOD
|
||
|
|
include 'd.inc'
|
||
|
|
|
||
|
|
CHARACTER*47 MESSAGE
|
||
|
|
|
||
|
|
DATA MESSAGE /'Enter Group Number'/
|
||
|
|
|
||
|
|
DATA ITIME/0/
|
||
|
|
|
||
|
|
! SWITCH TO GROUP ACTIVITY
|
||
|
|
|
||
|
|
IF(IQSW(1) .EQ. 1) IQSW(1)=2
|
||
|
|
IF(IQSW(2) .EQ. 1) IQSW(2)=2
|
||
|
|
|
||
|
|
|
||
|
|
! IF FIRST TIME ASK TO LOAD FILE OR SET GROUPS = 1
|
||
|
|
|
||
|
|
if(ITIME .EQ. 0) THEN
|
||
|
|
! ALLOCATE ARRAY SIZES
|
||
|
|
|
||
|
|
IF(.NOT. ALLOCATED(IGRPNUM)) THEN
|
||
|
|
ALLOCATE (IGRPNUM(25,MAXE),MAXENT(25))
|
||
|
|
CALL TOPAR
|
||
|
|
ENDIF
|
||
|
|
ISW=2
|
||
|
|
ITIME=1
|
||
|
|
ELSE
|
||
|
|
CALL TOPAR
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
|
||
|
|
! ASSIGN A NUMBER TO THE NEW GROUP
|
||
|
|
|
||
|
|
call wdialogload(IDD_GETINT)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_GETINT)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogPutString(IDF_STRING1,MESSAGE)
|
||
|
|
CALL WDialogPutInteger(IDF_INTEGER1,ISW)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
! Branch depending on type of message.
|
||
|
|
!
|
||
|
|
DO
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
|
||
|
|
CALL WDialogGetInteger(IDF_INTEGER1,ISW)
|
||
|
|
GO TO 200
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
|
||
|
|
200 CONTINUE
|
||
|
|
|
||
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish add these elements to the current group?'//&
|
||
|
|
CHAR(13)//' ','ADD ELEMENTS?')
|
||
|
|
|
||
|
|
! If answer 'No', start afresh
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(4).EQ.2) then
|
||
|
|
|
||
|
|
! STORE GROUP NUMBERS STARTING AT 1
|
||
|
|
|
||
|
|
DO K=1,NEFL
|
||
|
|
IGRPNUM(ISW,K)=NEFLAG(K)
|
||
|
|
ENDDO
|
||
|
|
MAXENT(ISW)=NEFL
|
||
|
|
ELSE
|
||
|
|
!
|
||
|
|
! FOR EACH ELEMENT SEARCH FIRST IF NOT FOUND ADD TO THE END
|
||
|
|
|
||
|
|
DO K=1,NEFL
|
||
|
|
DO J=1,MAXENT(ISW)
|
||
|
|
IF(NEFLAG(K) .EQ. IGRPNUM(ISW,J)) GO TO 240
|
||
|
|
ENDDO
|
||
|
|
MAXENT(ISW)=MAXENT(ISW)+1
|
||
|
|
IGRPNUM(ISW,MAXENT(ISW))=NEFLAG(K)
|
||
|
|
240 CONTINUE
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
! REMOVE FROM OLD LIST
|
||
|
|
DO I=1,25
|
||
|
|
IF(I .NE. ISW) THEN
|
||
|
|
DO J=1,MAXENT(I)
|
||
|
|
DO K=1,NEFL
|
||
|
|
IF(NEFLAG(K) .EQ. IGRPNUM(I,J)) THEN
|
||
|
|
IGRPNUM(I,J)=0
|
||
|
|
GO TO 260
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
260 CONTINUE
|
||
|
|
ENDDO
|
||
|
|
JT=0
|
||
|
|
LIMIT=MAXENT(I)
|
||
|
|
J=0
|
||
|
|
270 J=J+1
|
||
|
|
275 IF(J+JT .LE. LIMIT) THEN
|
||
|
|
IF(IGRPNUM(I,J+JT) .EQ. 0) THEN
|
||
|
|
JT=JT+1
|
||
|
|
GO TO 275
|
||
|
|
ENDIF
|
||
|
|
IGRPNUM(I,J)=IGRPNUM(I,J+JT)
|
||
|
|
GO TO 270
|
||
|
|
ENDIF
|
||
|
|
DO J=MAXENT(I),MAXENT(I)+1-JT,-1
|
||
|
|
IGRPNUM(I,J)=0
|
||
|
|
ENDDO
|
||
|
|
MAXENT(I)=MAXENT(I)-JT
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
|
||
|
|
CALL TOSER
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE TOSER
|
||
|
|
USE BLK1MOD
|
||
|
|
DO I=1,25
|
||
|
|
DO J=1,MAXENT(I)
|
||
|
|
IGRPSER(IGRPNUM(I,J))=I
|
||
|
|
ENDDO
|
||
|
|
ENDDO
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE TOPAR
|
||
|
|
USE BLK1MOD
|
||
|
|
|
||
|
|
MAXENT=0
|
||
|
|
IGRPNUM=0
|
||
|
|
|
||
|
|
DO K=1,NE
|
||
|
|
I=IGRPSER(K)
|
||
|
|
MAXENT(I)=MAXENT(I)+1
|
||
|
|
IGRPNUM(I,MAXENT(I))=K
|
||
|
|
ENDDO
|
||
|
|
RETURN
|
||
|
|
END
|