Sources Esope | Cast3M

pramel
C PRAMEL    SOURCE    CB215821  26/08/24    21:17:55     12622          
C   CE SOUS PROGRAMME FABRIQUE LE TABLEAU DES CONNECTIONS PAR NOEUD
C   POUR ENVOYER A AMELIO
      SUBROUTINE PRAMEL(XPROJ,MELEME,NUMELG,NUMNP,NUMINI,ICLE,QUAL,
     # NCTIN,NBNN)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
-INC SMELEME
 
-INC PPARAM
-INC CCOPTIO
      SEGMENT IVOI(IRANGE)
      SEGMENT /XPROJ/(X(3,1))
      SEGMENT KON(ISUP,IRANGE)
      IF (QUAL.LT.0) RETURN
      IRANGE=NUMNP-NCTIN+1
      SEGINI IVOI
      ITENT=0
  11  CONTINUE
      ISUP=0
      DO 100 I=1,IRANGE
      IVOI(I)=0
  100 CONTINUE
      DO  2003 J=1,NBNN
      DO 1 I=1,NUMELG
      IF (NUM(J,I).EQ.0) GOTO 1
      IC=NUM(J,I)-NCTIN+1
      IF (IC.LT.1) GOTO 1
      IVOI(IC)=IVOI(IC)+1
   1  CONTINUE
 2003 CONTINUE
      IF (IIMPI.EQ.2) WRITE (IOIMP,2001) ((NUM(I,J),I=1,NBNN),J=1,
     #   NUMELG)
 2001 FORMAT(' LISTE DE L''OBJET APRES SA CREATION',/,(20I4))
      IF (IIMPI.EQ.1) WRITE(IOIMP,2002) QUAL,NUMINI,NUMNP
 2002 FORMAT(' QUAL ',G12.5,' NUMINI ',I5,' NUMNP ',I5)
      DO 3 J=1,IRANGE
      IF (IVOI(J).GT.ISUP) ISUP=IVOI(J)
   3  CONTINUE
      SEGINI KON
      IF (ICLE.EQ.2) CALL AMELIO(X(1,1),NUM(1,1),NUMELG,NUMNP, NUMINI,
     #  ICLE,IVOI(1),ISUP,QUAL,KON(1,1),NCTIN,NBNN)
      SEGSUP KON
      IF (ICLE.EQ.2) SEGSUP IVOI
      IF (ICLE.EQ.2) RETURN
      IF (ICLE.EQ.6) QUAL=QUAL/0.75
      IF (ICLE.EQ.10) GOTO 12
      ICLE=10
      GOTO 11
  12  CONTINUE
      SEGINI KON
      CALL AMELIO(X(1,1),NUM(1,1),NUMELG,NUMNP,NUMINI,ICLE,IVOI(1),ISUP,
     #  QUAL,KON(1,1),NCTIN,NBNN)
      SEGSUP KON
      ICLE=2
      ITENT=ITENT+1
      IF (ITENT.EQ.10) SEGSUP IVOI
      IF (ITENT.EQ.10) RETURN
      QUAL=QUAL*0.75
      IF (IIMPI.EQ.1) WRITE (IOIMP,1000) QUAL
 1000 FORMAT (' NOUVELLE QUALITE TENTEE ',G12.5)
      GOTO 11
      END