Esope source files

   1 : C FUSPR3    SOURCE    MAGN      09/07/30    21:17:04     6458           
   2 :       SUBROUTINE FUSPR3(PMORSS,NTTDDL,
   3 :      $     PMTOT,
   4 :      $     IMPR,IRET)
   5 :       IMPLICIT REAL*8 (A-H,O-Z)
   6 :       IMPLICIT INTEGER (I-N)
   7 : C***********************************************************************
   8 : C NOM         : FUSPR3
   9 : C PROJET      : Assemblage matrice élémentaire -> matrice Morse
  10 : C DESCRIPTION : Assemblage d'un ensemble de profils Morse
  11 : C               Le résultat est dans PMTOT.
  12 : C               Subroutine quasi-identique à FUSPR3. On 
  13 : C               suppose la matrice totale carrée
  14 : C               
  15 : C                   
  16 : C LANGAGE     : ESOPE
  17 : C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  18 : C               mél : gounand@semt2.smts.cea.fr
  19 : C***********************************************************************
  20 : C APPELES          : 
  21 : C APPELE PAR       : PRASEM, MAKPMT
  22 : C***********************************************************************
  23 : C ENTREES            : PMORSS
  24 : C SORTIES            : PMTOT
  25 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  26 : C***********************************************************************
  27 : C VERSION    : v1, 13/12/99, version initiale
  28 : C HISTORIQUE : v1, 13/12/99, création
  29 : C HISTORIQUE :
  30 : C HISTORIQUE :
  31 : C***********************************************************************
  32 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
  33 : C en cas de modification de ce sous-programme afin de faciliter
  34 : C la maintenance !
  35 : C***********************************************************************
  36 : *
  37 : -INC CCOPTIO
  38 : -INC SMMATRIK
  39 :       INTEGER NTT,NJA
  40 :       POINTEUR PMCOU.PMORS
  41 :       POINTEUR PMTOT.PMORS
  42 : *
  43 :       SEGMENT PMORSS
  44 :       POINTEUR LISDD(NBPM).MLENTI
  45 :       POINTEUR LISPM(NBPM).PMORS
  46 :       ENDSEGMENT
  47 : *
  48 : 
  49 : -INC SMLENTI
  50 :       POINTEUR LDDCOU.MLENTI
  51 :       POINTEUR INDEX.MLENTI
  52 :       POINTEUR IWORK.MLENTI
  53 : *
  54 :       INTEGER IMPR,IRET
  55 : *
  56 :       INTEGER NTTDU2,NTTDUA,NTTPRI
  57 :       INTEGER NNZTOT
  58 : *
  59 : * Executable statements
  60 : *
  61 :       IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans fuspr3'
  62 :       NBPM=PMORSS.LISDD(/1)
  63 :       JG=NBPM
  64 :       SEGINI INDEX
  65 :       DO I=1,NBPM
  66 :          INDEX.LECT(I)=1
  67 :       ENDDO
  68 :       JG=NTTDDL
  69 :       SEGINI IWORK
  70 :       DO IPM=1,NBPM
  71 :          LDDCOU=PMORSS.LISDD(IPM)
  72 :          PMCOU=PMORSS.LISPM(IPM)
  73 :          SEGACT LDDCOU
  74 :          SEGACT PMCOU
  75 :       ENDDO
  76 : *      WRITE(IOIMP,*) 'Partie 1'
  77 : *
  78 : * Passe 1 : Effectuons le dimensionnement de PMTOT
  79 : *
  80 :       NNZTOT=0
  81 :       DO ITTDUA=1,NTTDDL
  82 : *         WRITE(IOIMP,*) 'ITTDUA=',ITTDUA
  83 :          LDG=0
  84 : * Fin de la liste chaînée
  85 :          LAST=-1
  86 :          DO IPM=1,NBPM
  87 :             LDDCOU=PMORSS.LISDD(IPM)
  88 :             PMCOU=PMORSS.LISPM(IPM)
  89 :             IDX=INDEX.LECT(IPM)
  90 :             IF (IDX.GT.0) THEN
  91 :                ITTDCO=LDDCOU.LECT(IDX)
  92 :                IF (ITTDCO.EQ.ITTDUA) THEN
  93 : *                  WRITE(IOIMP,*) ' IPM=',IPM
  94 : *                  segprt,lddcou
  95 : *                  segprt,pmcou
  96 : * Parcourons la ligne de PMCOU
  97 :                   DO JNZCOU=PMCOU.IA(IDX),PMCOU.IA(IDX+1)-1
  98 :                      JACOL=PMCOU.JA(JNZCOU)
  99 :                      IF (IWORK.LECT(JACOL).EQ.0) THEN
 100 :                         LDG=LDG+1
 101 : *                        write(ioimp,*) 'iwork'
 102 :                         IWORK.LECT(JACOL)=LAST
 103 :                         LAST=JACOL
 104 :                      ENDIF
 105 :                   ENDDO
 106 :                   IDX=IDX+1
 107 :                   IF (IDX.LE.LDDCOU.LECT(/1)) THEN
 108 :                      INDEX.LECT(IPM)=IDX
 109 :                   ELSE
 110 :                      INDEX.LECT(IPM)=0
 111 :                   ENDIF
 112 :                ENDIF
 113 :             ENDIF
 114 :          ENDDO
 115 : *         WRITE(IOIMP,*) 'LDG=',LDG
 116 :          NNZTOT=NNZTOT+LDG
 117 : * Remise à zéro du segment de travail 
 118 :          DO ILDG=1,LDG
 119 :             IPREC=IWORK.LECT(LAST)
 120 :             IWORK.LECT(LAST)=0
 121 :             LAST=IPREC
 122 :          ENDDO
 123 :       ENDDO
 124 : *      WRITE(IOIMP,*) 'Partie 2'
 125 : *
 126 : * Passe 2 : Remplissage de PMTOT
 127 : *
 128 : * Rétablissement des index
 129 :       DO I=1,NBPM
 130 :          INDEX.LECT(I)=1
 131 :       ENDDO
 132 :       JG=NTTDDL
 133 :       NTT=NTTDDL
 134 :       NJA=NNZTOT
 135 :       SEGINI PMTOT
 136 :       JNZC=0
 137 :       PMTOT.IA(1)=1
 138 :       DO ITTDUA=1,NTTDDL
 139 :          DO IPM=1,NBPM
 140 :             LDDCOU=PMORSS.LISDD(IPM)
 141 :             PMCOU=PMORSS.LISPM(IPM)
 142 :             IDX=INDEX.LECT(IPM)
 143 :             IF (IDX.GT.0) THEN
 144 :                ITTDCO=LDDCOU.LECT(IDX)
 145 :                IF (ITTDCO.EQ.ITTDUA) THEN
 146 : * Parcourons la ligne de PMCOU
 147 :                   DO JNZA=PMCOU.IA(IDX),PMCOU.IA(IDX+1)-1
 148 :                      JACOL=PMCOU.JA(JNZA)
 149 :                      IF (IWORK.LECT(JACOL).EQ.0) THEN
 150 :                         JNZC=JNZC+1
 151 :                         PMTOT.JA(JNZC)=JACOL
 152 :                         IWORK.LECT(JACOL)=JNZC
 153 :                      ENDIF   
 154 :                   ENDDO
 155 :                   IDX=IDX+1
 156 :                   IF (IDX.LE.LDDCOU.LECT(/1)) THEN
 157 :                      INDEX.LECT(IPM)=IDX
 158 :                   ELSE
 159 :                      INDEX.LECT(IPM)=0
 160 :                   ENDIF
 161 :                ENDIF
 162 :             ENDIF
 163 :          ENDDO
 164 : * Remise à zéro du segment de travail 
 165 :          DO INZC=PMTOT.IA(ITTDUA),JNZC
 166 :             IWORK.LECT(PMTOT.JA(INZC))=0
 167 :          ENDDO
 168 :          PMTOT.IA(ITTDUA+1)=JNZC+1
 169 :       ENDDO
 170 :       SEGSUP INDEX
 171 :       SEGSUP IWORK
 172 :       SEGDES PMTOT
 173 :       DO IPM=1,NBPM
 174 :          LDDCOU=PMORSS.LISDD(IPM)
 175 :          PMCOU=PMORSS.LISPM(IPM)
 176 :          SEGDES LDDCOU
 177 :          SEGDES PMCOU
 178 :       ENDDO
 179 : *
 180 : * Normal termination
 181 : *
 182 :       IRET=0
 183 :       RETURN
 184 : *
 185 : * Format handling
 186 : *
 187 : *
 188 : * Error handling
 189 : *
 190 :  9999 CONTINUE
 191 :       IRET=1
 192 :       WRITE(IOIMP,*) 'An error was detected in subroutine fuspr3'
 193 :       RETURN
 194 : *
 195 : * End of subroutine FUSPR3
 196 : *
 197 :       END
 198 : 
 199 :  
 200 :  
 201 :  
 202 :