a36.for

ADINA84有限元编程学习的好例子

      SUBROUTINE TODCON
C
C
C
C
C
      IMPLICIT DOUBLE PRECISION ( A-H,O-Z )
C***END:DPR***
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /DIMETC/ N01,N02,N03,N04,N05,N06,N07,N08,N09
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C,N1S
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP,IDCFGL,ISMASS
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDOF,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NGALL,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /EQIT/ METHOD,ILNSCH,NLSTPD,NLSTEP,ITEDIV,IPEQIT
      COMMON /SEQNCE/ ITA(18),IT19,ITB(10)
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /DPR/ ITWO
      COMMON /ELGLTH/ NFIRST,NLAST,NBCEL
      COMMON /ELSTP/ TIME,IDTHF
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /SKEW/ NSKEWS
      COMMON /DISCON/ NDISCE,NIDM
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,IBPORT,IFPORT,JDC,JVC,JAC
      COMMON /CNTACT/ NEQI,LEADEQ,NCE2D,NCE3D
      COMMON /ITRATE/ RCENRM,RCNORM,RCONSM,RCTOL
      COMMON /GROUPS/ NTGNL,NSGNL
      COMMON /ISSAC/ NEWREF
      COMMON /TAPES/ IIN,IOUT
      COMMON /ISUBST/ ISUBC,NSUBST,NSUB,NTUSE,NEGLS,NEGNLS,NUMNPS,
     1                NODCON,NODRET,IDOFS(12),NDOFS,NEQS,NWKS,MAXESC,
     2                MAS,NSTAPE,ILOA(13),KRSIZM,NEQC
      COMMON A(1)
      REAL A
      DIMENSION IA(1)
      DIMENSION RMDUMY(1,1),IMDUMY(1,1)
      EQUIVALENCE (A(1),IA(1))
C
      EQUIVALENCE (NPAR(1),NPAR1),
     1            (NPAR(2),NSURF),(NPAR(4),NSURFP),
     1            (NPAR(5),IAXIS),(NPAR(6),NEGSKS),
     1            (NPAR(9),NTOUCH),(NPAR(10),NSNOD),
     1            (NPAR(13),ICPRNT),(NPAR(15),MODEL)
C
      IF (IND.GE.1 .AND. IND.LE.3) RETURN
      IF (IND.NE.0) GO TO 700
      NG = NGALL-NEGL-NEGNL
C
C
C
      ISTOP=0
      IF (NEWREF.EQ.1) GO TO 20
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2600) ISTOP
C
   20 IF (ILNSCH.EQ.0) GO TO 50
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2650) ISTOP
C
C
   50 IF (NSURF.GE.2) GO TO 100
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2700) ISTOP,NSURF
C
  100 IF (NSURFP.GE.1) GO TO 150
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2800) ISTOP,NSURFP
C
  150 IF (NTOUCH.GE.2) GO TO 200
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2900) ISTOP,NTOUCH
C
  200 IF (NSNOD.GE.4) GO TO 240
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3000) ISTOP,NSNOD
C
  240 IF (NSNOD.GE.NTOUCH) GO TO 250
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3050) ISTOP,NSNOD,NTOUCH
C
  250 IF (IAXIS.GE.0 .AND. IAXIS.LE.2) GO TO 300
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3100) ISTOP,IAXIS
C
  300 IF (NEGSKS.EQ.0) GO TO 350
      IF (NSKEWS.GT.0) GO TO 350
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3200) ISTOP,NSKEWS,NEGSKS
C
  350 ICTEMP=ICPRNT
      IF (ICTEMP.EQ.1) ICPRNT=2
      IF (ICTEMP.EQ.2) ICPRNT=1
      IF (ICTEMP.GE.0 .AND. ICTEMP.LE.2) GO TO 400
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3300) ISTOP,ICTEMP
C
  400 MTEMP = MODEL
      MODEL = MODEL + 1
      IF (MTEMP.EQ.0 .OR. MTEMP.EQ.1) GO TO 450
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3400) ISTOP,MTEMP
C
  450 IF (ISTOP.EQ.0) GO TO 500
      write(66,4000) ISTOP
      STOP
C
  500 IF (IDATWR.GT.1) GO TO 600
C
C
      write(66,2000) NPAR1
      write(66,2050) NSURF,NSURFP
      write(66,2100) IAXIS,NEGSKS
      write(66,2150) NTOUCH,NSNOD
      write(66,2200) ICTEMP,MTEMP
C
C
  600 IF (JNPORT.EQ.0 .OR. NPUTSV.EQ.0) GO TO 700
      IF (JNPORT.EQ.1)
     1   WRITE (IBPORT     ) 'TYPE-16 ',NSUB,NGALL,(NPAR(I),I=1,20)
      IF (JNPORT.EQ.2)
     1   WRITE (IFPORT,9000) 'TYPE-16 ',NSUB,NGALL,(NPAR(I),I=1,20)
C
 9000 FORMAT ( A,/,(8I10) )
C
C
C
C
C
  700 NFIRST=N6
      IF (IND.EQ.4) NFIRST=N10
C
      NSEG=NSNOD+NSURF
      NXALL=2*NSNOD
      NXCON=2*NTOUCH
      NCEQN = MODEL
      NCADD = NCEQN*NTOUCH
C
      N110 = NFIRST + 20
      N120 = N110 + NSURFP*2
      N130 = N120 + NSURF + 1
      N140 = N130 + NSNOD
      N150 = N140 + NXALL
      N160 = N150 + NTOUCH
      N170 = N160 + NSEG
      N180 = N170 + NTOUCH
      N190 = N180 + 20
      N200 = N190 + 2
      N210 = N200 + NSNOD
      N215 = N210 + NSURF
      N220 = N215 + NSURF
      N230 = N220 + NCADD
      N240 = N230 + NSEG
      N250 = N240 + NTOUCH
      NILAST = N250 - 1
C
      N500 = N250
      N510 = N500 + 3*NSURFP*ITWO
      N520 = N510 + NXALL*ITWO
      N530 = N520 + NXCON*ITWO
      N540 = N530 + NXALL*ITWO
      N550 = N540 + NSEG*ITWO
      N560 = N550 + 2*NSEG*ITWO
      N570 = N560 + NXCON*ITWO
      N580 = N570 + NTOUCH*ITWO
      N590 = N580 + NXALL*ITWO
      N600 = N590 + NTOUCH*ITWO
      N900 = N600
      NLAST = N900 -1
      NEND  = NLAST
      IF (IND.EQ.0) NEND = NLAST + LEADEQ+NCADD-NEQI
C
C
C
      IF (IND.NE.0) GO TO 750
C
      LONG = NILAST - NFIRST + 1
      CALL EXAMIN (RMDUMY,1,1,IA(NFIRST),1,LONG,1,-100)
      LONG = ( NLAST - N500 + 1 )/ITWO
      CALL EXAMIN (A(N500),1,LONG,IMDUMY,1,1,1,100)
C
      J=NFIRST-1
      DO 800 I=1,20
      J=J+1
  800 IA(J)=NPAR(I)
C
      MIDEST=(NLAST-NFIRST)+1
      IF (IDATWR.LE.1) write(66,2300) MIDEST
      CALL SIZE (NEND)
C
  750 IF (IND.GT.3) GO TO 850
      M2=N2
      M3=N3
      M4=N4
      M5=N5
      GO TO 900
C
  850 M2=N2
      M3=N7
      M4=N8
      M5=N3
C
      IF (IEQUIT.EQ.1) GO TO 900
      M2=N6
      M5=N5
C
  900 CALL TOUCH2(A(N01),A(N02),A(N04),
     1            A(N1),A(M2),A(M3),A(M4),A(M5),
     1            A(N06),A(N1A),
     1            A(N110),A(N120),A(N130),A(N140),
     1            A(N150),A(N160),A(N170),A(N180),
     1            A(N190),A(N200),A(N210),A(N215),A(N220),
     1            A(N230),A(N240),
     1            A(N500),A(N510),A(N520),
     1            A(N530),A(N540),A(N550),
     1            A(N560),A(N570),A(N580),A(N590),
     1            NIDM,NDOF,NSURF,NSURFP,NTOUCH,NSNOD,NSEG)
