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

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