Télécharger la plaquette Cast3M


fr en

Télécharger sompac.eso

Retour à la liste

Numérotation des lignes : 

sompac

  1. C SOMPAC    SOURCE    MB234859  26/01/26    21:15:17     12460          
  2. C-----------------------------------------------------------------------
  3. C  Creer le squelette d'une ligne suite a sa factorisation symbolique
  4. C
  5. C Entrees :                                                 
  6. C ---------                                                 
  7. C   IPPVV : Tableau donnant le nombre de valeurs pour chaque inconnue
  8. C   IMASQ : Tableau indiquant pour un groupe de valeurs si il n'y a 
  9. C           que des 0 ou non
  10. C   NA    : Entier donnant le nombre d'inconnues de la ligne
  11. C                                                           
  12. C Sortie  :                                                 
  13. C ---------                                                 
  14. C   KIVLO : Tableau donnant la position des debuts de groupes de valeurs
  15. C   KIVPO : Tableau donnant les numeros de colonnes ou positionner les 
  16. C           valeurs
  17. C   NBPAR : Entier pour dimensionner le tableau IVPO du segment LIGN
  18. C-----------------------------------------------------------------------
  19.       SUBROUTINE SOMPAC(IPPVV,IMASQ,NA,KIVPO,KIVLO,NBPAR,izrosf)
  20. C
  21.       IMPLICIT INTEGER(I-N)
  22.       IMPLICIT REAL*8(A-H,O-Z)
  23. -INC CCHOLE
  24.       DIMENSION KIVPO(*),KIVLO(*),IPPVV(*),IMASQ(*)
  25.       LOGICAL bDECA
  26. C
  27.       ICDEB=1
  28.       ILDEB=1
  29.       NBPAR=0
  30.       IEND=IPPVV(2)
  31. C
  32.       NBPAR=NBPAR+1
  33.       KIVLO(NBPAR)=ILDEB
  34.       KIVPO(NBPAR)=ICDEB
  35.       IF (IEND.EQ.1) GOTO 13
  36. C
  37.       ILEND=MASQA(IEND)
  38.       bDECA=.true.
  39.       ib0=1
  40. C
  41.       GOTO 202
  42.  200  CONTINUE
  43.       DO IBM=ib0,ILEND
  44.         IMSQ=IMASQ(IBM)
  45.         ICDEB0=ICDEB
  46.         idec=0
  47.         IF (IMSQ.GT.0) THEN
  48. *msq
  49.           MSQB=MASQB(IMSQ)
  50.           MSQH=MASQH(IMSQ)
  51.           IMSQ=MSQH+(ibm-1)*masdim
  52.           IF (IMSQ.LT.IEND) THEN
  53. CCC         ILONV=MIN(MSQH-MSQB,MASDIM)
  54.             ILONV=MIN(IMSQ-MASQD(IMSQ)+1,MASDIM)
  55.             ILONC=MASDIM
  56.           ELSE
  57.             ILONV=IEND-ICDEB
  58.             ILONC=ILONV
  59.           ENDIF
  60.           ILDEB=ILDEB+ILONV
  61.           ICDEB=ICDEB+ILONC
  62. C
  63.           IF (bDECA) NBPAR=NBPAR+1
  64.           KIVLO(NBPAR)=ILDEB
  65.           KIVPO(NBPAR)=ICDEB
  66.         ELSE
  67.           idec=masqa(-imsq)-ibm
  68.           ICDEB=ICDEB+MASDIM*idec
  69.           KIVPO(NBPAR)=ICDEB
  70.           ILONV=0
  71.         ENDIF
  72.         ICOLFI=ICDEB0+ILONV
  73.         bDECA=(ICOLFI.NE.ICDEB)
  74.         if(idec.gt.1) then
  75.           ib0=masqa(-imsq)
  76.           goto 200
  77.         endif
  78.       ENDDO
  79. CCCC
  80. *  prise en compte des 0 en tete de troncon
  81. CCC   write(6,*) 'sompac avant kivpo kivlo',
  82. CCC  >   (kivpo(ip),kivlo(ip),ip=1,nbpar)
  83.       if (.true.) then
  84.       idec=0
  85.       do it=1,nbpar-1
  86.         iv=kivpo(it)
  87.         IMSQ=IMASQ(masqa(Iv))
  88.         if (imsq.le.0) call erreur(5)
  89.           ibdeb=imsq/(masdim+1)
  90.           ibfin=mod(imsq,masdim+1)
  91. **        write(6,*) 'sompac it iv kivlo ibdeb ibfin',it,iv,kivlo(it),
  92. **   >          ibdeb,ibfin
  93.           ibdeb=ibdeb-iv+masqd(iv)
  94.           if(ibdeb.le.0) call erreur(5)
  95. **        if (ibdeb.ge.ibfin) ibdeb=1
  96. **        if (ibdeb.ne.1) write(6,*) 'sompac it ibdeb',it,ibdeb
  97. *         ibdeb=1
  98.           if (kivpo(it)+ibdeb-1.ge.kivpo(it+1)) ibdeb=1
  99.           kivpo(it)=kivpo(it)+ibdeb-1
  100.           if(kivpo(it).ge.kivpo(it+1)) call erreur(5)
  101.           idec=idec+ibdeb-1
  102.           kivlo(it+1)=kivlo(it+1)-idec
  103.           if (kivlo(it+1).le.kivlo(it)) call erreur(5)
  104.       enddo
  105.       endif
  106. **      if (idec.ne.-1)
  107. **     >write(6,*) 'sompac apres kivpo kivlo',
  108. **     >   (kivpo(ip),kivlo(ip),ip=1,nbpar)
  109. C
  110.       GOTO 203
  111.  202  CONTINUE
  112. CCCC
  113.       IB0=1
  114.  201  CONTINUE
  115.       DO IBM=IB0,ILEND
  116.         IMSQ=IMASQ(IBM)
  117.         IF (IMSQ.GT.0) THEN
  118.           MSQB=MASQB(IMSQ)
  119.           MSQH=MASQH(IMSQ)
  120.           MLON=MSQH-MSQB+1
  121. C
  122. CCCC      IF ((MSQB.NE.1).AND.(IBM.NE.1)) THEN
  123. CCCC        KIVPO(NBPAR)=ICDEB+MSQB-1
  124. CCCC        bdeca=.true.
  125. CCCC      ENDIF
  126. C
  127.           IF (MSQB.NE.1) THEN
  128.             IF (IBM.NE.1) THEN
  129.               KIVPO(NBPAR)=ICDEB+MSQB-1
  130.               bdeca=.true.
  131.             ELSE
  132.               MSQB=1
  133.             ENDIF
  134.           ENDIF
  135. C
  136.           ICOLI=MSQB+(IBM-1)*MASDIM
  137.           ICOLF=MSQH+(IBM-1)*MASDIM
  138.           IF (ICOLF.LT.IEND) THEN
  139.             ILONV=MIN(MLON,MASDIM)
  140.             ILONC=MASDIM
  141.           ELSE
  142.             IF (KIVPO(NBPAR).EQ.IEND) GOTO 203
  143. CC          ILONV=IEND-ICOLI+1
  144.             ILONV=IEND-ICOLI
  145.             ILONC=IEND-ICDEB
  146.           ENDIF
  147.           ILDEB=ILDEB+ILONV
  148.           ICDEB=ICDEB+ILONC
  149. C
  150.           IF (bDECA) NBPAR=NBPAR+1
  151.           KIVLO(NBPAR)=ILDEB
  152.           KIVPO(NBPAR)=ICDEB
  153.           bdeca=(MSQH.NE.MASDIM)
  154.         ELSE
  155.           IB0=MASQA(-IMSQ)
  156.           IDEC=IB0-IBM
  157.           ICDEB=ICDEB+MASDIM*IDEC
  158.           IF (NBPAR.EQ.1) THEN
  159.             NBPAR=NBPAR+1
  160.             ILDEB=ILDEB+1
  161.             KIVLO(NBPAR)=ILDEB
  162.           ENDIF
  163.           KIVPO(NBPAR)=ICDEB
  164.           bdeca=.true.
  165.           IF(IDEC.GT.1) GOTO 201
  166.         ENDIF
  167.       ENDDO
  168.  203  CONTINUE
  169. *     write(6,*) 'sompac avant'
  170. *     write(6,*) (kivpo(it),it=1,nbpar)
  171. *     write(6,*) (kivlo(it),it=1,nbpar)
  172. *  verif de la taille des sauts
  173.       itsaut=0
  174.       nbparn=nbpar
  175.       do 400 it=2,nbpar-1
  176.           if (it.ge.nbparn) goto 400
  177.           nbc=kivpo(it)-kivpo(it-1)
  178.           nbv=kivlo(it)-kivlo(it-1)
  179.           isaut=nbc-nbv
  180.           if (isaut.lt.izrosf) then
  181. *         write(6,*) 'it isaut',it,isaut
  182. *  on reintroduit les 0
  183.            do 401 it1=it,nbparn
  184.             kivlo(it1)=kivlo(it1)+isaut
  185.  401       continue
  186. *  on fait sauter ce poteau
  187.            itsaut=itsaut+1
  188.            do 402 it1=it,nbparn-1
  189.             kivpo(it1)=kivpo(it1+1)
  190.             kivlo(it1)=kivlo(it1+1)
  191.  402       continue
  192.            nbparn=nbparn-1
  193.           endif
  194.  400  continue
  195.       nbpar=nbparn
  196. *     write(6,*) 'sompac apres'
  197. *     write(6,*) (kivpo(it),it=1,nbpar)
  198. *     write(6,*) (kivlo(it),it=1,nbpar)
  199. C
  200.  13   CONTINUE
  201.       NVALL=KIVLO(NBPAR)-1
  202.       NVALLG=KIVPO(NBPAR)-1
  203. C
  204. C     Reproduire ce meme decoupage pour toutes les inconnues du noeud
  205.       IPPVV(1)=1
  206.       DO 100 IL=2,NA
  207.         IPPVV(IL)=(IL-1)*NBPAR+1
  208.         DO 110 NBP=1,NBPAR
  209.           KIVLO(NBP+(IL-1)*NBPAR)=KIVLO(NBP+(IL-2)*NBPAR)+NVALL +IL-1
  210.           KIVPO(NBP+(IL-1)*NBPAR)=KIVPO(NBP+(IL-2)*NBPAR)+NVALLG+IL-1
  211.  110    CONTINUE
  212.  100  CONTINUE
  213.       NBPAR=NBPAR*NA
  214.       NBPAR=NBPAR+1
  215.       IPPVV(NA+1)=NBPAR
  216.       KIVPO(NBPAR)=KIVPO(NBPAR-1)+NA
  217.       KIVLO(NBPAR)=KIVLO(NBPAR-1)+NA
  218.       NVALL=KIVLO(NBPAR)-1
  219. C
  220. CCC   write (6,*) 'sompac na nbpar nvall ',na,nbpar,nvall
  221. CCC   write (6,*) 'nouveau ippvv',(ippvv(i),i=1,na+1)
  222. CCC   write (6,*) 'kivpo',(kivpo(i),i=1,nbpar)
  223. CCC   write (6,*) 'kivlo',(kivlo(i),i=1,nbpar)
  224. C
  225.       END
  226.  
  227.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales