a37.for

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

      write(66,2710) ISTOP,ISURF,IPLOT
C
   60 IF (ISTOP.GT.0) GO TO 65
      IF (IDATWR.GT.1) GO TO 65
      write(66,2100) ISURF,NSEG,NNODE,IPRINT,IPLOT
C
C
C
   65 JFS = IFSE(I)
      JLS = JFS + NSEG - 1
      READ (IIN,1100) MJS,MA,MB,MC,MD,MKN
C
      IF (MJS.EQ.1) GO TO 175
      JLOCAL=1
      ISTOP = ISTOP + 1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2715) ISTOP,ISURF,MJS,JLOCAL
C
  175 JS = MJS
      NA = MA
      NB = MB
      NC = MC
      ND = MD
      KN = MKN
      NGEN = NSEG
      IF (KN.EQ.0) KN = 1
C
      IF (JS.EQ.NSEG) GO TO 180
      READ (IIN,1100) MJS,MA,MB,MC,MD,MKN
C
      NGEN = MJS - 1
      IF (NGEN.GE.JS) GO TO 185
      ISTOP = ISTOP + 1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2720) ISTOP,ISURF,JS,NGEN
      STOP
C
  185 IF (MJS.LE.NSEG) GO TO 180
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2730) ISTOP,ISURF,NSEG,MJS
      STOP
C
  180 DO 190 JL=JS,NGEN
      NUMJ = JL
      JEL  = JL+JFS-1
      LOOP = (NUMJ-JS)*KN
      NCA(1,JEL) = NA + LOOP
      NCA(2,JEL) = NB + LOOP
      NCA(3,JEL) = NC + LOOP
      NCA(4,JEL) = ND + LOOP
  190 CONTINUE
      IF (NUMJ.LT.NSEG) GO TO 175
C
      DO 70 J=JFS,JLS
      DO 80 L=1,4
      NODE=NCA(L,J)
      IF (NODE.GT.0 .AND. NODE.LE.NUMNP) GO TO 80
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2750) ISTOP,ISURF,JS,NODE
   80 CONTINUE
C
      IF (NCA(1,J).EQ.NCA(3,J)) GO TO 90
      IF (NCA(2,J).EQ.NCA(4,J)) GO TO 90
C
      IF (NCA(1,J).NE.NCA(2,J)) GO TO 92
      IF (NCA(3,J).NE.NCA(4,J)) GO TO 92
      GO TO 90
C
   92 IF (NCA(1,J).NE.NCA(4,J)) GO TO 94
      IF (NCA(2,J).NE.NCA(3,J)) GO TO 94
C
   90 ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2800) ISTOP,ISURF,JS
C
   94 CONTINUE
   70 CONTINUE
C
C
      IF (ISTOP.GT.0) GO TO 20
      IF (IDATWR.GT.1) GO TO 76
      DO 75 J=JFS,JLS
      JLOCAL=J-JFS+1
   75 write(66,2200) JLOCAL,(NCA(L,J),L=1,4)
C
C
C
   76 IF (JNPORT.EQ.0 .OR. NPUTSV.EQ.0) GO TO 20
      IF (JNPORT.EQ.1)
     1   WRITE (IBPORT     ) '3D-CONTC',ISURF,NSEG,IPRINT,IPLOT,NNODE,
     2                       JFS,JLS,((NCA(L,J),L=1,4),J=JFS,JLS)
      IF (JNPORT.EQ.2)
     1   WRITE (IFPORT,9000) '3D-CONTC',ISURF,NSEG,IPRINT,IPLOT,NNODE,
     2                       JFS,JLS,((NCA(L,J),L=1,4),J=JFS,JLS)
C
 9000 FORMAT ( A,/,7I10,/,(8I10) )
C
C
   20 CONTINUE
C
      IF (NJSUM.EQ.NEALL) GO TO 110
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2850) ISTOP,NEALL,NJSUM
C
  110 IF (NKSUM.EQ.NSNOD) GO TO 120
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2900) ISTOP,NSNOD,NKSUM
C
C
C
  120 IF (IDATWR.LE.1) write(66,2300)
C
      DO 130 L=1,NSURFP
      READ (IIN,1200) ISPAIR,IT,IC,SCF,DCF
C
C
      IF (ISPAIR.EQ.L) GO TO 140
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,2950) ISTOP,L,ISPAIR
C
  140 IF (IT.NE.IC .AND. IT.LE.NSURF .AND. IC.LE.NSURF) GO TO 145
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3000) ISTOP,NSURF,IT,IC
C
  145 IF (MODEL.GT.1) GO TO 150
      PCF=0.0D0
      GO TO 160
C
  150 PCF = 1.0D+08
C
C
  160 IF (ISTOP.GT.0) GO TO 130
      IF (IDATWR.LE.1) write(66,2350) L,IT,IC
      ISURFP(1,L)=IT
      ISURFP(2,L)=IC
      FCOFF(1,L)=PCF
C
C
      IF (JNPORT.EQ.0 .OR. NPUTSV.EQ.0) GO TO 130
      IF (JNPORT.EQ.1)
     1   WRITE (IBPORT     ) '3D-SURFP',ISPAIR,IT,IC,SCF,DCF
      IF (JNPORT.EQ.2)
     1   WRITE (IFPORT,9010) '3D-SURFP',ISPAIR,IT,IC,SCF,DCF
C
 9010 FORMAT ( A,/,3I10,/,2E20.13 )
C
C
  130 CONTINUE
C
C
      ITRGET=0
      DO 132 I=1,NSURF
      IS=I
      CALL TRGET3 (ISURFP,IFSN,IFSE,NSURF,NSURFP,1)
      IF (ISR.EQ.0) GO TO 134
      IF (ITRGET.EQ.0) GO TO 132
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3100) ISTOP,ITRGET,IS
      GO TO 132
  134 ITRGET=IS
  132 CONTINUE
C
      IF (ISTOP.GT.0) GO TO 445
C
C
  200 IF (IDBPR.EQ.-1) READ (IIN,1300) (IDBUG(L),L=1,16)
      IDBA=IDBUG(3)
      IDBB=IDBUG(4)
C
      IF (IDBA.EQ.0) GO TO 205
      CALL LIGHT (RMDUMY,1,1,ISURFP,2,NSURFP,2,-1)
      CALL LIGHT (RMDUMY,1,1,IFSN,1,NSURF,2,-2)
      CALL LIGHT (RMDUMY,1,1,IFSE,1,NSURF,2,-3)
      CALL LIGHT (RMDUMY,1,1,NCA,4,NEALL,2,-10)
  205 CONTINUE
C
C
C
C
C
      DO 220 I=1,NSURF
      IS = I
      CALL TRGET3 (ISURFP,IFSN,IFSE,NSURF,NSURFP,1)
      KEND = KFS
      NODSF(KEND) = NCA(1,JFS)
C
      DO 230 J=JFS,JLS
      DO 240 L=1,4
      NODE = NCA(L,J)
C
      DO 250 K=KFS,KEND
      IF (NODSF(K).NE.NODE) GO TO 250
      NCA(L,J)=K
      GO TO 240
  250 CONTINUE
C
      KEND = KEND + 1
      NCA(L,J) = KEND
      NODSF(KEND) = NODE
  240 CONTINUE
  230 CONTINUE
C
      IF (KEND.EQ.KLS) GO TO 220
      ISTOP=ISTOP+1
      NNODE=KLS-KFS+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3150) ISTOP,I,NNODE
  220 CONTINUE
C
C
      DO 280 K=1,NSNOD
      IJ=0
C
      DO 270 J=1,NEALL
      DO 300 L=1,4
      IF (NCA(L,J).NE.K) GO TO 300
      IJ=IJ+1
      IF (IJ.LE.NJOIN) JOIN(IJ,K)=J
      GO TO 270
  300 CONTINUE
  270 CONTINUE
C
      IF (IJ.GT.0 .AND. IJ.LE.NJOIN) GO TO 280
      ISTOP=ISTOP+1
      NODE = NODSF(K)
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3225) ISTOP,NJOIN,NODE
  280 CONTINUE
C
      IF (IDBA.EQ.0) GO TO 285
      CALL LIGHT (RMDUMY,1,1,NODSF,1,NSNOD,2,-6)
      CALL LIGHT (RMDUMY,1,1,NCA,4,NEALL,2,-11)
      CALL LIGHT (RMDUMY,1,1,JOIN,NJOIN,NSNOD,2,-20)
  285 IF (ISTOP.GT.0) GO TO 445
C
C
C
      LOOP = NEQI + NDISCE
      DO 275 K=1,NSNOD
      NODE=NODSF(K)
      XYZ(1,K)=X(NODE)
      XYZ(2,K)=Y(NODE)
      XYZ(3,K)=Z(NODE)
      ISKEW(K)=0
      IF (NSKEWS.GT.0) ISKEW(K) = NODSYS(NODE)
      LL=0
      DO 290 L=1,3
      IF (IDOF(L).EQ.0) GO TO 305
      LMS(L,K)=0
      GO TO 290
  305 LL=LL+1
      IDEQN=ID(LL,NODE)
      IF (IDEQN.GT.LOOP) IDEQN=0
      LMS(L,K)=IDEQN
  290 CONTINUE
  275 CONTINUE
C
      IF (NEGSKS.GT.0) GO TO 335
      DO 345 K=1,NSNOD
      IF (ISKEW(K).EQ.0) GO TO 345
      write(66,3600) NSKEWS,NEGSKS
      STOP
  345 CONTINUE
  335 CONTINUE
C
      IF (IDBA.EQ.0) GO TO 295
      CALL LIGHT (RMDUMY,1,1,LMS  ,3,NSNOD,2,-7)
      CALL LIGHT (RMDUMY,1,1,ISKEW,1,NSNOD,2,-8)
      CALL LIGHT (XYZ,3,NSNOD,IMDUMY,1,1,2,2)
  295 CONTINUE
C
C
      NKSUM=0
      NJSUM=0
      DO 315 I=1,NSURF
      IS=I
      CALL TRGET3 (ISURFP,IFSN,IFSE,NSURF,NSURFP,1)
      IF (ISR.EQ.0) GO TO 315
      KFIRST=KFS
      KLAST =KLS
      NKSUM = NKSUM  +  KLS - KFS + 1
      NJSUM = NJSUM  +  JLS - JFS + 1
