a37.for

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

      DO 630 L=NLOWER,NUPPER
      IF (L.LT.NEQL .OR. L.GT.NEQR) GO TO 630
      IELCPL=1
      GO TO 610
  630 CONTINUE
      IF (IELCPL.EQ.-1) RETURN
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
  700 CALL XYZNEW (X,HT,
     1             RSDCOS,
     1             ISURFP,IFSN,IFSE,
     1             LMS,ISKEW,INUMEQ,NCA,
     1             LMAXA,INODE,ISECT,
     1             IDBUG,
     1             XYZ,XYZS,CPROLD,
     1             CPR,GUSTAV,VN,
     1             T,
     1             NSURFP,NECON,NEALL,NTOUCH,NSNOD)
C
      IF (ISET.LE.1) GO TO 750
C
      CALL FRICT3 (ISURFP,IFSN,IFSE,IPS,ISV,
     1             NODSF,NCA,
     1             INODE,ISECT,
     1             ITS,ITSP,JOIN,IDBUG,
     1             FCOFF,XYZS,
     1             CPR,DELTA,GUSTAV,VN,
     1             T,
     1             NSURFP,NECON,NEALL,NTOUCH,NSNOD,NJOIN)
C
      IF (KPRI.EQ.0) RETURN
C
  750 CALL TPOLGY (ISURFP,IFSN,IFSE,NODSF,
     1             NCA,
     1             INODE,ISECT,
     1             ITS,ITSP,JOIN,IDBUG,
     1             XYZ,XYZS,
     1             DELTA,VN,
     1             NSURFP,NEALL,NTOUCH,NSNOD,NJOIN)
C
  800 CALL XYZSTF (IA(N1),A(N4),HT,
     1             RSDCOS,
     1             ISURFP,IFSN,IFSE,NODSF,
     1             LMS,ISKEW,INUMEQ,NCA,
     1             INODE,
     1             ITS,ITSP,LMHT,IDBUG,
     1             XYZS,
     1             DELTA,
     1             CPR,VN,
     1             NSURFP,NEALL,NTOUCH,NSNOD)
C
C
C
      IF (IDBB.EQ.0) RETURN
      IF (IDBB.EQ.4) CALL LIGHT (A(N4),1,ISTOH,IMDUMY,1,1,2,12)
      IF (IDBB.GT.1) CALL LIGHT (HT,1,NEQ,IMDUMY,1,1,2,16)
      LONG = NEQ + 1
      IF (IDBB.GT.2) CALL LIGHT (RMDUMY,1,1,IA(N1),1,LONG,2,-23)
C
 1000 FORMAT(5I5)
 1100 FORMAT(6I5)
 1200 FORMAT(3I5,3F10.4)
 1300 FORMAT(20I3)
 2100 FORMAT(/,3X,I3,9X,I4,11X,I4,11X,I2,8X,I3)
 2200 FORMAT(72X,I4,3X,I5,4X,I5,4X,I5,4X,I5)
 2350 FORMAT(7X,I5,7X,I5,12X,I5)
C
 2000 FORMAT(//,2X,45H 3 - 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,5X,9HNUMBER OF,5X,9HNUMBER OF,5X,
     1       8HPRINTOUT,3X,15HPORTHOLE SAVING,3X,7HSEGMENT,
     1       2X,7HNODE(1),2X,7HNODE(2),2X,7HNODE(3),2X,7HNODE(4),/,
     1       3X,6HNUMBER,5X,8HSEGMENTS,8X,5HNODES,7X,7HCONTROL,
     1       8X,7HCONTROL,7X,6HNUMBER )
 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,/,
     1       8X,6HNUMBER,5X,11HSURFACE NO.,5X,11HSURFACE NO.,/)
C
C
C
 2500 FORMAT(/,44H   ERRORS IN 3-D CONTACT SURFACE INPUT DATA    ,/,
     1         21H   SURFACE GROUP NO =,I5,/)
 2550 FORMAT(/,I5,47H). CONTACT SURFACES MUST BE INPUT CONSECUTIVELY,/,
     1         8X,16HSURFACE NUMBER =,I5,4X,/,
     2         8X,25HINPUT AS SURFACE NUMBER =,I5)
 2600 FORMAT(/,I5,41H). FOR EACH CONTACT SURFACE   NSEG .GE. 1,/,
     1         8X,11HFOR ISURF =,I5,4X,12HINPUT NSEG =,I5)
 2650 FORMAT(/,I5,41H). NUMBER OF SURFACE NODES MUST BE GE. 3 ,/,
     1         8X,11HFOR ISURF =,I5,/,
     2         8X,13HINPUT NNODE =,I5)
 2700 FORMAT(/,I5,34H). IPS(ISURF) MUST BE EQ.0 OR EQ.1,/,
     1         8X,11HFOR ISURF =,I5,6X,18HINPUT IPS(ISURF) =,I5)
 2710 FORMAT(/,I5,34H). ISV(ISURF) MUST BE EQ.0 OR EQ.1,/,
     1         8X,11HFOR ISURF =,I5,6X,18HINPUT ISV(ISURF) =,I5)
 2715 FORMAT(/,I5,47H). SURFACE SEGMENTS MUST BE INPUT CONSECUTIVELY,/,
     1         8X,11HFOR ISURF =,I5,/,
     1         8X,24HSURFACE SEGMENT NUMBER =,I5,4X,/,
     1         8X,33HINPUT AS SURFACE SEGMENT NUMBER =,I5)
 2720 FORMAT(/,I5,47H). SURFACE SEGMENTS MUST BE INPUT CONSECUTIVELY,/,
     1         8X,11HFOR ISURF =,I5,/,
     1         8X,24HSURFACE SEGMENT NUMBER =,I5,4X,/,
     1         8X,37HINPUT BEFORE SURFACE SEGMENT NUMBER =,I5)
 2730 FORMAT(/,I5,42H). SURFACE SEGMENT NUMBER MUST BE LE. NSEG,/,
     1         8X,11HFOR ISURF =,I5,5X,6HNSEG =,I5,/,
     1         8X,24HSURFACE SEGMENT NUMBER =,I5,4X,/,
     1         8X,16HIS OUT OF BOUNDS )
 2750 FORMAT(/,I5,48H). GLOBAL NODE NUMBERS MUST BE GT.0 AND LE.NUMNP,/,
     1         8X,11HFOR ISURF =,I5,4X,13HSEGMENT NO. =,I5,/,
     2         8X,14HTHE NODE NO. =,I5,4X,16HIS OUT OF BOUNDS )
 2800 FORMAT(/,I5,46H). EACH SURFACE SEGMENT MUST HAVE NONZERO AREA,/,
     1         8X,11HFOR ISURF =,I5,6X,13HSEGMENT NO. =,I5,4X,3HHAS,/,
     2         8X,10HZERO AREA.  )
 2850 FORMAT(/,I5,38H). TOTAL NUMBER OF SEGMENTS, NPAR(8) =,I5,/,
     1          8X,19HDOES NOT MATCH WITH,/,
     1          8X,26HINPUT NUMBER OF SEGMENTS =,I5)
 3050 FORMAT(/,I5,38H). TOTAL NUMBER OF SEGMENTS, NPAR(8) =,I5,/,
     1         8X,26HINPUT NUMBER OF SEGMENTS =,I5)
 2900 FORMAT(/,I5,36H). TOTAL NUMBER OF NODES  NPAR(10) =,I5,/,
     1         8X,23HINPUT NUMBER OF NODES =,I5)
 2950 FORMAT(/,I5,44H). SURFACE PAIRS MUST BE INPUT CONSECUTIVELY,/,
     1         8X,18HSURFACE PAIR NO. =,I5,/,
     1         8X,19HINPUT AS PAIR NO. =,I5)
 3000 FORMAT(/,I5,46H). ITS AND ICS MUST SPECIFY DIFFERENT SURFACES,/,
     1         8X,13HITS LE. NSURF,4X,3HAND,4X,13HICS LE. NSURF,/,
     1         8X,13HINPUT NSURF =,I5,/,
     1         8X,11HINPUT ITS =,I5,7X,11HINPUT ICS =,I5)
 3100 FORMAT(/,I5,45H). ALL CONTACTOR SURFACES MUST BE INPUT FIRST,/,
     1         8X,20HTARGET SURFACE NO. =,I5,4X,
     1         8X,35HIS INPUT BEFORE CONTACTOR SURFACE =,I5)
 3150 FORMAT(/,I5,14H). FOR ISURF =,I5,10X,7HNNODE =,I5,/,
     1         8X,40HINPUT NUMBER OF NODES NOT EQUAL TO NNODE )
 3225 FORMAT(/,I5,19H). INPUT NPAR(11) =,I5,/,
     1         8X,17HGLOBAL NODE NO. =,I5,/,
     1         8X,40HTHE NUMBER OF SEGMENTS SHARING THE NODE ,/,
     1         8X,30HMUST BE GE. 1 AND LE. NPAR(11)  )
 3300 FORMAT(/,I5,44H). A CONTACTOR SURFACE CANNOT HAVE DEPENDENT,/,
     1         8X,18HDEGREES OF FREEDOM,/,
     1         8X,11HFOR ISURF =,I5,2X,/,
     1        26X,16HGLOBAL NODE NO =,I5,/,
     1         8X,34HDOES NOT HAVE ALL INDEPENDENT DOF )
 3350 FORMAT(/,I5,41H). A GENERIC NODE ON 3-D CONTACT SURFACES ,/,
     1         8X,26HCANNOT BELONG TO MORE THAN,/,
     1         8X,21HONE CONTACTOR SURFACE ,/,
     1         8X,16HGLOBAL NODE NO =,I5,/,
     1         8X,18HBELONGS TO ISURF =,I5,2X,11HAND ISURF =,I5)
 3400 FORMAT(/,I5,19H). INPUT NPAR( 9) =,I5,/,
     1         8X,37HINPUT TOTAL CONTACTOR SURFACE NODES =,I5,/,
     1         8X,13HARE NOT EQUAL )
 3425 FORMAT(/,I5,18H). INPUT NPAR(7) =,I5,/,
     1         8X,40HINPUT TOTAL CONTACTOR SURFACE SEGMENTS =,I5,/,
     1         8X,13HARE NOT EQUAL )
 3500 FORMAT(/,I5,42H). TOTAL NO. OF CONTACTOR SURFACE SEGMENTS ,/,
     1         8X,41HMUST BE .LE. TOTAL NO. OF SEGMENTS ON ALL ,/,
     1         8X,20H3-D CONTACT SURFACES ,/,
     1         8X,15HINPUT NPAR(7) =,I5,3X,15HINPUT NPAR(8) =,I5  )
 3550 FORMAT(/,I5,39H). TOTAL NO. OF CONTACTOR SURFACE NODES ,/,
     1         8X,38HMUST BE .LE. TOTAL NO. OF NODES ON ALL ,/,
     1         8X,20H3-D CONTACT SURFACES ,/,
     1         8X,15HINPUT NPAR(9) =,I5,3X,16HINPUT NPAR(10) =,I5  )
 3600 FORMAT(/,2X,8HNSKEWS =,I5,14H AND NPAR(6) =,I5,/,
     1         2X,18HARE NOT COMPATIBLE,/)
 3650 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 3-D CONTACT SURFACE DATA) )
C
      END
      SUBROUTINE XYZNEW (X,R,
     1                   RSDCOS,
     1                   ISURFP,IFSN,IFSE,
     1                   LMS,ISKEW,INUMEQ,NCA,
     1                   LMAXA,INODE,ISECT,
     1                   IDBUG,
     1                   XYZ,XYZS,CPROLD,
     1                   CPR,GUSTAV,VN,
     1                   T,
     1                   NSURFP,NECON,NEALL,NTOUCH,NSNOD)
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 /SURF3/ IS,KFS,KLS,JFS,JLS
      COMMON /TRGT3/ IT,KFT,KLT,JFT,JLT
      COMMON /MATCH3/ ISR,IPAIR,JTSECT
      COMMON /VALUES/ C1,C2,C3,C4,C5
      COMMON /ISET3/ ISET,NCEQN
C
      DIMENSION X(*),R(*),
     1          RSDCOS(9,*)
      DIMENSION ISURFP(2,NSURFP),IFSN(*),IFSE(*),
     1          LMS(3,NSNOD),ISKEW(*),INUMEQ(2),NCA(4,NEALL),
     1          LMAXA(*),INODE(*),ISECT(*),
     1          IDBUG(16)
      DIMENSION XYZ(3,NSNOD),XYZS(3,NSNOD),CPROLD(3,NTOUCH),
     1          CPR(3,NTOUCH),GUSTAV(4,NECON),
     1          VN(3,NEALL),
     1          T(*)
      DIMENSION S(10),RS(5)
      DIMENSION IMDUMY(1,1),RMDUMY(1,1)
