Esope source files

   1 : C FUSPR4    SOURCE    MAGN      09/07/30    21:17:05     6458           
   2 :       SUBROUTINE FUSPR4(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         : FUSPR4
   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 à FUSPR4. 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 fuspr4'
  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 : *
  77 : * Détermination du max de la taille des profils Morse
  78 : *
  79 :       MAXTAI=0
  80 :       DO IPM=1,NBPM
  81 :          PMCOU=PMORSS.LISPM(IPM)
  82 :          MAXTAI=MAX(MAXTAI,PMCOU.JA(/1))
  83 :       ENDDO
  84 : * Taille initiale et taille des blocs à allouer pour ajustement
  85 :       INITAI=MAXTAI*MIN(2,NBPM)
  86 :       INCTAI=MAXTAI
  87 : *
  88 : * Remplissage de PMTOT
  89 : *
  90 :       JG=NTTDDL
  91 :       NTT=NTTDDL
  92 :       NJA=INITAI
  93 :       SEGINI PMTOT
  94 :       JNZC=0
  95 :       PMTOT.IA(1)=1
  96 :       DO ITTDUA=1,NTTDDL
  97 :          DO IPM=1,NBPM
  98 :             LDDCOU=PMORSS.LISDD(IPM)
  99 :             PMCOU=PMORSS.LISPM(IPM)
 100 :             IDX=INDEX.LECT(IPM)
 101 :             IF (IDX.GT.0) THEN
 102 :                ITTDCO=LDDCOU.LECT(IDX)
 103 :                IF (ITTDCO.EQ.ITTDUA) THEN
 104 : * Parcourons la ligne de PMCOU
 105 :                   DO JNZA=PMCOU.IA(IDX),PMCOU.IA(IDX+1)-1
 106 :                      JACOL=PMCOU.JA(JNZA)
 107 :                      IF (IWORK.LECT(JACOL).EQ.0) THEN
 108 :                         JNZC=JNZC+1
 109 :                         IF (JNZC.GT.NJA) THEN
 110 :                            NJA=NJA+INCTAI
 111 :                            SEGADJ,PMTOT
 112 :                         ENDIF
 113 :                         PMTOT.JA(JNZC)=JACOL
 114 :                         IWORK.LECT(JACOL)=JNZC
 115 :                      ENDIF   
 116 :                   ENDDO
 117 :                   IDX=IDX+1
 118 :                   IF (IDX.LE.LDDCOU.LECT(/1)) THEN
 119 :                      INDEX.LECT(IPM)=IDX
 120 :                   ELSE
 121 :                      INDEX.LECT(IPM)=0
 122 :                   ENDIF
 123 :                ENDIF
 124 :             ENDIF
 125 :          ENDDO
 126 : * Remise à zéro du segment de travail 
 127 :          DO INZC=PMTOT.IA(ITTDUA),JNZC
 128 :             IWORK.LECT(PMTOT.JA(INZC))=0
 129 :          ENDDO
 130 :          PMTOT.IA(ITTDUA+1)=JNZC+1
 131 :       ENDDO
 132 :       DO IPM=1,NBPM
 133 :          LDDCOU=PMORSS.LISDD(IPM)
 134 :          PMCOU=PMORSS.LISPM(IPM)
 135 :          SEGDES LDDCOU
 136 :          SEGDES PMCOU
 137 :       ENDDO
 138 :       SEGSUP INDEX
 139 :       SEGSUP IWORK
 140 :       NJA=JNZC
 141 :       SEGADJ,PMTOT
 142 :       SEGDES PMTOT
 143 : *
 144 : * Normal termination
 145 : *
 146 :       IRET=0
 147 :       RETURN
 148 : *
 149 : * Format handling
 150 : *
 151 : *
 152 : * Error handling
 153 : *
 154 :  9999 CONTINUE
 155 :       IRET=1
 156 :       WRITE(IOIMP,*) 'An error was detected in subroutine fuspr4'
 157 :       RETURN
 158 : *
 159 : * End of subroutine FUSPR4
 160 : *
 161 :       END
 162 : 
 163 :  
 164 :  
 165 :  
 166 :