a36.for

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

      IF (JNPORT.EQ.0 .OR. NPUTSV.EQ.0) GO TO 100
      IF (JNPORT.EQ.1)
     1   WRITE (IBPORT     ) '2D-CONTC',ISURF,IOPEN,IPRINT,IPLOT,
     2                       NNODE,KFS,KLS,(NODSF(K),K=KFS,KLS)
      IF (JNPORT.EQ.2)
     1   WRITE (IFPORT,9000) '2D-CONTC',ISURF,IOPEN,IPRINT,IPLOT,
     2                       NNODE,KFS,KLS,(NODSF(K),K=KFS,KLS)
C
 9000 FORMAT ( A,/,7I10,/,(8I10) )
C
  100 CONTINUE
      IF (NSUM.EQ.NSNOD) GO TO 190
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2900) ISTOP,NSNOD,NSUM
C
  190 IF (IDATWR.GT.1) GO TO 200
      write(66,2150)
      DO 210 I=1,NSURF
      KFS=IFSN(I)
      KLS=IFSN(I+1)-1
      NNODE=KLS-KFS+1
      write(66,2200) I,NNODE
      KS=1
      KE=6
  220 IF (KE.GT.NNODE) KE=NNODE
      write(66,2250) KS,KE,(NODSF(KFS+L-1),L=KS,KE)
      KS=KS+6
      KE=KE+6
      IF (KS.LE.NNODE) GO TO 220
  210 CONTINUE
C
C
  200 IF (IDATWR.LE.1) write(66,2300)
C
      DO 230 L=1,NSURFP
      READ(IIN,1100) ISPAIR,IT,IC,SCF,DCF,PRCENT
C
      DCF = SCF
C
C
      IF (ISPAIR.EQ.L) GO TO 240
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2950) ISTOP,L,ISPAIR
C
  240 IF (IT.NE.IC .AND. IT.LE.NSURF .AND. IC.LE.NSURF) GO TO 250
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3000) ISTOP,NSURF,IT,IC
C
  250 IF (MODEL.NE.1) GO TO 260
      SCF=0.0D0
      DCF=0.0D0
      GO TO 270
C
  260 IF (SCF.GE.DCF .AND. DCF.GE.0.0D0) GO TO 270
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3050) ISTOP,SCF,DCF
C
  270 IF (PRCENT.EQ.0.0D0) PRCENT=0.01D0
      IF (PRCENT.GE.0.0D0 .AND. PRCENT.LE.1.0D0) GO TO 280
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3100) ISTOP,PRCENT
C
C
  280 IF (ISTOP.GT.0) GO TO 230
      IF (IDATWR.LE.1) write(66,2350) L,IT,IC,SCF
      ISURFP(1,L)=IT
      ISURFP(2,L)=IC
      FCOFF(1,L)=SCF
      FCOFF(2,L)=DCF
      FCOFF(3,L)=PRCENT
C
C
      IF (JNPORT.EQ.0 .OR. NPUTSV.EQ.0) GO TO 230
      IF (JNPORT.EQ.1)
     1   WRITE (IBPORT     ) '2D-SURFP',ISPAIR,IT,IC,SCF,DCF,PRCENT
      IF (JNPORT.EQ.2)
     1   WRITE (IFPORT,9010) '2D-SURFP',ISPAIR,IT,IC,SCF,DCF,PRCENT
C
 9010 FORMAT ( A,/,3I10,/,3E20.13 )
C
C
  230 CONTINUE
C
C
C
      IF (IDBPR.EQ.-1) READ(IIN,1200) (IDBUG(L),L=1,20)
      IDBA = IDBUG(3)
      IDBB = IDBUG(4)
C
      IF (IDBA.EQ.0) GO TO 300
      CALL EXAMIN (RMDUMY,1,1,ISURFP,2,NSURFP,2,-1)
      CALL EXAMIN (FCOFF,3,NSURFP,IMDUMY,1,1,2,1)
      CALL EXAMIN (RMDUMY,1,1,IFSN,1,NSURF,2,-2)
      CALL EXAMIN (RMDUMY,1,1,NODSF,1,NSNOD,2,-3)
  300 CONTINUE