C
      DO 320 K=KFIRST,KLAST
      NODE=NODSF(K)
C
      DO 325 L=1,3
      IF ( LMS(L,K).GE.0 ) GO TO 325
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3300) ISTOP,I,NODE
  325 CONTINUE
C
      IF (I.EQ.NSURF) GO TO 320
      IDO=I+1
      DO 340 II=IDO,NSURF
      IS=II
      CALL TRGET3 (ISURFP,IFSN,IFSE,NSURF,NSURFP,1)
      IF (ISR.EQ.0) GO TO 340
      DO 350 KK=KFS,KLS
      IF (NODSF(KK).NE.NODE) GO TO 350
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3350) ISTOP,NODE,I,II
  350 CONTINUE
  340 CONTINUE
C
  320 CONTINUE
  315 CONTINUE
C
      IF (NKSUM.EQ.NTOUCH) GO TO 360
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3400) ISTOP,NTOUCH,NKSUM
C
  360 IF (NJSUM.EQ.NECON) GO TO 370
      ISTOP=ISTOP+1
      write(66,3425) ISTOP,NECON,NJSUM
C
  370 IF (NECON.LE.NEALL) GO TO 365
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3500) ISTOP,NECON,NEALL
C
  365 IF (NTOUCH.LE.NSNOD) GO TO 375
      ISTOP=ISTOP+1
      IF (ISTOP.EQ.1) write(66,2500) NG
      write(66,3550) ISTOP,NTOUCH,NSNOD
C
  375 IF (ISTOP.GT.0) GO TO 445
      IF (IDBA.GE.1) CALL LIGHT (RMDUMY,1,1,IA(N5),1,NEQ,2,-21)
C
C
C
C
      DO 430 L=1,NSURFP
C
      IT = ISURFP(1,L)
      IS = ISURFP(2,L)
      CALL TRGET3 (ISURFP,IFSN,IFSE,NSURF,NSURFP,3)
C
      LHT = 0
      DO 440 K=KFT,KLT
      DO 450 LM=1,3
      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
      IHTX = 0
      IHTY = 0
      IHTZ = 0
      LMC  = (K-1)*NCEQN
C
      IF (LMS(1,K).GT.0) IHTX = LEADEQ - LMS(1,K)
      IF (LMS(2,K).GT.0) IHTY = LEADEQ - LMS(2,K)
      IF (LMS(3,K).GT.0) IHTZ = LEADEQ - LMS(3,K)
      IHLM = MAX0( LHT,IHTX,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
C
      INUMEQ(1) = LEADEQ
      LEADEQ    = LEADEQ + NCADD
      INUMEQ(2) = LEADEQ
      NCE3D = NCE3D + NCADD
      IF (IDBA.GE.1) CALL LIGHT (RMDUMY,1,1,LMHT,1,NCADD,2,-26)
      IF (IDBA.GE.1) CALL LIGHT (RMDUMY,1,1,INUMEQ,1,2,2,-9)
C
      IF (ISTOP.EQ.0) GO TO 452
  445 write(66,4000) ISTOP
      STOP
  452 CONTINUE
C
C
C
      DO 500 J=1,NECON
      LS=NTOUCH
      DO 510 L=1,4
      LI=NCA(L,J)
      IF (LI.LT.LS) LS=LI
  510 CONTINUE
C
      DO 520 L=1,4
      LI=NCA(L,J)
      ME=LI-LS
      LMTEMP=LMAXA(LI)
      LMAXA(LI)=MAX0(LMTEMP,ME)
  520 CONTINUE
  500 CONTINUE
C
      IF (IDBA.GT.0) CALL LIGHT (RMDUMY,1,1,LMAXA,1,NTOUCH,2,-13)
C
      LMAX=1
      NTOU=NTOUCH+1
      DO 530 K=1,NTOU
      LHT = LMAXA(K)
      LMAXA(K) = LMAX
      LMAX = LMAX + LHT + 1
  530 CONTINUE
C
      NXALL  = 3*NSNOD
      LENGTH = LMAXA(NTOUCH+1) - LMAXA(1)
      LNWK   = MAX0( NXALL,LENGTH )
C
      IF (IDBA.GT.0) CALL LIGHT (RMDUMY,1,1,LMAXA,1,NTOU,2,-12)
C
      DO 540 K=1,NTOUCH
  540 INODE(K)=10
      DO 550 J=1,NECON
  550 ISECT(J)=10
C
      RETURN
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 640 M=1,NPDIS
      MNPDIS=NOD(M)
      DO 640 K=1,NSNOD
      DO 640 L=1,3
      IF (MNPDIS.NE.LMS(L,K)) GO TO 640
      write(66,3650) NODSF(K)
      STOP
  640 CONTINUE
      IF (IDBA.GT.0) CALL LIGHT (RMDUMY,1,1,LMS,3,NSNOD,2,-7)
C
  620 IELCPL=-1
      NXALL=3*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)