C
      EQUIVALENCE (  NPAR(2),NSURF  ),(  NPAR(6),NEGSKS  ),
     1            (  NPAR(20),LNWK  )
C
      DATA RS / 0.5773502691D0, 0.5773502691D0, -0.5773502691D0,
     1         -0.5773502691D0, 0.5773502691D0 /
      DATA SMALL / 1.0D-12 /
C
      IDBA = IDBUG(5)
      IDBB = IDBUG(6)
      IF (IDBA.LT.3) GO TO 50
      CALL LIGHT (X  ,1,NEQ  ,IMDUMY,1,1,3,14)
      CALL LIGHT (XYZ,3,NSNOD,IMDUMY,1,1,3,2)
C
C
C
   50 DO 60 K=1,NSNOD
      DO 60 L=1,3
   60 XYZS(L,K) =0.0D0
      DO 70 K=1,NTOUCH
      DO 70 L=1,3
   70 CPR(L,K)=0.0D0
      DO 80 J=1,NECON
      DO 80 L=1,4
   80 GUSTAV(L,J)=0.0D0
      DO 90 J=1,NEALL
      DO 90 L=1,3
   90 VN(L,J)=0.0D0
C
      NLOWER = INUMEQ(1) + 1
      NUPPER = INUMEQ(2)
      DO 100 L=NLOWER,NUPPER
  100 X(L)=0.0D0
C
C
C
      DO 110 K=1,NSNOD
      DO 110 L=1,3
      KDOF=LMS(L,K)
      IF (KDOF.GT.NEQ) KDOF = KDOF - NEQ
      IF (KDOF.LT. 0 ) KDOF = NEQ  - KDOF
      XMOVE=0.0D0
      IF (KDOF.GT.0) XMOVE=X(KDOF)
      XYZS(L,K)=XMOVE
  110 CONTINUE
      IF (NEGSKS.GT.0) CALL DIRCOS (RSDCOS,XYZS,ISKEW,NSNOD,3,1)
C
      DO 130 K=1,NSNOD
      DO 130 L=1,3
      XYZS(L,K) = XYZ(L,K) + XYZS(L,K)
  130 CONTINUE
C
      IF (IDBA.GT.0) CALL LIGHT (XYZS,3,NSNOD,IMDUMY,1,1,3,3)
C
C
C
C
C
      DO 160 I=1,NSURF
      IS=I
      CALL TRGET3 (ISURFP,IFSN,IFSE,NSURF,NSURFP,1)
      DO 170 J=JFS,JLS
      JSEC=J
      KA=NCA(1,J)
      KB=NCA(2,J)
      KC=NCA(3,J)
      KD=NCA(4,J)
C
      XA = XYZS(1,KA)
      YA = XYZS(2,KA)
      ZA = XYZS(3,KA)
      XB = XYZS(1,KB)
      YB = XYZS(2,KB)
      ZB = XYZS(3,KB)
      XC = XYZS(1,KC)
      YC = XYZS(2,KC)
      ZC = XYZS(3,KC)
      XD = XYZS(1,KD)
      YD = XYZS(2,KD)
      ZD = XYZS(3,KD)