C
C
C
      LOOP = NEQI + NDISCE
      DO 310 K=1,NSNOD
      NODE=NODSF(K)
      XYZ(1,K)=Y(NODE)
      XYZ(2,K)=Z(NODE)
      ISKEW(K)=0
      IF (NSKEWS.GT.0) ISKEW(K) = NODSYS(NODE)
      LL=0
      IF (IDOF(1).EQ.0) LL=1
      DO 320 L=1,2
      IF (IDOF(L+1).EQ.0) GO TO 330
      LMS(L,K)=0
      GO TO 320
  330 LL=LL+1
      IDEQN = ID(LL,NODE)
      IF (IDEQN.GT.LOOP) IDEQN = 0
      LMS(L,K) = IDEQN
  320 CONTINUE
  310 CONTINUE
C
      IF (NEGSKS.GT.0) GO TO 315
      DO 325 K=1,NSNOD
      IF (ISKEW(K).EQ.0) GO TO 325
      write(66,3350) NSKEWS,NEGSKS
      STOP
  325 CONTINUE
  315 CONTINUE
C
C
C
      NSUM=0
      ITRGT=0
      DO 340 I=1,NSURF
      IS=I
      CALL TRGET2(ISURFP,IFSN,ISEG,NSURF,NSURFP,1)
      IF (ISR.EQ.0) GO TO 350
C
      IF (ITRGT.EQ.0) GO TO 360
      ISTOP=ISTOP+1
      write(66,3150) ISTOP,ITRGT,IS
      GO TO 500
C
  360 KFIRST=KFS
      KLAST=KES
      NNODE=KLS-KFS+1
      NSUM=NSUM+NNODE
      DO 370 K=KFIRST,KLAST
C
      KDUMY = K-KFIRST+1
      LNODE=NODSF(K)
      IF (LMS(1,K).GE.0 .AND. LMS(2,K).GE.0) GO TO 380
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3200) ISTOP,I,KDUMY,LNODE
C
  380 IF (I.EQ.NSURF) GO TO 370
      IDO=I+1
      DO 390 II=IDO,NSURF
      IS=II
      CALL TRGET2(ISURFP,IFSN,ISEG,NSURF,NSURFP,1)
      IF (ISR.EQ.0) GO TO 390
      DO 400 KK=KFS,KES
      IF (NODSF(KK).NE.LNODE) GO TO 400
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3250) ISTOP,LNODE,I,II
  400 CONTINUE
  390 CONTINUE
C
  370 CONTINUE
      GO TO 340
  350 ITRGT=IS
C
  340 CONTINUE
      IF (NSUM.EQ.NTOUCH) GO TO 410
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3300) ISTOP,NTOUCH,NSUM
C
  410 IF (IDBA.EQ.0) GO TO 420
      CALL EXAMIN (RMDUMY,1,1,LMS,2,NSNOD,2,-4)
      CALL EXAMIN (XYZ,2,NSNOD,IMDUMY,1,1,2,2)
      CALL EXAMIN (RMDUMY,1,1,IA(N5),1,NEQ,2,-8)
      CALL EXAMIN (RMDUMY,1,1,ISKEW,1,NSNOD,2,-11)
  420 CONTINUE
C
C
C
      NCEQN = MODEL
      DO 430 L=1,NSURFP
C
      IT = ISURFP(1,L)
      IS = ISURFP(2,L)
      CALL TRGET2(ISURFP,IFSN,ISEG,NSURF,NSURFP,3)
C
      LHT = 0
      DO 440 K=KFT,KLT
      DO 450 LM=1,2
      ILM = LMS(LM,K)
      IF (ILM) 460,450,470
C
  460 NCE = -ILM
      NLM = NID(NCE)
      IF (NLM.EQ.0) GO TO 450
      DO 480 M=1,NLM
      IHT  = 0
      ILMC = IDI(M,NCE)
      IF (ILMC.GT.0  ) IHT = LEADEQ - ILMC
      IF (IHT .GT.LHT) LHT = IHT
  480 CONTINUE
      GO TO 450
C
  470 IHT = LEADEQ - ILM
      IF (IHT.GT.LHT) LHT = IHT
  450 CONTINUE
  440 CONTINUE
C
      DO 490 K=KFS,KLS
      IHTY = 0
      IHTZ = 0
      LMC = (K-1)*NCEQN
C
      IF (LMS(1,K).GT.0) IHTY = LEADEQ - LMS(1,K)
      IF (LMS(2,K).GT.0) IHTZ = LEADEQ - LMS(2,K)
      IHLM = MAX0( LHT,IHTY,IHTZ )
      KTALL = LMC + IHLM
C
      DO 485 LM=1,NCEQN
      LMNEW = LM + KTALL
      LMOLD = LMHT(LMC+LM)
  485 LMHT(LMC+LM) = MAX0( LMNEW,LMOLD )
  490 CONTINUE
  430 CONTINUE
