Télécharger la plaquette Cast3M


fr en

Télécharger infopn.eso

Retour à la liste

Numérotation des lignes : 

infopn

  1. C INFOPN    SOURCE    SP204843  24/07/17    21:15:07     11962          
  2.       SUBROUTINE INFOPN(IAREA,IRET)
  3.       IMPLICIT INTEGER(I-N)
  4.  
  5. -INC PPARAM
  6. -INC CCOPTIO
  7. -INC CCNOYAU
  8. -INC CQALITE
  9.       SAVE SNOTICE
  10.       SAVE nbnoti
  11.       SEGMENT SNOTICE
  12. *  nomcom nom du fichier de la notice
  13. *  nomcou nom de la de la notice
  14.        CHARACTER*(LOCHAI) nomcom(notidim)
  15.        CHARACTER*(LONOM)  nomcou(notidim)
  16.       ENDSEGMENT
  17.       segment STEMP
  18.       CHARACTER*(LOCHAI) nomco2(notidim)
  19.       ENDSEGMENT
  20.  
  21.       integer notidim
  22.       external long
  23.       CHARACTER*(*) IAREA
  24.       character*(lochai) rep,entr,cvarenv,dirb,nomnot,premc
  25.       character*(LONOM) nomf,nomm,noml
  26.       equivalence(cvarenv,ivarenv)
  27.       equivalence(entr   ,ientr  )
  28. *  initialistion segment notice
  29.       notidim=1000
  30.       segini snotice,stemp
  31.  
  32. *  parametres positions dans chaine lue
  33.       l=lochai
  34.       l13=LONOM+5
  35.       l15=LONOM+7
  36.       l20=LONOM+12
  37.  
  38. * recherche et ouverture des repertoires
  39.       cvarenv='CASTEM_NOTICE' //char(0)
  40.       call ooozen(ivarenv,l)
  41.       if (l.gt.1) then
  42.         rep=cvarenv(1:l)
  43.       else
  44.         rep='./:./notice/:/home/castem-public/castem/notice/'
  45.       endif
  46.       l=long(rep)
  47. **    write(6,*) 'rep: ',l,rep
  48.       idrep=1
  49.       ifrep=l
  50.       nbnoti=0
  51. *  boucle sur les repertoires indiques
  52.   20  continue
  53. *  recherche debut fin du repertoire
  54. %IF WIN32,WIN64
  55.       ind=index(rep(idrep:ifrep),';')
  56. %ELSE
  57.       ind=index(rep(idrep:ifrep),':')
  58. %ENDIF
  59. **    ind=index(rep(idrep:ifrep),';')
  60. **    if (ind.eq.0) ind=index(rep(idrep:ifrep),':')
  61.       if(ind.eq.0)  ind=ifrep-idrep+2
  62.       ifrep=ind+idrep-2
  63.       dirb=rep(idrep:ifrep)
  64.       lgb=long(dirb)
  65. *     write(6,*)' ouverture de:',dirb(1:lgb),lgb
  66. %IF WIN32,WIN64
  67.       if(dirb(lgb:lgb).ne.'/'.and.dirb(lgb:lgb).ne.'\') then
  68. %ELSE
  69.       if(dirb(lgb:lgb).ne.'/') then
  70. %ENDIF
  71. **      write(6,*) 'ajout de / '
  72.         dirb(1:lgb+1)=dirb(1:lgb)//'/'
  73.         lgb=lgb+1
  74.       endif
  75.       call fopendir(dirb(1:lgb)//char(0),iret,iajout)
  76. **    write(6,*) ' ouverture repertoire ',dirb(1:lgb)
  77.       if (iret.ne.0) then
  78.          lgbt=min(lgb,128)
  79.         moterr        =dirb(1:lgbt)
  80.         if(dirb(1:lgb).ne.'./notice/') call erreur(1133)
  81.       else
  82. *  lecture du contenu
  83. ***   write(6,*) ' infopn,iajout ',iajout
  84. *  si il y a un index valide, on l'utilise au lieu de lire tou les fichiers
  85.       if (iajout.eq.1.and.lgb.ne.2) then
  86.        open(unit=36,file=dirb(1:lgb)//'INDEX',status='OLD',
  87.      >       form='FORMATTED',iostat=ios)
  88.        if(ios.eq.0) then
  89.            read(36,fmt='(I7)',err=10,end=10) nbindex
  90.          if(nbnoti+nbindex.gt.notidim) then
  91.            notidim=notidim+1000
  92.            segadj snotice,stemp
  93.          endif
  94. **       write(6,*) ' lgb = ',lgb
  95.          read(36,36,err=10,end=10) (nomcou(in),
  96.      >         nomco2(in),in=nbnoti+1,nbnoti+nbindex)
  97.          do in=nbnoti+1,nbnoti+nbindex
  98.                nomcom(in)=dirb(1:lgb)//nomco2(in)
  99. **        write(6,*) nomcom(in)(1:100)
  100.          enddo
  101. **36     format(A (lonom), A (lochai))
  102.   36     format(A 8    , A 512   )
  103.          close(36)
  104.          do in=nbnoti+1,nbnoti+nbindex
  105.         do j=1,nbnoti
  106.          if (nomcou(j).eq.nomcou(in)) then
  107.           moterr=nomcou(in)
  108.           call erreur(-379)
  109.          endif
  110.         enddo
  111.          enddo
  112.          nbnoti=nbnoti+nbindex
  113.          goto 11
  114.        endif
  115.       endif
  116.  
  117.   10  continue
  118.       entr=char(0)
  119.       call freaddir(ientr)
  120.       if(ichar(entr(1:1)).ne.0) then
  121.        lg=long(entr)-1
  122. **     write(6,*) 'entr',lg,entr(1:50)
  123.        ind=index(entr(max(1,lg-6):lg),'.notice')
  124.        if(ind.ne.0) then
  125.         ind=ind+lg-7
  126.         nomf=entr(1:ind-1)
  127. **      write(6,*) 'fichier notice trouve:', nomf
  128. *  lecture premiere carte pour avoir le nom
  129.         close(unit=36)
  130.         nomnot=dirb(1:lgb)//entr(1:lg)
  131. **      write(6,*) 'ouverture ',nomnot
  132.         open(file=nomnot(1:lgb+lg),unit=36,iostat=ios)
  133.         if(ios.ne.0) goto 1010
  134.         premc=' '
  135.         read(36,fmt='(A20)',end=1020) premc(1:lochai)
  136.  1020   continue
  137.         if (premc(1:5).ne.'$$$$ ') goto 1010
  138.         if (premc(l15:l20).ne.'NOTICE'.and.
  139.      >      premc(l15:l20).ne.'      ') goto 1010
  140.         close(36)
  141.         nomf=premc(6:l13)
  142.         call chcass(nomf,1,nomm)
  143. **      write(6,*) ' nom de la notice ',nomf
  144.         do j=1,nbnoti
  145.          if (nomcou(j).eq.nomm) then
  146.           moterr=nomm
  147.           call erreur(-379)
  148.           iqpro=1
  149.           goto 10
  150.          endif
  151.         enddo
  152.         nbnoti=nbnoti+1
  153.         if(nbnoti.gt.notidim) then
  154.            notidim=notidim+1000
  155.            segadj snotice,stemp
  156.         endif
  157.         nomcou(nbnoti)=nomm
  158.         nomcom(nbnoti)=
  159.      >    dirb(1:lgb)//entr(1:lg-7)//'.notice'//char(0)
  160. **      write(6,*) nomcou(nbnoti),' ',nomcom(nbnoti)
  161.        endif
  162.        goto 10
  163.  1010  continue
  164. **     write(6,*) 'apres 1010 ios premc',ios,premc(1:5),premc(l15:l20)
  165.        moterr=dirb(1:lgb)//entr(1:lg)
  166.        call erreur(-380)
  167.        goto 10
  168.       endif
  169.       call fclosedir
  170. *  ecriture index si possible
  171.        if (lgb.ne.2) then
  172.        open(unit=36,file=dirb(1:lgb)//'INDEX',status='UNKNOWN',
  173.      >       form='FORMATTED',iostat=ios)
  174.        if(ios.eq.0) then
  175.           write(36,fmt='(I7)',err=37) nbnoti
  176.          do in=1,nbnoti
  177.           nomco2(in)=nomcom(in)(lgb+1:)
  178.          enddo
  179.           write(36,36,err=37) 
  180.      >      (nomcou(in),nomco2(in),in=1,nbnoti)
  181.           close(36)
  182.   37   continue
  183.        endif
  184.        endif
  185.   11  continue
  186.  
  187.       endif
  188. *  il faut sauter le separateur
  189.       idrep=ifrep+2
  190.       ifrep=l
  191.       if (idrep.lt.l) goto 20
  192.       notidim=nbnoti
  193.       segadj snotice          
  194.       segsup stemp
  195.       return
  196. *
  197. *  lecture notice
  198.       entry infoli(iarea,iret)
  199. **     write(6,*) 'iret en entree',iret
  200.        read (36,fmt='(A500)',end=1000) iarea
  201.        iret=iret+1
  202.        if(iarea(1:4).eq.'$$$$')
  203.      > read (36,fmt='(A500)',end=1000) iarea
  204.        return
  205.  1000  continue
  206.        iret=99999
  207.  
  208.       return
  209. conversion nom numero
  210.       entry infol2(noml,iret)
  211.       do i=1,nbnoti
  212.        if(nomcou(i).eq.noml) then
  213.           iret=i
  214.           return
  215.        endif
  216.       enddo
  217.       iret=0
  218.       return
  219. *  ouverture notice
  220.       entry infopo(iargu,iret)
  221.        close(unit=36)
  222.        segact snotice
  223.        if (iargu.gt.nbnoti) call erreur(5)
  224.        if (iargu.le.0) call erreur(5)
  225. **     write(6,*) ' ouverture de ',nomcom(iargu)
  226.        open(file=nomcom(iargu),unit=36,iostat=ios)
  227.        if (ios.ne.0) call erreur(5)
  228.        iret=9999
  229.        return
  230.       end
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  

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