C
C
      RX = (  XA+XD  -  XB-XC  )/4.0
      RY = (  YA+YD  -  YB-YC  )/4.0
      RZ = (  ZA+ZD  -  ZB-ZC  )/4.0
C
C
      SX = (  XA+XB  -  XC-XD  )/4.0
      SY = (  YA+YB  -  YC-YD  )/4.0
      SZ = (  ZA+ZB  -  ZC-ZD  )/4.0
C
C
      VX =  SY*RZ  -  RY*SZ
      VY =  SZ*RX  -  RZ*SX
      VZ =  SX*RY  -  RX*SY
      RESULT = SQRT( VX*VX + VY*VY + VZ*VZ )
      IF (RESULT.LT.SMALL) GO TO 175
C
      VN(1,J) = VX/RESULT
      VN(2,J) = VY/RESULT
      VN(3,J) = VZ/RESULT
      IF (ISR.EQ.0) GO TO 170
C
      CX = (  XA+XC  -  XB-XD  )/4.0
      CY = (  YA+YC  -  YB-YD  )/4.0
      CZ = (  ZA+ZC  -  ZB-ZD  )/4.0
C
      DO 180 L=1,4
      XR = RS(L+1)
      XS = RS(L)
C
      RX = RX + XS*CX
      RY = RY + XS*CY
      RZ = RZ + XS*CZ
C
      SX = SX + XR*CX
      SY = SY + XR*CY
      SZ = SZ + XR*CZ
C
      VX =  SY*RZ  -  RY*SZ
      VY =  SZ*RX  -  RZ*SX
      VZ =  SX*RY  -  RX*SY
      RESULT = SQRT( VX*VX + VY*VY + VZ*VZ )
      IF (RESULT.LT.SMALL) GO TO 175
      GUSTAV(L,J) = RESULT
C
  180 CONTINUE
  170 CONTINUE
  160 CONTINUE
C
      IF (IDBA.EQ.0) GO TO 185
      CALL LIGHT (VN,3,NEALL,IMDUMY,1,1,3,10)
      CALL LIGHT (GUSTAV,4,NECON,IMDUMY,1,1,3,9)
      CALL LIGHT (CPROLD,3,NTOUCH,IMDUMY,1,1,3,4)
      GO TO 185
C
  175 write(66,2550) IS,JSEC
      STOP
C
C
C
  185 IF (KPRI.GT.0) GO TO 210
      DO 215 K=1,NTOUCH
      DO 215 L=1,3
  215 CPR(L,K)=CPROLD(L,K)
      IF (NEGSKS.GT.0) CALL DIRCOS (RSDCOS,CPR,ISKEW,NTOUCH,3,1)
      GO TO 260
C
  210 CSMALL = 0.0D0
      CTOTAL = 0.0D0
C
      DO 190 K=1,NTOUCH
      IXDOF=LMS(1,K)
      IYDOF=LMS(2,K)
      IZDOF=LMS(3,K)
      FX=0.0D0
      FY=0.0D0
      FZ=0.0D0
      KSNA = IABS( INODE(K) )
      IF (KSNA.EQ.10) GO TO 195
      IF (IXDOF.GT.0 .AND. IXDOF.LE.NEQI) FX = -R(IXDOF)
      IF (IYDOF.GT.0 .AND. IYDOF.LE.NEQI) FY = -R(IYDOF)
      IF (IZDOF.GT.0 .AND. IZDOF.LE.NEQI) FZ = -R(IZDOF)
      CPR(1,K) = FX
      CPR(2,K) = FY
      CPR(3,K) = FZ
C
  195 DIFX = CPROLD(1,K) - FX
      DIFY = CPROLD(2,K) - FY
      DIFZ = CPROLD(3,K) - FZ
      CPROLD(1,K) = FX
      CPROLD(2,K) = FY
      CPROLD(3,K) = FZ
      CTOTAL = CTOTAL +   FX*FX   +   FY*FY   +   FZ*FZ
      CSMALL = CSMALL + DIFX*DIFX + DIFY*DIFY + DIFZ*DIFZ
  190 CONTINUE