C
      NCADD = NCEQN*NTOUCH
      INUMEQ(1) = LEADEQ
      LEADEQ = LEADEQ + NCADD
      INUMEQ(2) = LEADEQ
      NCE2D = NCE2D + NCADD
C
      IF (IDBA.EQ.0) GO TO 495
      CALL EXAMIN (RMDUMY,1,1,INUMEQ,1,2,2,-10)
      CALL EXAMIN (RMDUMY,1,1,IA(N5),1,NEQI,2,-8)
      CALL EXAMIN (RMDUMY,1,1,LMHT,1,NCADD,2,-14)
  495 CONTINUE
C
      IF (ISTOP.EQ.0) RETURN
  500 write(66,4000) ISTOP
      STOP
C
C
  600 IF (IND.NE.4) RETURN
      IDBA = IDBUG(3)
      IDBB = IDBUG(4)
C
C
C
      IF (KSTEP.GT.1 .OR.ITE.GT.0) GO TO 610
      IF (NEQL.GT.1) GO TO 620
C
      IF (NPDIS.EQ.0) GO TO 620
      DO 630 M=1,NPDIS
      MNPDIS = NOD(M)
      DO 630 K=1,NSNOD
      DO 630 L=1,2
      IF (MNPDIS.NE.LMS(L,K)) GO TO 630
      write(66,3400) NODSF(K)
      STOP
  630 CONTINUE
      IF (IDBA.GE.1) CALL EXAMIN (RMDUMY,1,1,LMS,2,NSNOD,2,-4)
C
  620 IELCPL=-1
      NXALL=2*NSNOD
      CALL ECHECK (LMS,NXALL,ICODE,IUPDT)
      IF (ICODE.EQ.0) IELCPL=1
      IF (NEQL.EQ.1) IELCPL=1
      IF (IELCPL.EQ.1) GO TO 610
C
      NLOWER=INUMEQ(1)+1
      NUPPER=INUMEQ(2)
      DO 640 L=NLOWER,NUPPER
      IF (L.LT.NEQL .OR. L.GT.NEQR) GO TO 640
      IELCPL=1
      GO TO 610
  640 CONTINUE
      IF (IELCPL.EQ.-1) RETURN
C
C ---
C
  610 ISET=2
      IF (KPRI.EQ.0) GO TO 700
      IF (IEQUIT.EQ.1) ISET=1
      IF (NEQL.GT.1) GO TO 800
C
C
C
C
  700 CALL YZNEW  (X,HT,
     1             RSDCOS,
     1             ISURFP,IFSN,LMS,
     1             INODE,ISEG,IDBUG,
     1             ISV,
     1             INUMEQ,ISKEW,
     1             XYZ,CPROLD,
     1             XYZS,XLN,T,
     1             CPR,DELTA,CLOSED,
     1             NSURF,NSURFP,NTOUCH,NSNOD,NSEG)
C
      IF (ISET.LE.1) GO TO 750
C
      CALL FRICT2 (ISURFP,IFSN,NODSF,
     1             INODE,ISEG,ITS,IDBUG,
     1             IPS,ISV,
     1             JSLIDE,KSLIDE,
     1             FCOFF,
     1             XYZS,XLN,T,
     1             CPR,BETA,DELTA,
     1             NSURF,NSURFP,NTOUCH,NSNOD,NSEG)
C
      IF (KPRI.EQ.0) RETURN
C
  750 CALL ADJOIN (ISURFP,IFSN,NODSF,
     1             INODE,ISEG,ITS,IDBUG,
     1             XYZ,
     1             XYZS,XLN,T,
     1             BETA,DELTA,
     1             NSURF,NSURFP,NTOUCH,NSNOD,NSEG)
C
  800 CALL YZSTF  (IA(N1),A(N4),HT,
     1             RSDCOS,
     1             ISURFP,IFSN,NODSF,LMS,
     1             INODE,ISEG,ITS,IDBUG,
     1             INUMEQ,ISKEW,LMHT,
     1             XLN,T,
     1             CPR,BETA,DELTA,
     1             NSURF,NSURFP,NTOUCH,NSNOD,NSEG)
C
C
C
      IF (IDBB.EQ.0) RETURN
      LONG = NEQ + 1
      IF (IDBB.GE.4) CALL EXAMIN (A(N4),1,ISTOH,IMDUMY,1,1,2,16)
      IF (IDBB.GE.1) CALL EXAMIN (HT,1,NEQ,IMDUMY,1,1,2,14)
      IF (IDBB.GE.2) CALL EXAMIN (RMDUMY,1,1,IA(N1),1,LONG,2,-15)
