Esope source files

   1 : C FUSPR2    SOURCE    MAGN      09/07/30    21:17:03     6458           
   2 :       SUBROUTINE FUSPR2(PM1,PM2,NTTPRI,
   3 :      $     PMTOT,
   4 :      $     IMPR,IRET)
   5 :       IMPLICIT REAL*8 (A-H,O-Z)
   6 :       IMPLICIT INTEGER (I-N)
   7 : C***********************************************************************
   8 : C NOM         : FUSPR2
   9 : C PROJET      : Assemblage matrice élémentaire -> matrice Morse
  10 : C DESCRIPTION : Profil Morse (non ordonné) de A + profil Morse (non
  11 : C               ordonné) de B => profil Morse (non ordonné) de (A + B) 
  12 : C
  13 : C               On effectue un ET sur les profils Morses non
  14 : C               ordonnés PM1 et PM2.
  15 : C               Le résultat est dans PMTOT.
  16 : C               Subroutine quasi-identique à FUSPRM. FUSPRM supposait
  17 : C               des profils morse de matrices carrées. Pas FUSPR2.
  18 : C               En outre, on fait tout en esope et pas en fortran
  19 : C               (pas robuste)
  20 : C               
  21 : C                   
  22 : C LANGAGE     : ESOPE
  23 : C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  24 : C               mél : gounand@semt2.smts.cea.fr
  25 : C***********************************************************************
  26 : C APPELES          : 
  27 : C APPELE PAR       : PRASEM, MAKPMT
  28 : C***********************************************************************
  29 : C ENTREES            : PM1, PM2
  30 : C SORTIES            : PMTOT
  31 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  32 : C***********************************************************************
  33 : C VERSION    : v1, 13/12/99, version initiale
  34 : C HISTORIQUE : v1, 13/12/99, création
  35 : C HISTORIQUE :
  36 : C HISTORIQUE :
  37 : C***********************************************************************
  38 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
  39 : C en cas de modification de ce sous-programme afin de faciliter
  40 : C la maintenance !
  41 : C***********************************************************************
  42 : *
  43 : -INC CCOPTIO
  44 : -INC SMMATRIK
  45 :       INTEGER NTT,NJA
  46 :       POINTEUR PM1.PMORS
  47 :       POINTEUR PM2.PMORS
  48 :       POINTEUR PMTOT.PMORS
  49 : -INC SMLENTI
  50 :       INTEGER JG
  51 :       POINTEUR IWORK.MLENTI
  52 : *
  53 :       INTEGER IMPR,IRET
  54 : *
  55 :       INTEGER NTTDU2,NTTDUA,NTTPRI
  56 :       INTEGER NNZTOT
  57 : *
  58 : * Executable statements
  59 : *
  60 :       IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans fuspr2'
  61 :       SEGACT PM1
  62 :       NTTDUA=PM1.IA(/1)-1
  63 :       SEGACT PM2
  64 :       NTTDU2=PM2.IA(/1)-1
  65 :       IF (NTTDUA.NE.NTTDU2) THEN
  66 :          WRITE(IOIMP,*) 'Profils morse à fusionner incompatibles...'
  67 :          GOTO 9999
  68 :       ENDIF
  69 : *
  70 : * Passe 1 : Effectuons le dimensionnement de PMTOT
  71 : *
  72 :       JG=NTTPRI
  73 :       SEGINI,IWORK
  74 :       NNZTOT=0
  75 :       DO ITTDUA=1,NTTDUA
  76 :          LDG=0
  77 : * Fin de la liste chaînée
  78 :          LAST=-1
  79 : * Parcourons la ligne de A
  80 :          DO JNZA=PM1.IA(ITTDUA),PM1.IA(ITTDUA+1)-1
  81 :             JACOL=PM1.JA(JNZA)
  82 :             IF (IWORK.LECT(JACOL).EQ.0) THEN
  83 :                LDG=LDG+1
  84 :                IWORK.LECT(JACOL)=LAST
  85 :                LAST=JACOL
  86 :             ENDIF
  87 :          ENDDO
  88 : * Parcourons la ligne de B
  89 :          DO JNZB=PM2.IA(ITTDUA),PM2.IA(ITTDUA+1)-1
  90 :             JBCOL=PM2.JA(JNZB)
  91 :             IF (IWORK.LECT(JBCOL).EQ.0) THEN
  92 :                LDG=LDG+1
  93 :                IWORK.LECT(JBCOL)=LAST
  94 :                LAST=JBCOL
  95 :             ENDIF
  96 :          ENDDO
  97 :          NNZTOT=NNZTOT+LDG
  98 : * Remise à zéro du segment de travail 
  99 :          DO ILDG=1,LDG
 100 :             IPREC=IWORK.LECT(LAST)
 101 :             IWORK.LECT(LAST)=0
 102 :             LAST=IPREC
 103 :          ENDDO
 104 :       ENDDO
 105 : *
 106 : * Passe 2 : Remplissage de PMTOT
 107 : *
 108 :       NTT=NTTDUA
 109 :       NJA=NNZTOT
 110 :       SEGINI PMTOT
 111 :       JNZC=0
 112 :       PMTOT.IA(1)=1
 113 :       DO ITTDUA=1,NTTDUA
 114 : * Parcourons la ligne de A
 115 :          DO JNZA=PM1.IA(ITTDUA),PM1.IA(ITTDUA+1)-1
 116 :             JACOL=PM1.JA(JNZA)
 117 :             IF (IWORK.LECT(JACOL).EQ.0) THEN
 118 :                JNZC=JNZC+1
 119 :                PMTOT.JA(JNZC)=JACOL
 120 :                IWORK.LECT(JACOL)=JNZC
 121 :             ENDIF   
 122 :          ENDDO
 123 : * Parcourons la ligne de B
 124 :          DO JNZB=PM2.IA(ITTDUA),PM2.IA(ITTDUA+1)-1
 125 :             JBCOL=PM2.JA(JNZB)
 126 :             IF (IWORK.LECT(JBCOL).EQ.0) THEN
 127 :                JNZC=JNZC+1
 128 :                PMTOT.JA(JNZC)=JBCOL
 129 :                IWORK.LECT(JBCOL)=JNZC
 130 :             ENDIF
 131 :          ENDDO
 132 : * Remise à zéro du segment de travail 
 133 :          DO INZC=PMTOT.IA(ITTDUA),JNZC
 134 :             IWORK.LECT(PMTOT.JA(INZC))=0
 135 :          ENDDO
 136 :          PMTOT.IA(ITTDUA+1)=JNZC+1
 137 :       ENDDO
 138 :       SEGSUP IWORK
 139 :       SEGDES PMTOT
 140 :       SEGDES PM2
 141 :       SEGDES PM1
 142 : *
 143 : * Normal termination
 144 : *
 145 :       IRET=0
 146 :       RETURN
 147 : *
 148 : * Format handling
 149 : *
 150 : *
 151 : * Error handling
 152 : *
 153 :  9999 CONTINUE
 154 :       IRET=1
 155 :       WRITE(IOIMP,*) 'An error was detected in subroutine fuspr2'
 156 :       RETURN
 157 : *
 158 : * End of subroutine FUSPR2
 159 : *
 160 :       END
 161 : 
 162 :  
 163 :  
 164 :  
 165 :