C
C
C
      IF (IND.NE.0) RETURN
      NCEQ = LEADEQ - NEQI
      NOLD = NCEQ   - NCADD
      N220A = N220  - 1
      N900A = N900  - 1
      N900B = N900A + NOLD
      DO 910 L=1,NCADD
  910 IA(N900B+L) = IA(N220A+L)
      IF (NOLD.EQ.0) GO TO 920
      REWIND IT19
      READ  (IT19) ( IA(N900A+L),L=1,NOLD )
  920 REWIND IT19
      WRITE (IT19) ( IA(N900A+L),L=1,NCEQ )
      RETURN
C
C
C
 2000 FORMAT(36H S U R F A C E   D E F I N I T I O N  ///,
     1       14H SURFACE TYPE ,13(2H .),16H( NPAR(1) ). . =,I5,/,
     2       32H     EQ.16, 2-D CONTACT SURFACES,/,
     3       32H     EQ.17, 3-D CONTACT SURFACES,/)
 2050 FORMAT(27H NUMBER OF CONTACT SURFACES,3H  .,5(2H .),11H( NPAR(2) )
     1       ,5H. . =,I5,
     1     //24H NUMBER OF SURFACE PAIRS,8(2H .),16H( NPAR(4) ). . =,I5
     1     ,/)
 2100 FORMAT(/24H CONTACT SURFACE SUBTYPE,8(2H .),16H( NPAR(5) ). . =,I5
     1       /23H     EQ.0  AXISYMMETRIC ,
     1       /23H     EQ.1  PLANE STRAIN ,
     1       /23H     EQ.2  PLANE STRESS ,
     1      //23H SKEW COORDINATE SYSTEM,
     1      /,5X,19HREFERENCE INDICATOR,8(2H .),16H( NPAR(6) ). . =,I5,
     1     /,5X,23HEQ.0  ALL SURFACE NODES ,
     1      /,11X,37HUSE THE GLOBAL COORDINATE SYSTEM ONLY,
     1     /,5X,25HEQ.1  SURFACE NODES REFER ,
     1      /,11X,25HTO SKEW COORDINATE SYSTEM ,/)
 2150 FORMAT(/26H NUMBER OF CONTACTOR NODES,7(2H .),
     1        16H( NPAR(9) ). . =,I5,
     1       //24H NUMBER OF SURFACE NODES,8(2H .),16H( NPAR(10) ) . =
     1        ,I5)
 2200 FORMAT(/39H PRINT CONTROL FOR CONTACT SURFACES. . ,
     1        17H( NPAR(13) ). . =,I5/
     1     5X,43HEQ.0  PRINT CONSISTENT CONTACT NODAL FORCES,/,
     1    5X,47HEQ.1  PRINT AVERAGE CONTACTOR SEGMENT TRACTIONS ,/,
     1    5X,43HEQ.2  PRINT CONSISTENT CONTACT NODAL FORCES,/,
     1   11X,39HAND AVERAGE CONTACTOR SEGMENT TRACTIONS,
     1     //16H FRICTION MODEL ,12(2H .),16H( NPAR(15) ) . =,I5,/,
     1    5X,26HEQ.0, FRICTIONLESS CONTACT,/,
     1    5X,22HEQ.1, COULOMB FRICTION ,/)
 2300 FORMAT(//43H LENGTH OF ARRAY NEEDED FOR STORING SURFACE/
     1         43H DATA. . . . . . . . . . . . .(MIDEST). . =,I5/)
