Télécharger la plaquette Cast3M


fr en

Télécharger poscha.eso

Retour à la liste

Numérotation des lignes : 

poscha

  1. C POSCHA    SOURCE    GOUNAND   25/07/10    21:15:03     12312          
  2.       SUBROUTINE POSCHA(NAM,IPOSCH)
  3.       IMPLICIT INTEGER(I-N)
  4.  
  5. -INC PPARAM
  6. -INC CCOPTIO
  7. -INC CCNOYAU
  8. -INC CCASSIS
  9. * ithash tableau des segments de hash
  10. * ihash segments des positions dans ipchar des chaines du hash associe
  11. * lthash nombre de termes utiles dans ihash
  12.       parameter (nbhash=64)
  13.       INTEGER ITHASH(nbhash),LTHASH(nbhash),hmod
  14.       SEGMENT  IHASH(NH)
  15.       DATA ITHASH/nbhash*0/
  16.       DATA LTHASH/nbhash*0/
  17.       external long
  18.       CHARACTER*(*)NAM
  19. *  initialisation des segment de hash au premier appel
  20. *  comme ca a lieu avant l'initialisation du menage, les segments sont automatiquement proteges.
  21.       if (ithash(1).eq.0) then
  22.       do hmod=1,nbhash
  23.        nh=16
  24.        segini ihash
  25.        ithash(hmod)=ihash
  26.        lthash(hmod)=0
  27.        segdes ihash
  28.       enddo
  29.       endif
  30.       segact ipiloc
  31.       IL=LONG(NAM)
  32.       IO=IPCHAR(/1)
  33.       IA=0
  34.       DO 56 I=1,IL
  35.       IA = IA + ICHAR(NAM(I:I))
  36.    56 CONTINUE
  37. *      write(6,fmt='(''nam io lmncha ia'',a8,3i6)')nam,io,LMNCHA,ia
  38.       hmod=mod(ia,nbhash)+1
  39.       ihash=ithash(hmod)
  40.       segact ihash
  41.       LH=lthash(hmod)
  42.       do 1 ih=1,lh
  43.       ii=ihash(ih)
  44.       IF( IPHCOD(II).NE.IA) GO TO 1
  45.       ID=IPCHAR(II)
  46.       IFI=IPCHAR(II+1)
  47.       IF(IFI-ID.NE.IL) GO TO 1
  48.       IF(NAM.NE.ICHARA(ID:IFI-1)) GO TO 1
  49.       GO TO 2
  50.    1  CONTINUE
  51.   10  CONTINUE
  52.       segdes ihash
  53.       segact ipiloc*mod
  54.       LMNCHA=LMNCHA+1
  55.       M1=IPCHAR(LMNCHA)
  56.       M=M1+IL
  57. *      write(6,*) ' lmncha ' , lmncha , ' ipchar(/1))' , ipchar(/1)
  58.       IF(LMNCHA+1.GT.IPCHAR(/1) .or. M.GT.ICHARA(/1)) THEN
  59.          lmxx=xiflot(/1)
  60.          lmll=iplogi(/1)
  61.          lmmm=ichara(/1)
  62.          if(M.gt.ichara(/1)) lmmm= m+1000
  63.          lmcc= ipchar(/1)
  64.          if(LMNCHA+1.GT.lmcc) LMcc=LMNCHA+200
  65. *         write(6,*) ' lmxx,lmcc,lmmm,lmll',lmxx,lmcc,lmmm,lmll
  66.          SEGADJ IPILOC
  67. *      write(6,*) ' lmncha ' , lmncha,' m ',m
  68.        endif
  69.       IPCHAR(LMNCHA+1)=M
  70.       ICHARA(M1:M1+IL-1)=NAM
  71.       IPHCOD(LMNCHA)=IA
  72.       II=LMNCHA
  73.       if(nbesc.ne.0) THEN
  74.          SEGDES,IPILOC
  75.       else
  76.          SEGACT,IPILOC*NOMOD
  77.       endif
  78. *  remplir le tableau de hash
  79.       segact ihash*mod
  80.       lthash(hmod)=lthash(hmod)+1
  81.       if (lthash(hmod).gt.ihash(/1)) then
  82.         nh=lthash(hmod)+16
  83.         segadj ihash
  84.       endif
  85.       ihash(lthash(hmod))=ii
  86.    2  CONTINUE
  87.       IPOSCH=II
  88.       segdes ihash
  89. *      write(6,fmt='('' sortie poscha '',i8)') iposch
  90.       RETURN
  91.       END
  92.  
  93.  

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