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

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