C
C
C
C
 2500 FORMAT(1H1,38HERROR IN CONTACT SURFACE CONTROL CARDS/
     1       16H SURFACE GROUP =,I5,/)
 2600 FORMAT(I5,31H. FULL NEWTON ITERATION MUST BE  ,/,
     1       7X,34HEMPLOYED WHEN CONTACT SURFACES ARE  ,/,
     1       7X,40HPRESENT.  (SEE MASTER CONTROL CARD NO.7)  )
 2650 FORMAT(I5,35H. LINE SEARCH SOLUTION MUST NOT BE ,/,
     1       7X,34HEMPLOYED WHEN CONTACT SURFACES ARE  ,/,
     1       7X,40HPRESENT.  (SEE MASTER CONTROL CARD NO.7)  )
 2700 FORMAT(I5,41H. AT LEAST TWO SURFACES MUST BE SPECIFIED,/,
     1       7X,14HINPUT NPAR(2)=,I5)
 2800 FORMAT(I5,45H. AT LEAST ONE SURFACE PAIR MUST BE SPECIFIED,/,
     1       7X,14HINPUT NPAR(4)=,I5)
 2900 FORMAT(I5,48H. AT LEAST TWO CONTACTOR NODES MUST BE SPECIFIED,/,
     1       7X,14HINPUT NPAR(9)=,I5)
 3000 FORMAT(I5,37H. AT LEAST FOUR CONTACT SURFACE NODES,
     1          17HMUST BE SPECIFIED,/,
     1       7X,15HINPUT NPAR(10)=,I5)
 3050 FORMAT(I5,30H. NPAR(10) MUST BE GE. NPAR(9) ,/,
     1       7X,15HINPUT NPAR(15)=,I5,5X,14HINPUT NPAR(9)=,I5 )
 3100 FORMAT(I5,31H. NPAR(5) MUST BE GE.0 AND LE.2,/,
     1       7X,14HINPUT NPAR(5)=,I5)
 3200 FORMAT(I5,10H. NSKEWS =,I5,14H AND NPAR(6) =,I5,
     1       19H ARE NOT COMPATIBLE )
 3300 FORMAT(I5,32H. NPAR(13) MUST BE GE.0 AND LE.2,/,
     1       7X,15HINPUT NPAR(13)=,I5)
 3400 FORMAT(I5,31H. NPAR(15) MUST BE EQ.0 OR EQ.1 ,/,
     1       7X,15HINPUT NPAR(15)=,I5)
 4000 FORMAT(//,25H TOTAL NUMBER OF ERRORS =,I5,////,
     1          34H S T O P  (ERRORS IN SURFACE DATA)  )
      END
      SUBROUTINE TOUCH2(NID,IDI,NOD,
     1                  ID,X,Y,Z,HT,
     1                  RSDCOS,NODSYS,
     1                  ISURFP,IFSN,NODSF,LMS,
     1                  INODE,ISEG,ITS,IDBUG,
     1                  INUMEQ,ISKEW,IPS,ISV,LMHT,
     1                  JSLIDE,KSLIDE,
     1                  FCOFF,XYZ,CPROLD,
     1                  XYZS,XLN,T,
     1                  CPR,BETA,DELTA,CLOSED,
     1                  NIDM,NDOF,NSURF,NSURFP,NTOUCH,NSNOD,NSEG)
C
C
C***ADD:DPR***
      IMPLICIT DOUBLE PRECISION ( A-H,O-Z )
C***END:DPR***
      COMMON /SOL/ NUMNP,NEQ,NWK,NWM,NWC,NUMEST,MIDEST,MAXEST,NSTE,MA
      COMMON /CONST/ DT,DTA,A0,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11
     1              ,A12,A13,A14,A15,A16,A17,A18,A19,A20,DTOD,IOPE
      COMMON /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDFD,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /DIM/ N0,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15
      COMMON /LOA/ NLOAD,NPR2,NPR3,NPBM,NP3DB,NPPL,NPSH,NODE3,IDGRAV,
     1             NPDIS,NTEMP,IDCFGL,ISMASS
      COMMON /ELSTP/ TIME,IDTHF
      COMMON /VAR/ NGALL,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /PRCON/ IDATWR,IPRIC,NPB,IDC,IVC,IAC,IPC,IPNODE(3,15)
      COMMON /PORT/ INPORT,JNPORT,NPUTSV,IBPORT,IFPORT,JDC,JVC,JAC
      COMMON /FREQIF/ ISTOH,N1A,N1B,N1C,N1S
      COMMON /RANDI/ N0A,N1D,IELCPL
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /MDFRDM/ IDOF(12)
      COMMON /SKEW/ NSKEWS
      COMMON /CNTACT/ NEQI,LEADEQ,NCE2D,NCE3D
      COMMON /ITRATE/ RCENRM,RCNORM,RCONSM,RCTOL
      COMMON /GROUPS/ NTGNL,NSGNL
      COMMON /SRFACE/ IS,KFS,KLS,KES,JFS,JLS,JFSD,JLSD
      COMMON /PAIR/ IT,KFT,KLT,KET,JFT,JLT,JFTD,JLTD
      COMMON /MATCH/ ISR,IPAIR,JFSEG,JLSEG,JTSEG
      COMMON /OPRATE/ ISET
      COMMON /TAPES/ IIN,IOUT
      COMMON /DISCON/ NDISCE,MIDM
      COMMON A(1)
      REAL A
      DIMENSION IA(1)
