Next: Recent changes Up: FG-User-Routines Previous: Overview
Next: Recent changes
Up: FG-User-Routines
Previous: Overview
PROGRAM UFEM
C U F E M
C =======
C
C ******************************************************************
C *
C * PURPOSE :- OPEN A FEMGEN DATABASE, SCAN IT, AND WRITE OUT
C * MODEL DATA TO FILE.
C *
C ******************************************************************
C
C --- SUBROUTINES CALLED
C
EXTERNAL USTRT2,USLCHA,UWRITE,UREAD,UDECOD,UA1CHA,USIZE,UNAMG2,
+ UTITLE,UNODE,UGELEM,UELEM,JAPRE,UCSYS2,UPNT2,UCOCYL,
+ UCONS3,UMAT3,UPHYS3,ULOAD3,UNODEG,ULOADE,UELEMG,UFACEG,
+ UCLOS, UMATE, UPHYSE, URBEAM, UCONCT, URBODY, UBDRY3,
+ UEQUA, ULEVAL, UCURVT, UPRESC, UEFACE
C
C --- LOCAL VARIABLES
C
PARAMETER(IWDIM=100000, IWDIM2=1000, LU1=1, MAXNAM=20)
DIMENSION IWORK(IWDIM), WORK(IWDIM2), IBUF(16), IMAP(20), IPNE(9)
DIMENSION NCONST(20), IPRMPT(80), IREPLY(80), COORD(3), IELEM(27)
DIMENSION IELEM2(27), AXES(6), AXES2(6), P1(3),P2(3), ICONST(16)
DIMENSION LNAMES(MAXNAM), U(3), V(3), AXESO(3,3)
CHARACTER ANAME*8, FNAME*79, TNAME*20, CTYPE*8, TCNAM*8, CNAME*8
CHARACTER*80 CNAMES(MAXNAM)
DIMENSION IDOF1(16), IDOF2(16), IDOFM(16), IDOFS(16)
DIMENSION IDOFL(16,100), COEFFS(100)
C
C --- LOCAL DATA
C
DATA IMAP/0,0,3,0,4,0,3,0,4,4,2,0,2,2,2,0,2,0,0,0/
C
C ******************************************************************
C * *
C * CODE STARTS *
C * *
C ******************************************************************
C
C ------------------------------------------------------------------
C *** OPEN FEMGEN DATABASE ***
C ------------------------------------------------------------------
C
C --- PROMPT USER FOR DATABASE NAME
C
10 FNAME = ' '
WRITE(*,*)
WRITE(*,'(A$)') ' ENTER FULL NAME OF FEMGEN DATABASE >'
READ(*,'(A)',ERR=10) FNAME
C
C --- OPEN DATABASE
C
CALL USTRT2(FNAME,IWORK,IWDIM,IERR)
IF( IERR.EQ.1 ) THEN
WRITE(*,'(A)') 'ERROR: DATABASE DOES NOT EXIST'
GOTO 10
ELSEIF( IERR.EQ.2 ) THEN
WRITE(*,'(A)') 'ERROR: FILE IS NOT A FEMGEN DATABASE'
GOTO 10
ELSEIF( IERR.EQ.9 ) THEN
WRITE(*,'(A)') 'ERROR: IWORK ARRAY IS TOO SMALL'
GOTO 9999
ENDIF
C
C --- OUTPUT TEXT. NOTE THAT THE FEMGEN DIALOG ROUTINES CAN ONLY BE
C USED AFTER THE CALL TO USTRT2 WHICH ALSO INITIALISES CERTAIN
C INTERNAL COMMON BLOCKS.
C
CALL USLCHA(' *.',1,IPRMPT,ILAST)
CALL UWRITE(IPRMPT,ILAST)
CALL USLCHA('FEMGEN DATABASE OPENED ...*.',1,IPRMPT,ILAST)
CALL UWRITE(IPRMPT,ILAST)
CALL USLCHA('*.',1,IPRMPT,ILAST)
CALL UWRITE(IPRMPT,ILAST)
C
C ------------------------------------------------------------------
C *** OPEN ANALYSIS INPUT FILE ***
C ------------------------------------------------------------------
C
C --- INITIALISE PROMPT FOR QUESTION
C
20 CALL USLCHA('ENTER ANALYSIS INPUT FILE NAME >*.',1,IPRMPT,ILAST)
C
C --- ASK QUESTION AND PERFORM SIMPLE DECODE OF REPLY BASED ON IEXIT
C
CALL UREAD(IPRMPT,ILAST,0,1,IREPLY,IEXIT)
IF( IEXIT.EQ.0 ) GOTO 20
IF( IEXIT.EQ.-1 ) GOTO 9100
C
C --- DECODE REPLY BY LOOKING FOR FILE NAME
C
IWANT = 1
CALL UDECOD(IREPLY,1,80,IWANT,IGOT,IFIRST,ILAST,IVAL,RVAL)
IF( IGOT.NE.IWANT ) GOTO 20
C
C --- CONVERT REPLY TO CHARACTER FORMAT
C
FNAME = ' '
CALL UA1CHA(IREPLY,ILAST,FNAME)
C
C --- OPEN ANALYSIS INPUT FILE
C
OPEN(UNIT=LU1,FILE=FNAME,FORM='FORMATTED',STATUS='NEW',ERR=20)
C
C ------------------------------------------------------------------
C *** GET MODEL SIZE PARAMETERS ***
C ------------------------------------------------------------------
C
CALL USIZE(NCONST)
NN = NCONST(6)
NE = NCONST(8)
NMA = NCONST(10)
NPH = NCONST(11)
NCO = NCONST(12)
NLOAD = NCONST(13)
NTC = NCONST(14)
NCOSYS = NCONST(16)
NNBAS = NCONST(17)
NEBAS = NCONST(18)
NEGRMX = NCONST(19)
NLOCAS = NCONST(20)
C
C ------------------------------------------------------------------
C *** MODEL NAME AND DESCRIPTION ***
C ------------------------------------------------------------------
C
CALL UNAMG2(0,0,ANAME,IERR)
CALL UTITLE(TNAME)
WRITE(LU1,'(A,A)') ' MODEL NAME :',ANAME
WRITE(LU1,'(A,A)') ' MODEL TITLE:',TNAME
C
C ------------------------------------------------------------------
C *** NODAL COORDINATES ***
C ------------------------------------------------------------------
C
WRITE(LU1,*) 'NODAL COORDINATES ...'
I2D3D = 0
DO 100 I=1+NNBAS,NN+NNBAS
C
C --- GET NODAL COORDINATES
C
CALL UNODE(I,COORD,IERR)
IF( IERR.NE.0 ) GOTO 100
C
C --- OUTPUT NODAL COORDINATES
C
WRITE(LU1,'(1X,I5,3(1X,E14.7))') I,COORD
C
C --- SET 2D/3D INDICATOR
C
IF( COORD(3).NE.0.0 ) I2D3D = 1
C
100 CONTINUE
C
C ------------------------------------------------------------------
C *** ELEMENT TOPOLOGY (IN ASCENDING ELEMENT ORDER) ***
C ------------------------------------------------------------------
C
WRITE(LU1,*) 'ELEMENT TOPOLOGY IN ASCENDING ELEMENT ORDER ...'
DO 200 I=1+NEBAS,NE+NEBAS
C
C --- GET INFORMATION FOR ELEMENT
C
CALL UGELEM(I,IPATY,IPANO,IFGELT,IELVAR,IMID,IPID,IELGR,IERR)
IF( IERR.NE.0 ) GOTO 200
C
C --- GET ELEMENT NODES
C
CALL UELEM(I,IELEM,NNODE,IERR)
C
C --- CHECK AND CORRECT ELEMENT JACOBIAN
C ( NOTE THAT FOR SHELL ELEMENT VARIANTS A JACOBIAN CHECK IS
C MEANINGLESS AND JAPRE SHOULD NOT BE CALLED )
C
CALL JAPRE(IFGELT,IELEM,NNODE,I2D3D,IELEM2,IFFLIP)
C
C --- OUTPUT ELEMENT INFORMATION
C
WRITE(LU1,'(16I5)') I,IFGELT,IELVAR,IMID,IPID,
+ (IELEM2(J),J=1,NNODE)
C
200 CONTINUE
C
C ------------------------------------------------------------------
C *** ELEMENT TOPOLOGY (BY ELEMENT PROPERTY GROUPS) ***
C ------------------------------------------------------------------
C
WRITE(LU1,*) 'ELEMENT TOPOLOGY (BY ELEMENT PROPERTY GROUPS) ...'
DO 400 IG=1,NEGRMX
IFIRST = 0
DO 300 I=1+NEBAS,NE+NEBAS
C
C --- GET INFORMATION FOR ELEMENT
C
CALL UGELEM(I,IPATY,IPANO,IFGELT,IELVAR,IMID,IPID,IELGR,
+ IERR)
IF( IERR.NE.0 ) GOTO 300
C
C --- ELEMENT IS NOT IN CURRENT ELEMENT PROPERTY GROUP ... SKIP IT
C
IF( IELGR.NE.IG ) GOTO 300
C
C --- GET ELEMENT NODES
C
CALL UELEM(I,IELEM,NNODE,IERR)
IF( IERR.NE.0 ) GOTO 300
C
C --- CHECK AND CORRECT ELEMENT JACOBIAN
C ( NOTE THAT FOR SHELL ELEMENT VARIANTS A JACOBIAN CHECK IS
C MEANINGLESS AND JAPRE SHOULD NOT BE CALLED )
C
CALL JAPRE(IFGELT,IELEM,NNODE,I2D3D,IELEM2,IFFLIP)
C
C --- OUTPUT ELEMENT INFORMATION
C
IF( IFIRST.EQ.0 ) THEN
WRITE(LU1,*) 'ELEMENT PROPERTY GROUP ',IG
WRITE(LU1,*) 'ELEMENT TYPE ',IFGELT,
+ ' ELEMENT VARIANT',IELVAR,
+ ' MATERIAL ID',IMID,
+ ' PHYSICAL ID',IPID
IFIRST = 1
ENDIF
WRITE(LU1,'(16I5)') I,(IELEM2(J),J=1,NNODE)
C
300 CONTINUE
400 CONTINUE
C
C ------------------------------------------------------------------
C *** LOCAL COORDINATE SYSTEMS ***
C ------------------------------------------------------------------
C
WRITE(LU1,*) 'LOCAL COORDINATE SYSTEMS ...'
C
DO 500 I=1,NCOSYS
C
CALL UCSYS2(I,ITYPE,AXES,IP1,IP2,IP3,NSEL,IWORK,IWDIM,IERR)
IF( IERR.NE.0 ) GOTO 500
C
C --- GET SYSTEM NAME
C
CALL UNAMG2(25,I,ANAME,IERR)
WRITE(LU1,'(A,A)') 'LOCAL COORDINATE SYSTEM ',ANAME
C
C --- RECTANGULAR SYSTEM - ALL NODES HAVE SAME AXES
C
IF( ITYPE.EQ.1 ) THEN
WRITE(LU1,'(6(1X,E14.7))') AXES
WRITE(LU1,'(16I5)') (IWORK(J),J=1,NSEL)
C
C --- CYLINDRICAL OR SPHERICAL SYSTEM - ALL NODES HAVE DIFFERENT AXES
C
ELSE
CALL UPNT2(IP1,ANAME,P1,IERR)
DO 490 J=1,NSEL
INODE = IWORK(J)
CALL UNODE(INODE,P2,IERR)
CALL UCOCYL(ITYPE,AXES,P1,P2,AXES2)
WRITE(LU1,'(I5,6(1X,E14.7))') INODE,AXES2
490 CONTINUE
ENDIF
C
500 CONTINUE
C
C ------------------------------------------------------------------
C *** SINGLE POINT CONSTRAINTS ***
C ------------------------------------------------------------------
C
WRITE(LU1,*) 'RIGID CONSTRAINTS ...'
DO 600 I=1+NNBAS,NN+NNBAS
C
C --- GET NODAL CONSTRAINTS
C
CALL UCONS3(I,ICONST,ISYST,IESUPP,IERR)
IF( IERR.NE.0 ) GOTO 600
C
C --- OUTPUT NODAL CONSTRAINTS
C
WRITE(LU1,'(I5,16I2)') I,ICONST
C
600 CONTINUE
C
C ------------------------------------------------------------------
C *** MULTI-POINT CONSTRAINTS ***
C ------------------------------------------------------------------
C
C --- LOOP OVER ALL CONSTRAINTS
C
DO 610 ICO=1,NCO
CALL UBDRY3(ICO,CNAME,ICOTYP,IPART1,IDOF1,IPART2,IDOF2,V,IERR)
C
C --- CONSTRAINT DOES NOT EXIST, SKIP IT
C
IF( IERR.NE.0 ) GOTO 610
C
C ------------------------------------
C
C --- GET INFORMATION FOR MPC RBEAM (1 MASTER, MANY SLAVES)
C
IF( ICOTYP.EQ.5 ) THEN
CALL URBEAM(ICO,IWORK,IWDIM,IDOF1,IERR)
IF( IERR.NE.0 ) GOTO 610
C
C ------------------------------------
C
C --- GET INFORMATION FOR MPC RBODY
C
ELSEIF( ICOTYP.EQ.6 ) THEN
CALL URBODY(ICO,IWORK,IWDIM,IM,IDOFM,COEF,NSLAVE,IDOFL,IERR)
IF( IERR.NE.0 ) GOTO 610
C
C ------------------------------------
C
C --- GET INFORMATION FOR MPC RCONNECT (CAN BE MANY THINGS)
C
ELSEIF( ICOTYP.EQ.7 ) THEN
CALL UCONCT(ICO,IWORK,IWDIM,IDOF1,IERR)
IF( IERR.NE.0 ) GOTO 610
C
C ------------------------------------
C
C --- GET INFORMATION FOR MPC EQUA
C
ELSEIF( ICOTYP.EQ.8 ) THEN
CALL UEQUA(ICO,IWORK,IWDIM,IS,IDOFS,COEF,NMASTR,IDOFL,
+ COEFFS,RHS,IERR)
IF( IERR.NE.0 ) GOTO 610
ELSE
C
C ------------------------------------
C
GOTO 610
ENDIF
C
C ------------------------------------------------------------------
C
C --- OUTPUT MPC DATA
C ===============
C
C --- RBEAM AND RCONNECT
C
IF( (ICOTYP.EQ.5).OR.(ICOTYP.EQ.7) ) THEN
C
WRITE(LU1,'(A,A,A,I5)') 'CONSTRAINT ',CNAME,' TYPE ',ICOTYP
WRITE(LU1,'(A)') ' SLAVE MASTER(S)'
C
IP1 = 1
IP2 = 2
620 IS = IWORK(IP1)
NM = IWORK(IP2)
IF( IS.NE.0 ) THEN
WRITE(LU1,'(I5,2X,3I5)') IS,(IWORK(IP2+I),I=1,NM)
IP1 = IP1 + 2 + NM
IP2 = IP2 + 2 + NM
GOTO 620
ENDIF
C
C ------------------------------------
C
C --- RBODY
C
ELSEIF( ICOTYP.EQ.6 ) THEN
C
WRITE(LU1,'(A,A,A,I5)') 'CONSTRAINT ',CNAME,' TYPE ',ICOTYP
WRITE(LU1,'(A,I5,1X,16I2,G14.7)')
+ 'MASTER:',IM,IDOFM,COEF
C
IP = 1
DO 630 I=1,NSLAVE
C
WRITE(LU1,'(A,16I2)') 'SLAVES: ',(IDOFL(K,I),K=1,16)
NS1 = IWORK(IP)
WRITE(LU1,'(16I5)') (IWORK(K),K=IP+1,IP+NS1)
IP = IP + 1 + NS1
630 CONTINUE
C
C --- EQUA
C
ELSEIF( ICOTYP.EQ.8 ) THEN
C
WRITE(LU1,'(A,A,A,I5)') 'CONSTRAINT ',CNAME,' TYPE ',ICOTYP
WRITE(LU1,'(A,G14.7)') 'RHS =',RHS
WRITE(LU1,'(A,I5,1X,16I2,G14.7)')
+ 'SLAVE:',IS,IDOFS,COEF
C
IP = 1
DO 640 I=1,NMASTR
WRITE(LU1,'(A,16I2,G14.7)') 'MASTERS: ',
+ (IDOFL(K,I),K=1,16),COEFFS(I)
NS1 = IWORK(IP)
WRITE(LU1,'(16I5)') (IWORK(K),K=IP+1,IP+NS1)
IP = IP + 1 + NS1
640 CONTINUE
ENDIF
C
610 CONTINUE
C
C ------------------------------------------------------------------
C *** MATERIAL PROPERTIES ***
C ------------------------------------------------------------------
C
WRITE(LU1,*) 'MATERIAL PROPERTIES ...'
DO 700 I=1,NMA
C
C --- GET MATERIAL DATA
C
CALL UMAT3(I,ANAME,CTYPE,IMTYPE,NVALS,WORK,IWDIM2,IERR)
IF( IERR.NE.0 ) GOTO 700
C
C --- OUTPUT INTERNAL MATERIAL DATA
C
IF( IMTYPE.EQ.1 ) THEN
WRITE(LU1,'(4A)') ' MATERIAL ',ANAME,' TYPE ',CTYPE
WRITE(LU1,'(5(1X,E14.7))') (WORK(J),J=1,NVALS)
C
C --- OUTPUT EXTERNAL MATERIAL NAMES
C
ELSE
CALL UMATE(WORK,IWDIM2,MAXNAM,NNAMES,LNAMES,CNAMES,IERR)
IF( NNAMES.GT.0 ) THEN
WRITE(LU1,'(3A)') ' MATERIAL ',ANAME,' TYPE: EXTERNAL'
DO 690 J=1,NNAMES
WRITE(LU1,'(A)') CNAMES(J)
690 CONTINUE
ENDIF
ENDIF
C
700 CONTINUE
C
C ------------------------------------------------------------------
C *** PHYSICAL PROPERTIES ***
C ------------------------------------------------------------------
C
WRITE(LU1,*) 'PHYSICAL PROPERTIES ...'
DO 800 I=1,NPH
C
C --- GET PHYSICAL DATA
C
CALL UPHYS3(I,ANAME,CTYPE,IPTYPE,IFORI,IFOFF,NVALS,WORK,
+ IWDIM2,IERR)
IF( IERR.NE.0 ) GOTO 800
C
C --- OUTPUT INTERNAL PHYSICAL DATA
C NOTE THAT THE PROPERTY TYPE (IE THE PRESENCE OF ORIENTATION AND
C OFFSET DEFINITIONS WILL AFFECT THE POSITION OF THE OTHER PROPERTY
C DATA.
C
IF( IPTYPE.EQ.1 ) THEN
WRITE(LU1,'(4A)') ' PHYSICAL ',ANAME,' TYPE ',CTYPE
IF( (IFORI.EQ.1).AND.(IFOFF.EQ.1) ) THEN
WRITE(LU1,'(A,3(1X,E14.7))') ' ORIENTATION ',(WORK(J),J=1,3)
WRITE(LU1,'(A,3(1X,E14.7))') ' OFFSET1 ',(WORK(J),J=4,6)
WRITE(LU1,'(A,3(1X,E14.7))') ' OFFSET2 ',(WORK(J),J=7,9)
WRITE(LU1,'(5(1X,E14.7))') (WORK(J),J=10,NVALS)
ELSEIF( (IFORI.EQ.1).AND.(IFOFF.EQ.0) ) THEN
WRITE(LU1,'(A,3(1X,E14.7))') ' ORIENTATION ',(WORK(J),J=1,3)
WRITE(LU1,'(5(1X,E14.7))') (WORK(J),J=4,NVALS)
ELSEIF( (IFORI.EQ.0).AND.(IFOFF.EQ.1) ) THEN
WRITE(LU1,'(A,3(1X,E14.7))') ' OFFSET1 ',(WORK(J),J=1,3)
WRITE(LU1,'(A,3(1X,E14.7))') ' OFFSET2 ',(WORK(J),J=4,6)
WRITE(LU1,'(5(1X,E14.7))') (WORK(J),J=7,NVALS)
ELSEIF( (IFORI.EQ.0).AND.(IFOFF.EQ.0) ) THEN
WRITE(LU1,'(5(1X,E14.7))') (WORK(J),J=1,NVALS)
ENDIF
C
C --- OUTPUT EXTERNAL PHYSICAL NAMES
C
ELSE
CALL UPHYSE(WORK,IWDIM2,MAXNAM,NNAMES,LNAMES,CNAMES,IERR)
IF( NNAMES.GT.0 ) THEN
WRITE(LU1,'(3A)') ' PHYSICAL ',ANAME,' TYPE: EXTERNAL'
DO 790 J=1,NNAMES
WRITE(LU1,'(A)') CNAMES(J)
790 CONTINUE
ENDIF
ENDIF
C
800 CONTINUE
C
C ------------------------------------------------------------------
C *** TIME CURVES ***
C ------------------------------------------------------------------
C
WRITE(LU1,*) 'TIME CURVES FOR LOAD AMPLITUDE DEFINITION ...'
C
C --- LOOP ON NUMBER OF TIME CURVES
C
DO 750 ITC=1,NTC
C
IEVAL = 1
CALL UCURVT(ITC,IEVAL,TCNAM,ITTYPE,SMOOTH,ICYCLE,IWORK,
+ IWDIM,WORK,IWDIM2,NVAL,IERR)
IF( IERR.NE.0 ) GOTO 750
C
C --- OUTPUT TIME CURVE FOR USE AS AMPLITUDE REFERENCE IN LOADS
C
WRITE(LU1,'(A,A)') ' TIME CURVE',TCNAM
NPAIR = NVAL/2
IP = 0
DO 749 IC=1,NPAIR
C
IP = IP + 1
T = WORK(IP)
IP = IP + 1
VAL = WORK(IP)
WRITE(LU1,*) T,VAL
C
749 CONTINUE
750 CONTINUE
C
C ------------------------------------------------------------------
C *** LOADS ***
C ------------------------------------------------------------------
C
WRITE(LU1,*) 'LOADS IN ASCENDING LOADCASE NUMBER ...'
C
DO 1000 ILOCAS=1,NLOCAS
IFIRST = 0
DO 900 ILOAD=1,NLOAD
C
CALL ULOAD3(ILOAD,ANAME,CTYPE,LCAS,IAPPL,ITC,ISC,ILM,ICS,
+ IPAT,IPAN,NVALS,WORK,IWDIM2,IERR)
IF( IERR.NE.0 ) GOTO 900
C
IF( IFIRST.EQ.0 ) THEN
WRITE(LU1,*) 'LOADS FOR LOADCASE ',ILOCAS
IFIRST = 1
ENDIF
C
C --- INTERPRET LOAD: THIS CAN BE DONE IN EITHER A GENERAL WAY BY
C EXAMINING THE PARAMETERS RETURNED BY ULOAD3, OR
C DIRECTLY IF AN ANALYSIS ENVIRONMENT WAS SPECIFIED USING A USERIQ
C ROUTINE. THE FOLLOWING EXAMPLES ASSUME THAT THE FEMGEN NEUTRAL
C ENVIRONMENT HAS BEEN LOADED (WHICH IT IS BY DEFAULT).
C
C ------------------------------------------------------------------
C
C --- FORCE LOADS: APPLIED TO NODES
C ===============================
C
IF( CTYPE.EQ.'FORCE ' ) THEN
CALL UNODEG(IPAT,IPAN,NSEL,IWORK,IWDIM,IERR)
IF( IERR.EQ.0 ) THEN
WRITE(LU1,'(A,A,A,A)') ' LOAD ',ANAME,' TYPE ',CTYPE
C
C --- TIME CURVE HAS BEEN ATTACHED
C
IF( ITC.NE.0 ) THEN
CALL UNAMG2(39,ITC,TCNAM,IERR)
WRITE(LU1,'(2A)') ' AMPLITUDE VARIATION ',TCNAM
ENDIF
C
C --- LOOP OVER LOADS TO EVALUATE
C
VLOAD = WORK(1)
IDOF = IFIX(WORK(2))
C
IFIRST = 0
DO 860 IC=1,NSEL
IN = IWORK(IC)
CALL UNODE(IN,COORD,IERR)
CALL ULEVAL(IFIRST,ILM,ISC,ICS,COORD,IPAT,IPAN,
+ ISTAT,VALUE,AXESO,
+ IWORK(IWDIM-10000),10000,IERR)
IF( IERR.NE.0 ) GOTO 860
C
C --- IN OR OUT OF LOAD MASK ?
C
IF( ISTAT.NE.1 ) GOTO 860
C
C --- MODIFY LOAD VALUE FOR SPACE CURVE
C
U(1) = 0.0
U(2) = 0.0
U(3) = 0.0
U(IDOF) = VLOAD * VALUE
C
C --- MODIFY LOAD FOR LOCAL AXIS SYSTEM
C
V(1)=AXESO(1,1)*U(1)+AXESO(1,2)*U(2)+AXESO(1,3)*U(3)
V(2)=AXESO(2,1)*U(1)+AXESO(2,2)*U(2)+AXESO(2,3)*U(3)
V(3)=AXESO(3,1)*U(1)+AXESO(3,2)*U(2)+AXESO(3,3)*U(3)
C
C --- AND OUTPUT
C
WRITE(LU1,'(I8,3G13.6)') IN,(V(K),K=1,3)
860 CONTINUE
ENDIF
ENDIF
C
C ------------------------------------------------------------------
C
C --- GRAVITY LOADS: APPLIED TO WHOLE ELEMENTS
C ========================================
C
IF( CTYPE.EQ.'GRAVITY ' ) THEN
WRITE(LU1,'(A,A,A,A)') ' LOAD ',ANAME,' TYPE ',CTYPE
WRITE(LU1,'(A,E14.7)') ' GRAVITY =',WORK(1)
WRITE(LU1,'(A,I5)') ' DIRECTION =',IFIX(WORK(2))
C
C --- LOOP OVER PART INDEX POINTERS
C
DO 890 IPOINT=IPAT,IPAN
CALL ULOADE(IPOINT,IPATY,IPANO,IFATYP,IERR)
IF( IERR.NE.0 ) GOTO 890
C
C --- IF FACE TYPE IS RELEVANT FOR A GRAVITY LOAD (IE WHOLE ELEMENTS
C MUST BE LOADED AND NOT FACES) THEN PROCEED
C
IF( (IFATYP.LE.1).OR.(IFATYP.EQ.3) ) THEN
C
C --- GET ELEMENTS ON PART TYPE IPATY, PART NUMBER IPANO
C
CALL UELEMG(IPATY,IPANO,NE0,NE1,IELT,IVAR,IMID,
+ IPID,IELGR,IERR)
C
C --- NO ELEMENTS ON PART ... SKIP TO NEXT ONE
C
IF( IERR.NE.0 ) GOTO 890
C
C --- LOOP OVER ELEMENTS ON PART TO CHECK THAT THEY EXIST
C (SOME MAY HAVE BEEN DELETED) AND OUTPUT IN BLOCKS OF 16.
C
NBUF = 0
DO 880 IE=NE0,NE1
CALL UELEM(IE,IELEM,NNODE,IERR)
IF( IERR.NE.0 ) GOTO 880
NBUF = NBUF + 1
IBUF(NBUF) = IE
IF( NBUF.EQ.16 ) THEN
WRITE(LU1,'(16I5)') IBUF
NBUF = 0
ENDIF
880 CONTINUE
IF( NBUF.NE.0 )
+ WRITE(LU1,'(16I5)') (IBUF(K),K=1,NBUF)
ENDIF
890 CONTINUE
ENDIF
C
C ------------------------------------------------------------------
C
C --- PRESSURE LOADS: APPLIED TO ELEMENT FACE/EDGES
C =============================================
C
IF( CTYPE.EQ.'PRESSURE' ) THEN
WRITE(LU1,'(A,A,A,A)') ' LOAD ',ANAME,' TYPE ',CTYPE
WRITE(LU1,'(A,E14.7)') ' PRESSURE =',WORK(1)
WRITE(LU1,'(A,I5)') ' DIRECTION =',IFIX(WORK(2))
C
C --- LOOP OVER PART INDEX POINTERS
C
DO 870 IPOINT=IPAT,IPAN
CALL ULOADE(IPOINT,IPATY,IPANO,IFATYP,IERR)
IF( IERR.NE.0 ) GOTO 870
C
C --- NO ELEMENTS ON PART ... SKIP TO NEXT ONE
C
IF( IERR.NE.0 ) GOTO 870
C
C --- GET ELEMENTS ON LOADED FACE/EDGE AND THE EDGE/FACE IDENTIFIER
C
CALL UFACEG(IPATY,IPANO,IPATY2,IPANO2,NNEF,IPNE,
+ IFACE,JAC,NELO,IWORK,IWDIM,IERR)
C
C --- UNABLE TO DETERMINE LOADED FACE/ELEMENTS ON PART ... SKIP
C
IF( IERR.NE.0 ) GOTO 870
C
C --- GET ELEMENT TYPE
C
CALL UELEMG(IPATY,IPANO,NE0,NE1,IFGELT,IELVAR,
+ IMID,IPID,IG,IERR)
IF( IERR.NE.0 ) GOTO 870
C
C --- LOOP OVER ELEMENTS ON PART
C
DO 865 IP=1,NELO
IE = IWORK(IP)
C
C --- GET FACE NUMBER FOR CURRENT ELEMENT
C
IWOFF = NELO
IWDIM3 = IWDIM - NELO
CALL UEFACE(IE,IFGELT,IPATY,IPANO,IFATYP,NNEF,
+ IWORK,IWDIM3,IWOFF,IEFACE,IERR)
IF( IERR.NE.0 ) GOTO 865
IFACE = IEFACE
C
C --- CHECK JACOBIAN ON ELEMENT: IF PARAMETER IFFLIP INDICATES
C THAT THE ELEMENT HAD A NEGATIVE JACOBIAN THEN THE LOADED
C FACE ID MUST BE CHANGED TO REFLECT THE FACT THAT THE ELEMENT
C DEFINITION WAS FLIPPED AT THE ELEMENT TOPOLOGY STAGE.
C
C WHERE THE ANALYSIS PACKAGE DEFINES ELEMENT FACES BY THE
C FACE NODES AND NOT A FACE IDENTIFIER THIS WILL NOT BE NECESSARY.
C
CALL UELEM(IE,IELEM,NNODE,IERR)
CALL JAPRE(IFGELT,IELEM,NNODE,I2D3D,IELEM2,
+ IFFLIP)
C
IF( IFFLIP.EQ.1 ) THEN
NBAS = IMAP(IFGELT)
IF( IFGELT.GE.11 ) THEN
IF( IFGELT.EQ.12.OR.IFGELT.EQ.16 ) THEN
IF( IFACE.EQ.2 ) NBAS=2
IF( IFACE.EQ.4 ) NBAS=-2
IFACE=IFACE+NBAS
ELSEIF( IFACE.LT.3 ) THEN
IFACE=-IFACE+NBAS+1
ENDIF
ELSE
IFACE=-IFACE+NBAS+1
ENDIF
ENDIF
C
WRITE(LU1,'(A,I5,A,I2,A,9I5)')
+ ' ELEMENT ',IE,' FACE ',IFACE,' NODES ',
+ (IELEM(IPNE(J)),J=1,NNEF)
C
865 CONTINUE
870 CONTINUE
ENDIF
C
C ------------------------------------------------------------------
C
900 CONTINUE
1000 CONTINUE
C
C ------------------------------------------------------------------
C *** PRESCRIBED VALUES ***
C ------------------------------------------------------------------
C
WRITE(LU1,*) 'PRESCRIBED VALUES ...'
C
DO 1100 ICO=1,NCO
C
CALL UPRESC(ICO,ANAME,IPATY,IPANO,IDOF,VALUE,LCAS,IERR)
IF( IERR.NE.0 ) GOTO 1100
C
CALL UNAMG2(IPATY,IPANO,ANAME,IERR)
C
WRITE(LU1,*) ANAME,IDOF,VALUE
C
1100 CONTINUE
C
C ------------------------------------------------------------------
C *** CLOSE DATABASE ***
C ------------------------------------------------------------------
C
9100 CALL UCLOS
CALL USLCHA(' *.',1,IPRMPT,ILAST)
CALL UWRITE(IPRMPT,ILAST)
CALL USLCHA('FEMGEN DATABASE CLOSED*.',1,IPRMPT,ILAST)
CALL UWRITE(IPRMPT,ILAST)
C
C ******************************************************************
C * *
C * END OF CODE *
C * *
C ******************************************************************
C
9999 CONTINUE
END
SUBROUTINE XINIT
RETURN
END