C
      IF (NEGSKS.GT.0) CALL DIRCOS (RSDCOS,CPR,ISKEW,NTOUCH,3,1)
C
  205 RCN = RCNORM*RCNORM + CTOTAL
      RCE = RCENRM*RCENRM + CSMALL
      IF (RCN.GT.0.0D0) RCNORM = SQRT(RCN)
      IF (RCE.GT.0.0D0) RCENRM = SQRT(RCE)
C
      IF (IDBB.GT.0) CALL LIGHT (CPR,3,NTOUCH,IMDUMY,1,1,3,5)
      IF (ISET.LE.1) RETURN
C
C
C
  260 DO 420 J=1,NECON
      JSSA = IABS( ISECT(J) )
      IF (JSSA.EQ.10) GO TO 420
C
      XJ1 = GUSTAV(1,J)
      XJ2 = GUSTAV(2,J)
      XJ3 = GUSTAV(3,J)
      XJ4 = GUSTAV(4,J)
      AREA = XJ1 + XJ2 + XJ3 + XJ4
C
      S(1)  = C1*XJ1 + C3*( XJ2+XJ4 ) + C5*XJ3
      S(5)  = C1*XJ2 + C3*( XJ3+XJ1 ) + C5*XJ4
      S(8)  = C1*XJ3 + C3*( XJ4+XJ2 ) + C5*XJ1
      S(10) = C1*XJ4 + C3*( XJ1+XJ3 ) + C5*XJ2
C
      S(2)  = C2*( XJ1+XJ2 ) + C4*( XJ3+XJ4 )
      S(6)  = C2*( XJ2+XJ3 ) + C4*( XJ4+XJ1 )
      S(9)  = C2*( XJ3+XJ4 ) + C4*( XJ1+XJ2 )
      S(4)  = C2*( XJ4+XJ1 ) + C4*( XJ2+XJ3 )
C
      S(3)  = C3*AREA
      S(7)  = S(3)
C
      CALL CONADD (T,LMAXA,S,NCA(1,J))
  420 CONTINUE
C
C
C
      CALL COLSIN (T,CPR,LMAXA,IDBUG,NTOUCH,LNWK)
C
      IF (IDBB.GT.0) CALL LIGHT (CPR,3,NTOUCH,IMDUMY,1,1,3,6)
      RETURN
C
 2550 FORMAT(/,5X,23HUNDEFINED NORMAL VECTOR ,/,
     1         5X,12HFOR ISURF = ,I5,5X,12HSEGMENT NO.=,I5,/,
     1         5X,17HSTOPPED IN XYZNEW )
      END
      SUBROUTINE FRICT3 (ISURFP,IFSN,IFSE,IPS,ISV,
     1                   NODSF,NCA,
     1                   INODE,ISECT,
     1                   ITS,ITSP,JOIN,IDBUG,
     1                   FCOFF,XYZS,
     1                   CPR,DELTA,GUSTAV,VN,
     1                   CFOR,
     1                   NSURFP,NECON,NEALL,NTOUCH,NSNOD,NJOIN)
C
C
C***ADD:DPR***
      IMPLICIT DOUBLE PRECISION ( A-H,O-Z )
C***END:DPR***
      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 /CNTACT/ NEQI,LEADEQ,NCE2D,NCE3D
      COMMON /SURF3/ IS,KFS,KLS,JFS,JLS
      COMMON /TRGT3/ IT,KFT,KLT,JFT,JLT
      COMMON /MATCH3/ ISR,IPAIR,JTSECT
      COMMON /PRLC/ ALFA,BETA,KCON
      COMMON /CQUAD/ JSE,JSSA,AREA,NSE(4),VNJ(3)
      COMMON /PRESS/ PNAV,PTAV,RN(3),RT(3),RS(3)
      COMMON /VALUES/ C1,C2,C3,C4,C5
C
      DIMENSION ISURFP(2,NSURFP),IFSN(*),IFSE(*),IPS(*),ISV(*),