PROGRAM SOPTIMZRX
C=======================================================================
C EIJI FUKUMORI JULY 2, 2010
C=======================================================================
IMPLICIT REAL*8 ( A-H , O-Z )
INCLUDE 'PARAM.DAT'
PARAMETER ( ND2=ND*12 )
CC PARAMETER ( ND=8, ND2=50, MXE=800000, MXN=800000, MXB=5000 )
C======================================================================
C
DIMENSION NODEX(MXE,ND),XCOORD(3,MXN)
DIMENSION IREL(MXN,ND2),INOD(MXN),NEW(MXN),JNT(MXN),
* NJNT(MXN),TEMP(MXN), IP(ND,ND), IBNDW(MXE)
DIMENSION NBFX(3),IBNDFX(3,MXB),BVX(3,MXB),
* NFORCEX(3),IBFORCEX(3,MXB), BVFORCEX(3,MXB)
CHARACTER INPFILE*14, OUTFILE*13, EXFILE*3
LOGICAL YES
C=======================================================================
WRITE (*,*) '======== WELCOME TO BANDWIDTH CRUNCHER ========'
C=======================================================================
C FILE MANAGEMENT
INPFILE = 'NONE'
IF ( ND .EQ. 8 ) THEN
INPFILE = 'STATIC3D08.DAT'
OUTFILE = 'STATIC3D08.DAT'
END IF
IF ( ND .EQ. 27 ) THEN
INPFILE = 'STATIC3D27.DAT'
OUTFILE = 'STATIC3D27.DAT'
END IF
IF ( INPFILE .EQ. 'NONE' ) STOP 'NO INPUT FILE SELECTED'
C=======================================================================
CALL PERMX ( ND, IP )
C=======================================================================
CALL INPUT ( INPFILE,MXE,MXN,MXB,ND,NE,NNODE,YOUNG,
* POISSON,NODEX,XCOORD,NBFX,IBNDFX,BVX,NFORCEX,IBFORCEX,BVFORCEX )
C=======================================================================
CALL BNDWDTH (ND, NODEX, MXE, NE, IBNDW )
C=======================================================================
CALL OPTIMX(ND,ND2,NODEX,IREL,INOD,NEW,JNT,NJNT,XCOORD,
* TEMP,MXE,MXN,NE,NNODE,IMP,IP,IBNDW )
IF ( IMP .GT. 0 ) THEN
EXFILE = 'NEW'
IW = 2
OPEN ( IW, FILE=OUTFILE, STATUS='UNKNOWN' )
WRITE (IW,*) YOUNG, POISSON
WRITE (IW,*) NE
DO I = 1 , NE
WRITE (IW,*) I, ( NODEX(I,J), J = 1 , ND )
END DO
WRITE (IW,*) NNODE
DO I = 1 , NNODE
WRITE (IW,*) I,XCOORD(1,I),XCOORD(2,I),XCOORD(3,I)
END DO
WRITE(IW,*) NBFX(1)
DO I = 1 , NBFX(1)
WRITE (IW,*) IBNDFX(1,I), BVX(1,I)
END DO
WRITE(IW,*) NBFX(2)
DO I = 1 , NBFX(2)
WRITE (IW,*) IBNDFX(2,I), BVX(2,I)
END DO
WRITE(IW,*) NBFX(3)
DO I = 1 , NBFX(3)
WRITE (IW,*) IBNDFX(3,I), BVX(3,I)
END DO
WRITE(IW,*) NFORCEX(1)
IF ( NFORCEX(1) .GT. 0 ) THEN
DO I = 1 , NFORCEX(1)
WRITE(IW,*) IBFORCEX(1,I), BVFORCEX(1,I)
END DO
ENDIF
WRITE(IW,*) NFORCEX(2)
IF ( NFORCEX(2) .GT. 0 ) THEN
DO I = 1 , NFORCEX(2)
WRITE(IW,*) IBFORCEX(2,I), BVFORCEX(2,I)
END DO
ENDIF
WRITE(IW,*) NFORCEX(3)
IF ( NFORCEX(3) .GT. 0 ) THEN
DO I = 1 , NFORCEX(3)
WRITE(IW,*) IBFORCEX(3,I), BVFORCEX(3,I)
END DO
ENDIF
CLOSE (IW)
WRITE (*,*) 'OPTIMIZED. WELL DONE'
ELSE
WRITE (*,*) 'SOORY NO IMPROVEMENT'
END IF
C
IW = 7
OPEN ( IW, FILE='BNDWDTH.FEM', STATUS='UNKNOWN' )
CALL BNDWDTH (ND, NODEX, MXE, NE, IBNDW )
WRITE (IW,*) 'ELEMENT BANDWIDTH'
DO I = 1 , NE
WRITE (IW,'(2I8)') I , IBNDW(I)+1
END DO
CLOSE (IW)
STOP
END
C
C
C--------0---------0---------0---------0---------0---------0---------0--
C=======================================================================
SUBROUTINE INPUT ( INPFILE,MXE,MXN,MXB,ND,NE,NNODE,YOUNG,
* POISSON,NODEX,XCOORD,NBFX,IBNDFX,BVX,NFORCEX,IBFORCEX,BVFORCEX )
IMPLICIT REAL*8 ( A-H , O-Z )
DIMENSION NODEX(MXE,ND),XCOORD(3,MXN)
DIMENSION NBFX(3),IBNDFX(3,MXB),BVX(3,MXB),
* NFORCEX(3),IBFORCEX(3,MXB), BVFORCEX(3,MXB)
CHARACTER*14 INPFILE
LOGICAL YES
C========> FILENAME NSDATA.FLN
INQUIRE ( FILE=INPFILE, EXIST=YES )
IF ( YES ) THEN
OPEN ( 1, FILE=INPFILE, STATUS='OLD' )
ELSE
WRITE (*,*)'INPUT FILE DOES NOT EXIST'
STOP
ENDIF
C========> PARAMETERS
READ (1,*) YOUNG, POISSON
C========> ELEMENTS
READ (1,*) NE
DO I = 1 , NE
READ (1,*) IEL, ( NODEX(IEL,J), J = 1 , ND )
END DO
C========> FILENAME COORDINATES OF NODAL POINTS
READ (1,*) NNODE
DO I = 1 , NNODE
READ (1,*) NODE,XCOORD(1,NODE),XCOORD(2,NODE),XCOORD(3,NODE)
END DO
C---------- DIRICHLET TYPE BOUNDARY CONDITIONS
READ(1,*) NBFX(1)
DO I = 1 , NBFX(1)
READ (1,*) IBNDFX(1,I), BVX(1,I)
END DO
READ(1,*) NBFX(2)
DO I = 1 , NBFX(2)
READ (1,*) IBNDFX(2,I), BVX(2,I)
END DO
READ(1,*) NBFX(3)
DO I = 1 , NBFX(3)
READ (1,*) IBNDFX(3,I), BVX(3,I)
END DO
C---------- NUEMANN TYPE BOUNDARY CONDITIONS
READ(1,*) NFORCEX(1)
IF ( NFORCEX(1) .GT. 0 ) THEN
DO I = 1 , NFORCEX(1)
READ(1,*) IBFORCEX(1,I), BVFORCEX(1,I)
END DO
ENDIF
READ(1,*) NFORCEX(2)
IF ( NFORCEX(2) .GT. 0 ) THEN
DO I = 1 , NFORCEX(2)
READ(1,*) IBFORCEX(2,I), BVFORCEX(2,I)
END DO
ENDIF
READ(1,*) NFORCEX(3)
IF ( NFORCEX(3) .GT. 0 ) THEN
DO I = 1 , NFORCEX(3)
READ(1,*) IBFORCEX(3,I), BVFORCEX(3,I)
END DO
ENDIF
C---------- FINAL
CLOSE (1)
RETURN
END
C
C
SUBROUTINE OPTIMX ( ND,ND2,NODEX,IREL,INOD, NEW, JNT, NJNT,XCOORD,
* TEMP,MXE,MXN,NE,NNODE,IMP,IP,IBNDW )
IMPLICIT REAL*8 ( A-H , O-Z )
DIMENSION NODEX(MXE,ND), IREL(MXN,ND2), INOD(MXN),
& NEW(MXN),JNT(MXN),NJNT(MXN),XCOORD(3,MXN),
* IP(ND,ND), TEMP(MXN),JTEMP(ND2), IBNDW(MXE)
C-------------------------------------------------------------------------
IW = 4
OPEN ( IW, FILE='OPTIMIZATION-STATUS.FEM', STATUS='UNKNOWN' )
C-------------------------------------------------------------------------
WRITE (*,*) 'OPTIMIZATION STARTED'
CALL SETUP( ND, ND2,NODEX,IREL,INOD,MXE,MXN,NE,NNODE,IBWOR,IP,
* IBNDW )
C-------------------------------------------------------------------------
IMP = 0
CALL OPTIM(ND2,IREL,INOD,JNT,NJNT,NEW,MXN,NNODE,IBWOR,MAXDIF,IMP)
IBW = MAXDIF
DO I = 1, NNODE
DO J = 1, INOD(I)
JTEMP(J) = IREL(I,INOD(I)-J+1)
END DO
DO K = 1, INOD(I)
IREL(I,K) = JTEMP(K)
END DO
END DO
WRITE (*,*) 'SECOND TRIAL'
CALL OPTIM(ND2,IREL,INOD,JNT,NJNT,NEW,MXN,NNODE,IBW,MAXDIF,IMP)
IF ( IMP .LE. 0 ) THEN
IBOLD = IBWOR + 1
WRITE(IW,*) '===== NODE NUMBERING CANNOT BE IMPROVED.====='
WRITE(IW,*) '===== HALF-BANDWIDTH REMAINS AT ', IBOLD,' ====='
RETURN
END IF
IBOLD = IBWOR + 1
MAXBWH = MAXDIF + 1
WRITE(IW,*) 'ORIGINAL HALF-BANDWIDTH =', IBOLD
WRITE(IW,*) 'REDUCED HALF-BANDWIDTH =', MAXBWH
DO I = 1, NE
DO J = 1, ND
NODEX(I,J) = NEW( NODEX(I,J) )
END DO
END DO
DO I = 1, NNODE
TEMP(I) = XCOORD(1,I)
END DO
DO I = 1, NNODE
XCOORD(1,NEW(I)) = TEMP(I)
TEMP(I) = XCOORD(2,I)
END DO
DO I = 1, NNODE
XCOORD(2,NEW(I)) = TEMP(I)
TEMP(I) = XCOORD(3,I)
END DO
DO I = 1, NNODE
XCOORD(3,NEW(I)) = TEMP(I)
END DO
C
WRITE(IW,*) 'NEW OPTIMIZED NODE NUMBERING:'
WRITE(IW,*) '(OLD NODE NO.--> NEW NODE NO.)'
WRITE(IW,'(5(1H(,I7,4H -->,I7,4H ) ))') (I,NEW(I),I=1,NNODE)
RETURN
END
C
C
SUBROUTINE OPTIM ( ND2,IREL,INOD,JNT,NJNT,NEW,MXN,NNODE,IDIFF,
& MAXDIF, IMP )
DIMENSION IREL(MXN,ND2),INOD(MXN),JNT(MXN),NJNT(MXN), NEW(MXN)
MAXDIF = IDIFF
DO 60 IX = 1, NNODE
IF ( IX/100*100 .EQ. IX ) WRITE(*,*)'OPTIMIZATION AT NODE =',IX
DO J = 1, NNODE
JNT(J) = 0
NJNT(J) = 0
END DO
MAX = 0
I = 1
NJNT(1) = IX
JNT(IX) = 1
K = 1
DO
DO JJ = 1, INOD(NJNT(I))
KX = IREL(NJNT(I),JJ)
IF ( JNT(KX) .LE. 0 ) THEN
K = K + 1
NJNT(K) = KX
JNT(KX) = K
NDIFF = IABS ( I - K )
IF ( NDIFF .GE. MAXDIF ) GO TO 60
MAX = MAX0 ( NDIFF, MAX )
END IF
END DO
IF ( K .EQ. NNODE ) EXIT
I = I + 1
END DO
MAXDIF = MAX
DO J = 1, NNODE
NEW(J) = JNT(J)
END DO
IMP = IMP + 1
60 CONTINUE
RETURN
END
C
C
SUBROUTINE SETUP (ND,ND2,NODEX,IREL,INOD,MXE,MXN,NE,NNODE,IBWOR,
* IP, IBNDW )
DIMENSION NODEX(MXE,ND),IREL(MXN,ND2),INOD(MXN),IP(ND,ND),
* IBNDW(MXE)
C
IBWOR = 0
DO NODE = 1, NNODE
KOUNT = 0
DO IEL = 1, NE
DO K = 1, ND
IF ( NODE .EQ. NODEX(IEL,IP(K,1)) ) THEN
DO J = 2, ND
CALL SQUENCE ( ND2,MXN,NODE,NODEX(IEL,IP(K,J)),KOUNT,IREL )
END DO
END IF
END DO
IBWOR = MAX0 ( IBNDW(IEL), IBWOR )
END DO
INOD(NODE) = KOUNT
IF ( NODE/100*100 .EQ. NODE ) WRITE(*,*)'SETUP AT NODE =',NODE
END DO
RETURN
END
C
C
SUBROUTINE SQUENCE ( ND2, MXN, NODE, IPNODE, KOUNT, IREL )
DIMENSION IREL(MXN,ND2)
IF ( KOUNT .GT. 0 ) THEN
DO L = 1, KOUNT
IF ( IREL(NODE,L) .EQ. IPNODE ) RETURN
END DO
END IF
KOUNT = KOUNT + 1
IREL(NODE,KOUNT) = IPNODE
RETURN
END
C
C
SUBROUTINE PERMX ( ND, IP )
DIMENSION IP(ND,ND)
DO I = 1 , ND
K = I
IP(I,1) = I
DO J = 2 , ND
K = K + 1
IF ( K .GT. ND ) K = K - ND
IP(I,J) = K
END DO
END DO
RETURN
END
C
C
SUBROUTINE BNDWDTH (ND, NODEX, MXE, NE, IBNDW )
DIMENSION NODEX(MXE,ND), IBNDW(MXE)
C
DO IEL = 1, NE
IBNDW(IEL) = 0
DO J = 1 , ND-1
DO K = J+1 , ND
IBNDW(IEL) = MAX0(IBNDW(IEL),IABS(NODEX(IEL,J)-NODEX(IEL,K)))
END DO
END DO
END DO
RETURN
END