C
      DIMENSION NID(*),IDI(NIDM,*),NOD(*),
     1          ID(NDOF,*),X(*),Y(*),Z(*),HT(*),
     1          RSDCOS(9,*),NODSYS(*)
      DIMENSION ISURFP(2,NSURFP),IFSN(*),NODSF(*),LMS(2,NSNOD),
     1          INODE(*),ISEG(*),ITS(*),IDBUG(20),
     1          INUMEQ(2),ISKEW(*),IPS(*),ISV(*),LMHT(*),
     1          JSLIDE(*),KSLIDE(*)
      DIMENSION FCOFF(3,NSURFP),XYZ(2,NSNOD),CPROLD(2,NTOUCH),
     1          XYZS(2,NSNOD),XLN(*),T(2,NSEG),
     1          CPR(2,NTOUCH),BETA(*),DELTA(2,NSNOD),CLOSED(*)
      DIMENSION ILMS(6)
      DIMENSION RMDUMY(1,1),IMDUMY(1,1)
C
      EQUIVALENCE (NPAR(5),IAXIS),(NPAR(6),NEGSKS),
     1            (NPAR(13),ICPRNT),(NPAR(15),MODEL),
     1            (NPAR(16),IDBPR)
      EQUIVALENCE (A(1),IA(1))
C
      NG = NGALL-NEGL-NEGNL
      IF (IND.GT.0) GO TO 600
C
C
C
C
C .                                                                   .
      DO 10 J=1,NSEG
   10 ISEG(J)=1
      DO 30 K=1,NTOUCH
   30 INODE(K)=1
C
      IF (IDATWR.LE.1) write(66,2000)
      IF (IDATWR.LE.1) write(66,2050)
C
      NSUM=0
      ISTOP=0
      IFSN(1)=1
      DO 100 I=1,NSURF
      READ(IIN,1000) ISURF,NNODE,IPRINT,IPLOT
C
      IF (ISURF.EQ.I) GO TO 110
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2550) ISTOP,I,ISURF
C
  110 IF (NNODE.GE.2) GO TO 120
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2600) ISTOP,ISURF,NNODE
C
  120 IPS(I)=IPRINT
      IF (IPRINT.EQ.0 .OR. IPRINT.EQ.1) GO TO 135
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2700) ISTOP,ISURF,IPRINT
C
  135 ISV(I)=IPLOT
      IF (IPLOT.EQ.0 .OR. IPLOT.EQ.1) GO TO 140
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2710) ISTOP,ISURF,IPLOT
C
  140 IF (ISTOP.EQ.0 .AND. IDATWR.LE.1)
     1write(66,2100) ISURF,NNODE,IPRINT,IPLOT
C
      KFS=IFSN(I)
      IFSN(I+1)=KFS+NNODE
      KLS=IFSN(I+1)-1
      READ(IIN,1050) (NODSF(K),K=KFS,KLS)
C
      IOPEN=0
      IF (NODSF(KLS).EQ.NODSF(KFS)) IOPEN=1
C
      ISEG(KFS+I-1)=IOPEN
      ISEG(KLS+I)=IOPEN
C
      KES=KLS
      IF (IOPEN.EQ.1) KES=KLS-1
C
  150 DO 170 KA=KFS,KES
      LOCALA = KA-KFS+1
      LNODE  = NODSF(KA)
      IF (LNODE.GT.0 .AND. LNODE.LE.NUMNP) GO TO 160
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2800) ISTOP,ISURF,LOCALA,LNODE,NUMNP
C
  160 IF (KA.EQ.KES) GO TO 170
      JK=KA+1
      DO 180 KB=JK,KES
      LOCALB=KB-KFS+1
      IF (LNODE.NE.NODSF(KB)) GO TO 180
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2850) ISTOP,ISURF,LOCALA,LOCALB,LNODE
  180 CONTINUE
  170 CONTINUE
C
      NSUM=NSUM+NNODE
C
C