!IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR REORDERING SUBROUTINE ORDDIR USE BLK1MOD USE BLK2MOD INCLUDE 'BFILES.I90' ! COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout REAL*8 XPROJ(100000) NCM=MAXECON NCMI=MAXECON NAD=0 MP=0 IPASS=1 ! ! GET TABLE OF ELEMENT CONNECTIONS ! ISWW=0 CALL KCON(ISWW) ISWALL=0 nmess=47 IF(.NOT. ALLOCATED(NKEY1)) THEN ALLOCATE (NKEY1(MAXE)) ENDIF DIRD=0. CALL GETFPN(DIRD) ! IF(ISWALL .EQ. 0) ISWALL=1 ISW=0 DIR=DIRD*3.14159/180. DO N=1,NE IF(IMAT(N) .NE. 0) THEN XPROJ(N)=XC(N)*COS(DIR)+YC(N)*SIN(DIR) ELSE XPROJ(N)=1.E15 ENDIF ENDDO CALL SORTDB(XPROJ,NKEY1,NE) IRDONE=1 DO N=1,NE ILIST(1,N)=NKEY1(N) ENDDO ! PROCESS INITIAL ORDER ! CALL REORD(ISW,ISWALL) ! CALL WMessageBox(0,4,1,'REORDERING COMPLETE',' ') ! CALL WCursorShape(CurArrow ) ! ! Restore screen ! !pk jan98 WRITE(*,*) 'Press "Return" to restore grapical screen' CALL SHOWORD RETURN END !IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR REORDERING SUBROUTINE ORDALL INCLUDE 'BFILES.I90' COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout ISWALL=1 nmess=45 CALL GETINT(ISWALL) IF(ISWALL .EQ. 0) ISWALL=1 ISW=0 CALL REORD(ISW,ISWALL) CALL WMessageBox(0,4,1,'REORDERING COMPLETE',' ') IRDONE=1 RETURN END !IPK LAST UPDATE JULY 11 2005 FIX BUG IN REORDERING !ipk last update Nov 18 1996 ! Last change: IPK 12 Jan 98 2:06 pm !ipk last update Jan 6 1997 disallow negative sums SUBROUTINE ADDORD(ISW) ! ! Enter reordering sequence ! USE WINTERACTER USE BLK1MOD INCLUDE 'BFILES.I90' ! INCLUDE 'BLK1.COM' !iPK APR94 COMMON /RECOD/ IRECD,TSPC ! dimension ilisttmp(100) ! CHARACTER*1 IFLAG CHARACTER*14 HEADR CHARACTER*60 STRELS CHARACTER*80 LIND ! INTEGER*2 IPAG,NT DATA MULTPG/0/ DATA STRELS/' You have tried to reorder before executing "FILL"'/ DATA XPRT/0./ ! ! Test to make sure fill has been executed. ! IF(ISW .NE. 1) THEN DO 70 N=1,NE IF(IMAT(N) .GT. 0) THEN DO 60 M=2,NCORN(N),2 !ipkoct93 if(imat(n) .gt. 900) go to 60 IF(NOP(N,M) .EQ. 0) THEN CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK, & 'You have tried to reorder before executing "FILL"'//CHAR(13) & //'Reordering terminated',& 'UNABLE TO REORDER') ! CALL SYMBL(0.,7.30,0.20,STRELS,0.,60) RETURN ENDIF 60 CONTINUE ENDIF 70 CONTINUE ENDIF ! ! IF(ISW .EQ. 0) THEN ! ! Change screens if possible ! IF(MULTPG .EQ. 1) THEN ! IPAG=1 ! NT=SETACTIVEPAGE(IPAG) ! NT=SETVISUALPAGE(IPAG) ELSE CALL CLSCRN CALL SETD(23) ENDIF ISWW=0 CALL WCursorShape(CurHourGlass ) ISWALL=0 CALL REORD(ISWW,ISWALL) IRDONE=1 !IPK AUG05 CALL REORD(ISWW) CALL WCursorShape(CurArrow ) ! ! Restore screen ! !pk jan98 WRITE(*,*) 'Press "Return" to restore grapical screen' CALL SHOWORD ! WRITE(LIND,6002) ! 6002 FORMAT( 'Press "Return" to restore grapical screen') ! call rblue ! call symbl & ! & (1.1,3.0,0.20,LIND,0.0,80) ! ndig=1 ! CALL GTCHARX(IFLAG,NDIG,5.0,7.6) !ipk jan98 READ(*,'(A)') IFLAG IF(MULTPG .EQ. 1) THEN IPAG=0 ! NT=SETACTIVEPAGE(IPAG) ! NT=SETVISUALPAGE(IPAG) ELSE CALL CLSCRN CALL SETD(2) ! CALL PLOTS(0) !ipk nov97 add (1) CALL PLOTOT(1) do n=1,ne nn=iem(n) if(imat(nn) .ne. 0 .AND. IESKP(NN) .EQ. 0) then call fillemC(nn,MOD(N/25,15)) endif ! if(mod(n,200) .eq. 0) then ! READ(*,'(A)') IFLAG ! endif enddo ENDIF ELSEIF(ISW .EQ. 1) THEN 100 continue ! 100 WRITE(HEADR,5000) NLST ! 5000 FORMAT(' NLIST = ',I5) ! NHTP = 0 ! NMESS = 13 ! NBRR = 0 ! CALL HEDR ! CALL SYMBL(0.,7.50,0.20,HEADR,0.,14) ! XPRT=3.2 ! ! Form element reordering list by clicking on elements with cursor ! 5001 FORMAT(I10) ! CALL GETINT(NLIST) ! READ(*,5001,ERR=220) NLIST ! ! Find element nearest cursor ! J=0 200 IBOX=1 NMESS = 12 NBRR = 9 CALL HEDR CALL PLOTORDS INREORD=1 CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX) INREORD=0 CALL PLOTORDS ! write(90,*) 'reord' ! write(90,'(i10,a10)') ibox,iflag IF(IRMAIN .EQ. 1) THEN DO J=1,100 ilisttmp (j)=0 ENDDO RETURN ENDIF 210 IF(IFLAG .EQ. 'c' .and. ibox .ne. 7) THEN CALL FILLEM(IELEM) XPRT=XPRT+0.5 IF(XPRT .GT. HSIZE) XPRT=0. FPN= IELEM CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1) J=J+1 ilisttmp (j)=ielem ! ILIST(NLIST,J)=IELEM GO TO 200 ELSEIF (IFLAG .EQ. 'U') THEN ilisttmp (j)=0 J=J-1 CALL PLOTOT(1) CALL HEDR DO IELEM=1,J CALL FILLEM(ILISTTMP(IELEM)) ENDDO GO TO 200 ELSEIF(IFLAG .EQ. 'e') THEN ! LLIST(NLIST)=J nlist=nlst+1 call getnlist(nlist) LLIST(NLIST)=J do i=1,j ilist(nlist,i)=ilisttmp(i) enddo IF(NLIST .GT. NLST) NLST=NLIST DO J=1,100 ilisttmp (j)=0 ENDDO GO TO 100 ELSEIF(IFLAG .EQ. 'a' .or. ibox .eq. 7) THEN nlist=nlst+1 IF(IRECD .NE.2) call getnlist(nlist) LLIST(NLIST)=J do i=1,j ilist(nlist,i)=ilisttmp(i) enddo IF(NLIST .GT. NLST) NLST=NLIST DO J=1,100 ilisttmp (j)=0 ENDDO GO TO 100 ELSEIF(IFLAG .EQ. 'q') THEN ! LLIST(NLIST)=J ! IF(NLIST .GT. NLST) NLST=NLIST ! CALL REORD(NLIST) ! CALL WRTOUT(0) DO J=1,100 ilisttmp (j)=0 ENDDO ENDIF ELSEIF(ISW .EQ. 2) THEN ! ! Change screens if possible ! IF(MULTPG .EQ. 1) THEN IPAG=1 ! NT=SETACTIVEPAGE(IPAG) ! NT=SETVISUALPAGE(IPAG) ELSE CALL CLSCRN CALL SETD(23) ENDIF ISWW=NLIST ISWALL=0 CALL REORD(ISWW,ISWALL) !IPK AUG05 CALL REORD(ISWW) ! ! Restore screen ! !IPK JAN98 WRITE(*,*) 'Press "Return" to restore grapical screen' !IPK JAN98 READ(*,'(A)') IFLAG CALL SHOWORD ! WRITE(LIND,6002) ! call symbl & ! & (1.1,3.0,0.20,LIND,0.0,80) ! ndig=1 ! CALL GTCHARX(IFLAG,NDIG,5.0,7.6) IF(MULTPG .EQ. 1) THEN IPAG=0 ! NT=SETACTIVEPAGE(IPAG) ! NT=SETVISUALPAGE(IPAG) ELSE CALL CLSCRN CALL SETD(2) ! CALL PLOTS(0) !ipk nov97 add (1) CALL PLOTOT(1) ENDIF ENDIF 220 RETURN END SUBROUTINE REORD (ISW,ISWALL) ! ! DRIVING ROUTINE TO REORDER ELEMENTS ! USE BLK1MOD USE BLK2MOD ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' ! ! INITIALIZE ! IF(IECHG .EQ. 0) THEN NCM=MAXECON NCMI=MAXECON NAD=0 MP=0 IPASS=1 ! ! GET TABLE OF ELEMENT CONNECTIONS ! ISWW=0 CALL KCON(ISWW) IF(ISWW .EQ. -1) RETURN ! ! SETUP NELIM. IDENTIFIES 3 NODE ELEMENTS OR JUNCTIONS WHEN = 1 ! DO 250 N=1,NE IF(IMAT(N) .NE. 0) THEN !ipkoct93 IF(NCORN(N) .EQ. 3 .OR. (IMAT(N) .GT. 900 .and. & & ncorn(n) .ne. 8)) THEN NELIM(N)=1 ELSE NELIM(N)=0 ENDIF ELSE NELIM(N)=1 ENDIF 250 CONTINUE IECHG=1 !IPK MAY03 ICHG=0 ! ! PROCESS INITIAL ORDER ! IF(ISW .EQ. 0) THEN CALL ORDER(ISWALL) ISW=ISW+1 ENDIF ENDIF IF(ISW .EQ. 0) ISW=1 ! ! OTHERWISE RESET MLIST ! 305 DO 310 N=1,NAE MLIST(N)=0 310 END DO ! ! SET STARTING SEQUENCE ! !IPK AUG05 IF(ISWALL .EQ. 0) THEN NN=1 DO 320 N=1,NAE MLIST(NN)=ILIST(ISW,N) IF(NN .GT. 1) THEN IF(MLIST(NN) .EQ. MLIST(NN-1)) THEN NN=NN-1 ENDIF !IPK JUL05 FIX BUG MOVE DOWN NN=NN+1 ENDIF NN=NN+1 ! write(90,*) 'Entries forming start of list',n,mlist(n) IF(MLIST(N) .EQ. 0) GO TO 325 320 END DO ELSE 322 CONTINUE IF(MOD(ISW,ISWALL) .EQ. 0) THEN MLIST(1)=ISW ELSE ISW=ISW+1 GO TO 322 ENDIF ENDIF ! 325 MP=0 NAD=0 ! ! RESET NODE TO ELEMENT LIST ! DO 340 N=1,NP DO 335 M=1,NCM IF(NECON(N,M) .EQ. 0) GO TO 338 335 CONTINUE 338 NDELM(N)=M-1 340 END DO ! ! RESET ELEMENT CONNECTIONS ! DO 350 N=1,NE DO 350 M=1,NCMI ICON(N,M)=IABS(ICON(N,M)) 350 CONTINUE ! ! GO TO PROCESS THIS SEQUENCE ! IF(MLIST(1) .GT. 0) THEN CALL ORDER(ISWALL) ISW=ISW+1 ELSE GO TO 600 ENDIF IF(ISWALL .EQ. 0) THEN IF(ISW .GT. NLST) GO TO 600 ELSE WRITE(90,*) MLIST(1),MTSUMSV(NSEQ),NFWSV(NSEQ),IEM(1),MRSUM IF(ISW .GT. NE) GO TO 600 ENDIF GO TO 305 ! ! PRINT FINAL ORDER ! 600 WRITE(90,6040) (IEM(K),K=1,NAE) 6040 FORMAT(//' SELECTED ELEMENT ORDER'/(10I6)) ! ! RETURN TO MAIN ! RETURN END SUBROUTINE ORDER(ISWALL) ! ! FIND ORDER AND FRONT SUM FOR A GIVEN START POINT ! USE BLK1MOD USE BLK2MOD ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' ! ! SET LIST OF INCORPORATED NODES ! DO 200 N=1,NP 200 NINC(N)=0 ! ! SET COUNTER ON ELEMENTS ! KNT=0 MTSUM=0 !ipk feb97 add mtsum1 mtsum1=0 !IPK MAY94 LINE ADDED NFWSAV=0 ! ! PROCESS THROUGH ELEMENTS ! 300 CONTINUE ! ! SET MLIST FROM INPUT IF NON-ZERO WE MUST FIND KREC ! KREC=MLIST(KNT+1) ! ! GET NEXT ELEMENT TO ADDED ! CALL MOVFNT(KREC,ISWALL) !ipk mar04 IF(KREC .lt. 0) THEN write(90,*) 'krec',knt,mlist(knt) MTSUM=9999999999999 MTSUM1=9999999999999 GO TO 310 ENDIF ! ! SAVE SELECTED VALUE ! MLIST(KNT+1)=KREC KNT=KNT+1 ! ! UPDATE FRONT AND CONNECTION TABLES ! CALL UPFNT(KREC) ! ! TEST FOR FULL SET OF ELEMENTS ! IF (KNT.LT.NAE) GO TO 300 WRITE(90,9000) KREC,MTSUM,MSUM,MP,NAD 9000 FORMAT(' KREC MTSUM MSUM MP NAD'/I6,2I15,2I5) ! ! FOR COMPLETE ORDER CHECK IF IT IS IMPROVEMENT ! !IPK MAR04 310 CONTINUE CALL CHKOUT(ISWALL) ! ! FINISHED ! RETURN END SUBROUTINE MOVFNT(KREC,ISWALL) ! ! GET ELEMENT THAT INCREASES FRONT WIDTH LEAST ! USE BLK1MOD USE BLK2MOD ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' INTEGER*8 MSAV,MSA CHARACTER*80 LIND CHARACTER*1 JUNK ! ! INITIALIZE ! MSAV=99999999 NSN=99999 ! ! SKIP IF KREC ALREADY DEFINED ! IF(KREC .GT. 0) GO TO 310 ! ! SEARCH ADJACENT ELEMENTS ! NTST=NITST 260 NFD=0 if(nad .eq. 0) then !IPK JAN98 write(*,*) 'nad in trouble type q and press return,enxt(1)',enxt(1) !IPK JAN98 read(*,*) njunk !ipk mar04 WRITE(LIND,6002)krec,nsn !ipk mar04 6002 FORMAT( 'NAD =0 illegal connection. krec,nsn',2i5,'Type q to exit') !ipk mar04 call symbl & !ipk mar04 & (1.1,3.0,0.20,LIND,0.0,80) !ipk mar04 ndig=1 !ipk mar04 CALL GTCHARX(JUNK,NDIG,5.0,7.6) !ipk mar04 stop IF(ISWALL .GT. 0) THEN KREC=-1 RETURN ENDIF write(90,*) nae write(90,'(5(i7,i6))') (n,mlist(n),n=1,ne) CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK, & 'No active adjacent elements found '//CHAR(13) & //'Possible network error.'//CHAR(13) & //'or erroneous starting element'//CHAR(13) & //'Reordering terminated',& 'ERROR') krec=-1 return endif DO 300 K=1,NAD NEL=ENXT(K) IF(NTST .EQ. 0) GO TO 270 IF(NELIM(NEL) .EQ. 1) GO TO 300 270 CONTINUE NFD=1 ! ! GET SUMS FOR NEL ! CALL SUMIT(NEL) ! ! MSA IS THE AVERAGE PER NODE ADDED ! MSA=MSUM ! MSA=9999999 IF(NDP .GT. 1) MSA=(MSUM+NDP/2)/NDP ! ! CHECK IF IT IS LESS ! IF (MSA.GT.MSAV) GO TO 300 IF (MSA.LT.MSAV) GO TO 280 ! ! IF EQUAL TAKE CASE WITH LEAST NODES ADDED ! IF (NDP.GE.NSN) GO TO 300 280 KREC=NEL NSN=NDP MSAV=MSA 300 END DO IF(NFD .EQ. 0) THEN NTST=0 GO TO 260 ENDIF 310 CONTINUE ! ! GET INFORMATION AGAIN FOR SELECTED ELEMENT ! CALL SUMIT(KREC) !IPK MAY94 ADD A LINE IF(NFWS .GT. NFWSAV) NFWSAV=NFWS IF(MSUM .EQ. 9999999) MSUM=0 MTSUM=MTSUM+MSUM !ipk feb97 add pseudo double precision 320 continue ! if(mtsum .gt. 100000000) then ! mtsum1=mtsum1+1 ! mtsum=mtsum-100000000 ! go to 320 ! endif ! ! UPDATE LIST OF NODES IN FRONT ! MPN=MP IF (MP.EQ.0) GO TO 420 IF (NDP.EQ.0) GO TO 420 ! ! REMOVE THE DROPPED NODES ! ! ict2=ict2+1 ! write(88,*) ict2,'z',krec,ndp,(ndrop(n),n=1,ndp) DO 400 N=1,NDP ! ! FIND THE NODE TO BE DROPPED IN LIST ! DO 390 M=1,MP IF (LIST(M).NE.NDROP(N)) GO TO 390 LIST(M)=-LIST(M) GO TO 400 390 CONTINUE 400 END DO ! ! NOW DROP THEM ! MPN=0 DO 410 M=1,MP IF (LIST(M).LT.0) GO TO 410 MPN=MPN+1 LIST(MPN)=LIST(M) 410 END DO ! ! NOW ADD NEWLY GENERATED NODES ! IF (NNEW.EQ.0) GO TO 435 420 DO 430 M=1,NNEW ! ! FIRST SEE IF LNEW IS IN DROP LIST ! IF(NDP .EQ. 0) GO TO 428 DO 425 N=1,NDP IF(LNEW(M) .EQ. NDROP(N)) GO TO 430 425 CONTINUE 428 CONTINUE MPN=MPN+1 LIST(MPN)=LNEW(M) K=LNEW(M) NINC(K)=1 430 END DO ! ! REDUCE COUNT OF ELEMENTS ACQUIRED AT THE NODES OF THE ELEMENT ! 435 CONTINUE MP=MPN ! ict1=ict1+1 ! write(85,*) ict1,'x',krec,mp,(list(n),n=1,mp) DO 440 K=1,8 N=NOP(KREC,K) IF (N.EQ.0) GO TO 440 NDELM(N)=NDELM(N)-1 440 END DO RETURN END SUBROUTINE UPFNT(KREC) ! ! DEFINE NEW INFO ON FRONT ! USE BLK1MOD USE BLK2MOD ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' ! ! SET ICON ENTRIES NEGATIVE TO SAY THIS ELEMENT ALREADY ADDED ! DO 450 M=1,NCMI K=ICON(KREC,M) IF (K.EQ.0) GO TO 460 IF (K.LT.0) GO TO 450 DO 430 J=1,NCMI IF (ICON(K,J).NE.KREC) GO TO 430 ICON(K,J)=-ICON(K,J) GO TO 450 430 CONTINUE 450 END DO ! ! UPDATE LIST OF ELEMENTS STILL IN FRONT ! 460 MNAD=0 ! ! FIRST ELIMINATE KREC ! IF(NAD .EQ. 0) GO TO 510 DO 500 K=1,NAD IF (ENXT(K).EQ.KREC) GO TO 500 MNAD=MNAD+1 ENXT(MNAD)=ENXT(K) 500 END DO 510 CONTINUE NAD=MNAD ! ! NOW ADD NEW ELEMENTS ! DO 520 J=1,NCMI K=ICON(KREC,J) IF (K.LE.0) GO TO 520 ! ! CHECK OF -K- ALREADY IN LIST ! DO 515 M=1,NAD IF(K .EQ. ENXT(M)) GO TO 520 515 CONTINUE MNAD=MNAD+1 ENXT(MNAD)=K 520 END DO NAD=MNAD RETURN END SUBROUTINE SUMIT(NEL) ! ! DEVELOP SUMS FOR MAKING ELIMINATION CHOICE ! USE BLK1MOD USE BLK2MOD INTEGER*8 MSUMP ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' ! ! LOCATE NEW NODES ! NDP=0 NNEW=0 DO 280 K=1,8 N=NOP(NEL,K) IF (N.EQ.0) GO TO 280 ! ! TEST WHETHER THIS NODE ALREADY INCORPORATED ! IF (NINC(N).EQ.1) GO TO 260 NNEW=NNEW+1 LNEW(NNEW)=N ! ! NOW TEST IF THE NODE IS COMPLETELY FORMED ! 260 IF (NDELM(N).GT.1) GO TO 280 NDP=NDP+1 NDROP(NDP)=N 280 END DO ! ! IMMEDIATELY ON ADDING NEW FRONT SIZE IS ! NFW=MP+NNEW !IPK MAY94 ADD A LINE NFWS=NFW ! ! NOW TAKE OUT ALL WE CAN ! MSUM=99999999 ! MSUM=0 IF(NDP .EQ. 0) RETURN MSUMP=0 DO 300 K=1,NDP MSUMP=MSUMP+NFW**2 NFW=NFW-1 300 END DO msum=msump if(msum .gt. 99999999) THEN write(90,*) ndp,msum,nfw,nel ENDIF RETURN END SUBROUTINE CHKOUT(ISWALL) ! ! CHECK FINAL TOTAL SAVE ORDER IF BETTER ! USE BLK1MOD USE BLK2MOD ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' CHARACTER*80 LIND ! DATA ITIME/0/ IF(ITIME .EQ. 0) THEN ! call rblue ! call clscrn ! YT=7.5 ! WRITE(90,6010) mtsum1,MTSUM,NFWSAV ! WRITE(LIND,6010) mtsum1,MTSUM,NFWSAV ! WRITE(90,6010) MTSUM,NFWSAV ! WRITE(LIND,6010) MTSUM,NFWSAV ! call symbl & ! & (0.1,YT,0.20,LIND,0.0,80) NSEQ=0 MTSUMSV(NSEQ)=MTSUM NFWSV(NSEQ)=NFWSAV ! elseif(mtsum1 .gt. mrsum1) then ! WRITE(90,6020) mtsum1,MTSUM,NFWSAV ! WRITE(LIND,6020) mtsum1,MTSUM,NFWSAV ! YT=YT-0.3 ! call symbl & ! & (0.1,YT,0.20,LIND,0.0,80) ! RETURN ! elseif(mtsum1 .eq. mrsum1) then !IPK AUG05 ELSE ELSEIF(ISWALL .EQ. 0) THEN NSEQ=NSEQ+1 MTSUMSV(NSEQ)=MTSUM NFWSV(NSEQ)=NFWSAV if(mtsum .ge. mrsum .AND. MRSUM .GT. 0) then ! WRITE(90,6020) mtsum1,MTSUM,NFWSAV ! WRITE(LIND,6020) mtsum1,MTSUM,NFWSAV ! WRITE(90,6020) MTSUM,NFWSAV ! WRITE(LIND,6020) MTSUM,NFWSAV ! YT=YT-0.3 ! call symbl & ! & (0.1,YT,0.20,LIND,0.0,80) RETURN else ! WRITE(90,6020) mtsum1,MTSUM,NFWSAV ! WRITE(LIND,6020) mtsum1,MTSUM,NFWSAV ! WRITE(90,6020) MTSUM,NFWSAV ! WRITE(LIND,6020) MTSUM,NFWSAV ! YT=YT-0.3 ! call symbl & ! & (0.1,YT,0.20,LIND,0.0,80) endif ! ELSE ! WRITE(90,6020) mtsum1,MTSUM,NFWSAV ! WRITE(LIND,6020) mtsum1,MTSUM,NFWSAV ! WRITE(90,6020) MTSUM,NFWSAV ! WRITE(LIND,6020) MTSUM,NFWSAV ! YT=YT-0.3 ! call symbl & ! & (0.1,YT,0.20,LIND,0.0,80) ELSE ! NSEQ=NSEQ+1 if(mtsum .ge. mrsum .AND. MRSUM .GT. 0) then NSEQ=0 MTSUMSV(NSEQ)=MTSUM NFWSV(NSEQ)=NFWSAV RETURN ELSE NSEQ=0 MTSUMSV(NSEQ)=MTSUM NFWSV(NSEQ)=NFWSAV endif ENDIF ! mrsum1=mtsum1 MRSUM=MTSUM ITIME=1 ! 6010 FORMAT('ORDERING SUM, ORIGINAL ELEMENT ORDER, MAX FRONT' & ! &,I4,I8.8,I7) ! 6020 FORMAT('ORDERING SUM, LATEST START POINT, MAX FRONT' & ! &,I4,I8.8,I7) 6010 FORMAT('ORDERING SUM, ORIGINAL ELEMENT ORDER, MAX FRONT' & &,I12,I7) 6020 FORMAT('ORDERING SUM, LATEST START POINT, MAX FRONT' & &,I12,I7) !ipk feb97 end changes ! ! COPY ORDER ! DO 300 N=1,NAE IEM(N)=MLIST(N) 300 END DO ! ! FILL IEM ARRAY ! NAEP=NAE+1 DO 400 N=1,NE IF(IMAT(N) .EQ. 0) THEN IEM(NAEP)=N NAEP=NAEP+1 ENDIF 400 END DO RETURN END SUBROUTINE KCON(isw1) use winteracter USE BLK1MOD USE BLK2MOD ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' ! implicit none include 'D.inc' ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE ! ! ESTABLISH ELEMENT CONNECTED TO ELEMENT TABLE ! ! ! INITIALIZE ! DO 200 J=1,NCM DO 200 N=1,NP 200 NECON(N,J)=0 DO 210 J=1,NCMI DO 210 M=1,NE 210 ICON(M,J)=0 DO 230 N=1,NP 230 NDELM(N)=0 ! ! FORM TABLE OF ELEMENTS CONNECTED TO EACH NODE ! DO 300 M=1,NE IF(IMAT(M) .EQ. 0) GO TO 300 if(isw1 .eq. 1) then if(imat(m) .eq. 999) go to 300 endif DO 280 K=1,8 N=NOP(M,K) IF (N .GT. 0) THEN NDELM(N)=NDELM(N)+1 J=NDELM(N) NECON(N,J)=M !ipkoct93 ELSE !ipkoct93 GO TO 300 ENDIF 280 CONTINUE 300 END DO ! do n=1,np ! write(87,'(31i6)') n,(necon(n,j),j=1,ncmi) ! enddo ! write(89,*) 'yy' ! DO N=1,NP ! WRITE(89,*) 'NDELM',N,NDELM(N) ! ENDDO ! ! CONVERT TABLE TO ELEMENT TO ELEMENT CONNECTION ! DO 600 N=1,NP ! ! PLACE PAIRS OF ENTRIES FOR EACH NODE INTO APPROPRIATE ROWS ! NL=NDELM(N)-1 ! ! SKIP OUT WHEN ONE ELEMENT OR LESS NODE ! IF (NL.LE.0) GO TO 600 DO 420 J=1,NL M=NECON(N,J) ! ! PROCESS SECOND ELEMENT IN A GIVEN ROW ! DO 370 K=J+1,NL+1 MR=NECON(N,K) MS=M ! ! PROCESS EACH DIRECTION OF CONNECTION ! DO 360 MX=1,2 ! ! SEARCH IN CASE CONNECTION ALREADY FOUND ! DO 350 L=1,NCMI IF (ICON(MS,L).NE.0) GO TO 345 ICON(MS,L)=MR GO TO 355 345 IF (ICON(MS,L).EQ.MR) GO TO 355 350 CONTINUE ! ! REVERSE MR-MS FOR SECOND PASS ! 355 CONTINUE MS=MR MR=M 360 CONTINUE ! ! END LOOP ON SECOND ELEMENT ! 370 CONTINUE ! ! END LOOP ON FIRST ELEMENT ! 420 CONTINUE ! ! END LOOP FOR THIS NODE ! 600 END DO DO M=1,NE IF(IMAT(M) .LT. 1) CYCLE IF(ICON(M,1) .EQ. 0) THEN call wdialogload(IDD_NOCONNECT) CALL WDialogSelect(IDD_NOCONNECT) ierr=infoerror(1) CALL WDialogPutInteger(idf_integer1,m) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) do IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN ISW1=-1 RETURN ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN ENDIF ENDDO ENDIF 610 CONTINUE ENDDO ! do n=1,ne ! write(86,'(31i6)') n,(icon(n,j),j=1,ncmi) ! enddo ! ! PROCESS TO FIND NUMBER OF ACTIVE ELEMENTS ! NAE=0 NTE=NE+1 DO 700 M=1,NE IF (IMAT(M) .LT. 1) GO TO 650 NAE=NAE+1 MLIST(NAE)=M GO TO 700 650 NTE=NTE-1 MLIST(NTE)=M 700 END DO RETURN END !ipk jan01 subroutine getnlist(ipos) use winteracter implicit none include 'd.inc' INTEGER :: IPOS,IERR ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE call wdialogload(IDD_DIALOG001) ierr=infoerror(1) CALL WDialogSelect(IDD_DIALOG001) ierr=infoerror(1) CALL WDialogPutINTEGER(IDF_INTEGER1,IPOS) ! write(90,*) 'iposin',ipos CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) do IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN CALL WDialogGetINTEGER(IDF_INTEGER1,IPOS) ! write(90,*) 'iposout',ipos return endif return enddo RETURN END !ipk jan04 subroutine SHOWORD use winteracter USE BLK1MOD USE BLK2MOD ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' include 'd.inc' INTEGER :: IERR CHARACTER*6 SCOL1(101) CHARACTER*18 SCOL2(101) CHARACTER*8 SCOL3(101) ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE call wdialogload(IDD_ORDEROUT) ierr=infoerror(1) CALL WDialogSelect(IDD_ORDEROUT) ierr=infoerror(1) DO I=0,NSEQ WRITE(SCOL1(I+1),'(I4)') I WRITE(SCOL2(I+1),'(I16)') MTSUMSV(I) WRITE(SCOL3(I+1),'(I8)') NFWSV(I) ENDDO CALL WGridPutString(IDF_GRID1,1,SCOL1,NSEQ+1) CALL WGridPutString(IDF_GRID1,2,SCOL2,NSEQ+1) CALL WGridPutString(IDF_GRID1,3,SCOL3,NSEQ+1) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) do IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN return endif enddo RETURN END