C
      RETURN
C
 1000 FORMAT(5I5)
 1050 FORMAT(16I5)
 1100 FORMAT(3I5,3F10.6)
 1200 FORMAT(20I3)
C
 2000 FORMAT(//,2X,45H 2 - D I M E N S I O N A L   C O N T A C T   ,
     1      15HS U R F A C E S,//)
 2050 FORMAT(2X,7HSURFACE,6X,6HNUMBER,6X,8HPRINTOUT,6X,8HPORTHOLE,
     1        7H SAVING,/,
     1       3X,6HNUMBER,5X,8HOF NODES,6X,7HCONTROL,10X,7HCONTROL,/ )
 2100 FORMAT(I6,6X,I6,7X,I6,11X,I6)
 2150 FORMAT(////,2X,18H SURFACE    NUMBER,10X,5HLOCAL,15X,6HGLOBAL,
     1               13H NODE NUMBERS,/,2X,
     1               36H  NUMBER   OF NODES     NODE NUMBERS,/)
 2200 FORMAT(2X,I5,I11,/)
 2250 FORMAT(27X,I2,4H  TO,I3,7X,6I5)
C
 2300 FORMAT(//,2X,42H C O N T A C T   S U R F A C E   P A I R S,//,
     1       9X,4HPAIR,8X,6HTARGET,9X,9HCONTACTOR,7X,11HCOEFFICIENT,/,
     1       8X,6HNUMBER,5X,11HSURFACE NO.,5X,11HSURFACE NO.,7X,
     1          11HOF FRICTION,/)
 2350 FORMAT(7X,I5,7X,I5,11X,I5,10X,E12.4)
C
C
C
 2500 FORMAT(/,44H   ERRORS IN 2-D CONTACT SURFACE INPUT DATA    ,/,
     1         21H   SURFACE GROUP NO =,I5,/)
 2550 FORMAT(I5,45H. SURFACE INDICES MUST BE INPUT CONSECUTIVELY,/,
     1       7X,16HSURFACE NUMBER =,I5,11X,16HINPUT AS ISURF =,I5,/)
 2600 FORMAT(I5,44H. EACH SURFACE SHOULD HAVE MINIMUM TWO NODES,/,
     1       7X,11HFOR ISURF =,I5,4X,13HINPUT NNODE =,
     1       I5,/)
 2700 FORMAT(I5,35H. IPS(ISURF) MUST BE EQ.0 .OR. EQ.1,/,
     1       7X,11HFOR ISURF =,I5,5X,20H  INPUT IPS(ISURF) =,I5,/)
 2710 FORMAT(I5,35H. ISV(ISURF) MUST BE EQ.0 .OR. EQ.1,/,
     1       7X,11HFOR ISURF =,I5,5X,20H  INPUT ISV(ISURF) =,I5,/)
 2750 FORMAT(I5,13H. FOR ISURF =,I5,2X,17HIOPEN .NE. 0  AND ,/,
     1       7X,10HNODSF(1) =,I5,2X,18HAND NODSF(NNODE) =,I5,/,
     1       7X,13HARE NOT EQUAL ,/)
 2800 FORMAT(I5,49H. GLOBAL NODE NUMBERS MUST BE .GT.0 AND .LE.NUMNP,
     1     /,7X,11HFOR ISURF =,I5,2X,15HLOCAL NODE  K =,I5,/,
     1       7X,10HNODSF(K) =,I5,10X,7HNUMNP =,I5,/)
 2850 FORMAT(I5,13H. FOR ISURF =,I5,/,
     1       7X,24HLOCAL NODE NUMBERS  KA =,I5,2X,9HAND  KB =,I5,/,
     1       7X,40HHAVE SAME GLOBAL NODE NUMBER NODSF(KA) =,I5,/)
 2900 FORMAT(I5,18H. INPUT NPAR(10) =,I5,/,
     1       7X,39HINPUT TOTAL 2-D CONTACT SURFACE NODES =,I5,/,
     1       7X,13HARE NOT EQUAL ,/)
 2950 FORMAT(I5,44H. SURFACE PAIRS MUST BE INPUT CONSECUTIVELY  ,/,
     1       9X,14HSURFACE PAIR =,I5,10X,17HINPUT AS ISPAIR =,I5,/)
 3000 FORMAT(I5,36H. ITS AND ICS MUST SPECIFY DIFFERENT,
     1       43H SURFACES  AND  ITS.LE.NSURF   ICS.LE.NSURF,/,
     1       9X,7HNSURF =,I4,5X,5HITS =,I4,5X,5HICS =,I4,/)
 3050 FORMAT(I5,44H. FRICTION COEFFICIENTS MUST BE POSITIVE     ,/,
     1       7X,21HAND STCOFF .GE. DCOFF ,/,
     1       8X,10H STCOFF = ,E15.6,10H  DCOFF = ,E15.6,/)
 3100 FORMAT(I5,25H. FRICTION TOLERANCE MUST ,
     1          24H BE GE. 0.0 AND LE. 1.0 ,/,
     1       7X,13HINPUT PRCENT=,I5)
 3150 FORMAT(I5,32H. TARGET SURFACES MUST BE INPUT ,
     1          24HAFTER CONTACTOR SURFACES,/,
     1       7X,19HTARGET SURFACE NO =,I5,4X,
     1          15HIS INPUT BEFORE ,/,
     1       7X,22HCONTACTOR SURFACE NO =,I5)
 3200 FORMAT(I5,43H. A CONTACTOR SURFACE CANNOT HAVE DEPENDENT,/,
     1       7X,18HDEGREES OF FREEDOM,/,
     1       7X,11HFOR ISURF =,I5,2X,17HLOCAL NODE NO K =,I5,/,
     1      25X,16HGLOBAL NODE NO =,I5,/,
     1       7X,34HDOES NOT HAVE ALL INDEPENDENT DOF ,/)
 3250 FORMAT(I5,40H. A GENERIC NODE ON 2-D CONTACT SURFACES ,/,
     1       7X,26HCANNOT BELONG TO MORE THAN ,/,
     1       7X,21HONE CONTACTOR SURFACE ,/,
     1       7X,16HGLOBAL NODE NO =,I5,/,
     1       7X,18HBELONGS TO ISURF =,I5,2X,12HAND  ISURF =,I5,/)
 3300 FORMAT(I5,18H. INPUT NPAR( 9) =,I5,/,
     1       7X,37HINPUT TOTAL CONTACTOR SURFACE NODES =,I5,/,
     1       7X,13HARE NOT EQUAL,/)
 3350 FORMAT(/,2X,8HNSKEWS =,I5,14H AND NPAR(6) =,I5,/,
     1         2X,18HARE NOT COMPATIBLE,/)
 3400 FORMAT(7X,37HDISPLACEMENTS CANNOT BE PRESCRIBED AT,/,
     1       7X,21HCONTACT SURFACE NODES,/,
     1       7X,21HSURFACE NODE NUMBER =,I5,4X,5HHAS A,/,
     1       7X,41HPRESCRIBED DISPLACEMENT DEGREE OF FREEDOM,/)
 4000 FORMAT(//,2X,25H TOTAL NUMBER OF ERRORS =,I5,////,
     1       2X,46H S T O P  (ERRORS IN 2-D CONTACT SURFACE DATA) )
C
      END
      SUBROUTINE YZNEW (X,R,
     1                  RSDCOS,
     1                  ISURFP,IFSN,LMS,
     1                  INODE,ISEG,IDBUG,
     1                  ISV,
     1                  INUMEQ,ISKEW,
     1                  XYZ,CPROLD,
     1                  XYZS,XLN,T,
     1                  CPR,GAUSS,CLOSED,
     1                  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 /EL/ IND,ICOUNT,NPAR(20),NUMEG,NEGL,NEGNL,IMASS,IDAMP,ISTAT
     1           ,NDFD,KLIN,IEIG,IMASSN,IDAMPN
      COMMON /VAR/ NG,MODEX,IUPDT,KSTEP,ITEMAX,IEQREF,ITE,KPRI,
     1             IREF,IEQUIT,IPRI,KPLOTN,KPLOTE
      COMMON /NORMS/ RNORM,RENORM,RTOL,DTOL,STOL,SMAX,SMIN,
     1               DMAX,DMIN,ETOL
      COMMON /ADDB/ NEQL,NEQR,MLA,NBLOCK
      COMMON /CNTACT/ NEQI,LEADEQ,NCE2D,NCE3D
      COMMON /ITRATE/ RCENRM,RCNORM,RCONSM,RCTOL
      COMMON /SRFACE/ IS,KFS,KLS,KES,JFS,JLS,JFSD,JLSD
      COMMON /MATCH/ ISR,IPAIR,JFSEG,JLSEG,JTSEG
      COMMON /OPRATE/ ISET