Télécharger la plaquette Cast3M


fr en

Télécharger lextpn.eso

Retour à la liste

Numérotation des lignes : 

lextpn

  1. C LEXTPN    SOURCE    OF166741  23/11/14    21:15:03     11784          
  2.  
  3. *----------------------------------------------------------------------*
  4.       SUBROUTINE LEXTPN (iret)
  5.  
  6.       IMPLICIT INTEGER(I-N)
  7.       IMPLICIT REAL*8(A-H,O-Z)
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11.  
  12.       PARAMETER (LOCHAJ = 10 * LOCHAI)
  13.       PARAMETER (NBLIB  = 3)
  14.  
  15. *  dirloi repertoire de la loi externe
  16.       SEGMENT SDIEXT
  17.         CHARACTER*(LOCHAI) dirloi(nbdir)
  18.       ENDSEGMENT
  19.  
  20. *  ficloi fichier (bibliotheque) de la loi externe
  21. *  idrloi entier correspondant a dirloi de SDIEXT
  22.       SEGMENT SLOEXT
  23.         CHARACTER*(LOCHAI) ficloi(nbloi)
  24.         INTEGER            idrloi(nbloi)
  25.       ENDSEGMENT
  26.  
  27. *DEV*  nomloi nom de la loi externe dans la bibliotheque
  28. *DEV*  idfloi entier correspondant a ficloi de SLOEXT
  29. *DEV*  iptloi pointeur fonction de la loi externe
  30. *DEV      SEGMENT SFCEXT
  31. *DEV        CHARACTER*(LOCHAI) nomloi(nbfct)
  32. *DEV        INTEGER            idfloi(nbfct)
  33. *DEV        INTEGER            iptloi(nbfct)
  34. *DEV      ENDSEGMENT
  35.  
  36.       EXTERNAL long
  37.  
  38.       CHARACTER*(*) repl,ficl,noml
  39.  
  40.       CHARACTER*(LOCHAJ) cvarenv,rep,entr
  41.       CHARACTER*(LOCHAI) dirb,ficb,nomb
  42.       CHARACTER*(1)      sepa1(NBLIB)
  43.       CHARACTER*(2)      sepa2(NBLIB)
  44.       CHARACTER*(6)      sextl(NBLIB)
  45.  
  46.       EQUIVALENCE(cvarenv,ivarenv)
  47.       EQUIVALENCE(entr   ,ientr  )
  48.  
  49.       LOGICAL logdbg
  50.  
  51.       SAVE SDIEXT, NDIEXT, SLOEXT, NLOEXT
  52. *DEV      SAVE SFCEXT, NFCEXT
  53.       SAVE sepa1, sepa2, sextl, iextl, nextl
  54.       SAVE logdbg
  55.  
  56. * Option cachee de debogage :
  57.       cvarenv = 'CASTEM_MFRONT_DEBUG'//CHAR(0)
  58.       l = LOCHAJ
  59.       CALL OOOZEN(ivarenv,l)
  60.       logdbg = l.GE.1
  61.       if (logdbg) write(ioimp,*) 'Mode debogage actif'
  62.  
  63.       iret = 0
  64. * 0 - Initialisation des segments sdiext, sloext, sfcexT
  65.       ndiext = 0
  66.       nbdir = 256
  67.       SEGINI,sdiext
  68.  
  69.       nloext = 0
  70.       nbloi = 256
  71.       SEGINI,sloext
  72.  
  73. *DEV      nfcext = 0
  74. *DEV      nbfct = 256
  75. *DEV      SEGINI,sfcext
  76.  
  77. * 1 - Definition pour chaque OS (LINUX, WIN, MAC) :
  78. *         - du separateur de recherche
  79. *         - du(des) separateur(s) de repertoire
  80. *         - de l'extension de la bibliotheque
  81.       sextl(1) = '.so   '
  82.       sepa1(1) = ':'
  83.       sepa2(1) = '//'
  84.       sextl(2) = '.dll  '
  85.       sepa1(2) = ';'
  86.       sepa2(2) = '\/'
  87.       sextl(3) = '.dylib'
  88.       sepa1(3) = ':'
  89.       sepa2(3) = '//'
  90. %IF WIN32,WIN64
  91.       iextl = 2
  92. %ELSE
  93.       iextl = 1
  94. * Cas particulier du MACOS
  95.       cvarenv = 'CASTEM_PLATEFORME'//CHAR(0)
  96.       l = LOCHAI
  97.       CALL OOOZEN(ivarenv,l)
  98.       IF (l.GE.1) THEN
  99.         IF (cvarenv(1:l).EQ.'MAC') iextl = 3
  100.       END IF
  101. %ENDIF
  102.       nextl = LONG(sextl(iextl))
  103.       if (logdbg) then
  104.         if (iextl.eq.1) write(ioimp,*) 'OS = LINUX (default)'
  105.         if (iextl.eq.2) write(ioimp,*) 'OS = WIN32/WIN64'
  106.         if (iextl.eq.3) write(ioimp,*) 'OS = MACOS64'
  107.       end if
  108.  
  109. * 2 - Recherche des repertoires a scruter
  110.       rep   = '.'//sepa1(iextl)(1:1)//'.'//sepa2(iextl)(1:1)//'src'
  111.       lgrep = LONG(rep)
  112.       cvarenv = 'CASTEM_MFRONT_PATH'//CHAR(0)
  113.       l = LOCHAJ
  114.       CALL OOOZEN(ivarenv,l)
  115.       IF (l.GE.1) THEN
  116.         if (lgrep+1+l.gt.LOCHAJ) then
  117.           moterr = '(Warning 0) CASTEM_MFRONT_PATH too long'
  118.           call erreur(-385)
  119.           moterr = '=> Variable not used'
  120.           call erreur(-385)
  121.           iret = iret + 1
  122.         else
  123.       if (logdbg) write(ioimp,*) 'rep =>CASTEM_MFRONT_PATH<='
  124.           lgrep = lgrep + 1
  125.           rep(lgrep:lgrep) = sepa1(iextl)(1:1)
  126.           rep(lgrep+1:lgrep+l) = cvarenv(1:l)
  127.           GOTO 2
  128.         end if
  129.       END IF
  130.       cvarenv = 'LD_LIBRARY_PATH'//CHAR(0)
  131.       if (iextl.eq.3) cvarenv = 'DYLD_LIBRARY_PATH'//CHAR(0)
  132.       l = LOCHAJ
  133.       CALL OOOZEN(ivarenv,l)
  134.       IF (l.GE.1) THEN
  135.         if (lgrep+1+l.gt.LOCHAJ) then
  136.           moterr = '(Warning 0) (DY)LD_LIBRARY_PATH too long'
  137.           call erreur(-385)
  138.           moterr = '=> Variable not used'
  139.           call erreur(-385)
  140.           iret = iret + 1
  141.         else
  142.       if (logdbg) write(ioimp,*) 'rep =>(DY)LD_LIBRARY_PATH<='
  143.           lgrep = lgrep + 1
  144.           rep(lgrep:lgrep) = sepa1(iextl)(1:1)
  145.           rep(lgrep+1:lgrep+l) = cvarenv(1:l)
  146.           GOTO 2
  147.         end if
  148.       END IF
  149.       if (logdbg) write(ioimp,*) 'rep =>default<='
  150.  2    CONTINUE
  151.       lgrep = LONG(rep)
  152.       if (logdbg) write(ioimp,*) 'rep "',rep(1:lgrep),'"',lgrep
  153.  
  154.       idrep  = 1
  155. * 3 - Boucle sur les repertoires indiques
  156.  30   CONTINUE
  157.  
  158. * 3.1 - Analyse du nom du repertoire
  159.         ifrep = lgrep
  160. *  Recherche debut fin du repertoire
  161.         ind = INDEX(rep(idrep:ifrep),sepa1(iextl)(1:1))
  162.         IF (ind.NE.0) ifrep = idrep + ind - 2
  163. *  Cas particulier ou 2 separateurs se suivent
  164.         IF (ind.EQ.1) GOTO 31
  165.         lgd = LONG(rep(idrep:ifrep))
  166. *  Cas particulier ou il n'y a que des espaces entre 2 separateurs
  167.         IF (lgd.EQ.0) GOTO 31
  168.         if (lgd.gt.LOCHAI) then
  169.           moterr = '(Warning 1) External laws: '//
  170.      &             'Directory name too long'
  171.           call erreur(-385)
  172.           l = 60
  173.           moterr = ' "'//rep(idrep:idrep+l)//'[...]'//
  174.      &             rep(ifrep-l:ifrep)//'"'
  175.           call erreur(-385)
  176.           moterr = '=> Directory not used'
  177.           call erreur(-385)
  178.           iret = iret + 1
  179.           goto 31
  180.         end if
  181.         dirb = ' '
  182.         dirb = rep(idrep:ifrep)
  183. *  Cas particulier du melange de "separateurs de repertoire" (sepa2)
  184.         DO i = 1, lgd
  185.           IF (dirb(i:i).EQ.sepa2(iextl)(2:2)) THEN
  186.             dirb(i:i) = sepa2(iextl)(1:1)
  187.           END IF
  188.         END DO
  189. *  On ajoute le separateur en fin de repertoire s'il manque
  190.         IF (dirb(lgd:lgd).NE.sepa2(iextl)(1:1)) THEN
  191.           if (lgd.eq.LOCHAI) then
  192.             moterr = '(Warning 1) External laws: '//
  193.      &               'Directory name too long'
  194.             call erreur(-385)
  195.             l = 60
  196.             moterr = ' "'//dirb(1:1+l)//'[...]'//
  197.      &               dirb(lgd-l-1:lgd)//sepa2(iextl)(1:1)//'"'
  198.             call erreur(-385)
  199.             moterr = '=> Directory not used'
  200.             call erreur(-385)
  201.             iret = iret + 1
  202.             goto 31
  203.           end if
  204.           lgd = lgd + 1
  205.           dirb(lgd:lgd) = sepa2(iextl)(1:1)
  206.         END IF
  207.  
  208.         CALL LEXTDN(dirb,ios)
  209.         IF (ios.GT.0) THEN
  210.       if (logdbg) then
  211.           moterr = '(Warning 2) External laws: '//
  212.      &             'Directory already read'
  213.           call erreur(-385)
  214.           if (lgd.gt.125) then
  215.             l = 60
  216.             moterr = ' "'//dirb(1:1+l)//'[...]'//dirb(lgd-l:lgd)//'"'
  217.           else
  218.             moterr = ' "'//dirb(1:lgd)//'"'
  219.           end if
  220.           call erreur(-385)
  221.       end if
  222.           GOTO 31
  223.         END IF
  224.  
  225. * 3.2 - Ouverture du repertoire "complet"
  226.         ios = 0
  227.         CALL fopendir(dirb(1:lgd)//CHAR(0),ios,iajout)
  228.         IF (ios.NE.0) THEN
  229.       if (logdbg) then
  230.           moterr = '(Warning 3) External laws: '//
  231.      &             'Directory cannot be opened'
  232.           call erreur(-385)
  233.           if (lgd.gt.125) then
  234.             l = 60
  235.             moterr = ' "'//dirb(1:1+l)//'[...]'//dirb(lgd-l:lgd)//'"'
  236.           else
  237.             moterr = ' "'//dirb(1:lgd)//'"'
  238.           end if
  239.           call erreur(-385)
  240.           moterr = '=> Directory not used'
  241.           call erreur(-385)
  242.       end if
  243.           iret = iret + 1
  244.           GOTO 31
  245.         END IF
  246.  
  247. * On ajoute le repertoire a la liste :
  248.         ndiext = ndiext + 1
  249.         IF (ndiext.GT.nbdir) THEN
  250.           nbdir = nbdir + 256
  251.           SEGADJ,sdiext
  252.         END IF
  253.         sdiext.dirloi(ndiext) = ' '
  254.         sdiext.dirloi(ndiext)(1:lgd) = dirb(1:lgd)
  255.       if (logdbg) then
  256.         write(ioimp,*) 'Ajout du repertoire',ndiext
  257.         write(ioimp,*) ' "'//dirb(1:lgd)//'"'
  258.       end if
  259.  
  260. * 3.3 - Boucle sur le contenu du repertoire
  261.         nlopre = nloext
  262.  310    CONTINUE
  263.           entr = CHAR(0)
  264.           CALL freaddir(ientr)
  265.           IF (ICHAR(entr(1:1)).EQ.0) GOTO 320
  266. * 3.3.1 - Analyse du fichier trouve : extension attendue... 
  267.           lgf = LONG(entr) - 1
  268.           if (lgf.LE.0) goto 310
  269.           IF (lgf.LT.nextl) GOTO 310
  270. %IF WIN32,WIN64
  271.           CALL CHCASS(entr(lgf-nextl+1:lgf),0,ficb(1:nextl))
  272. %ELSE
  273.           ficb(1:nextl) = entr(lgf-nextl+1:lgf)
  274. %ENDIF
  275.           IF (ficb(1:nextl).NE.sextl(iextl)(1:nextl)) GOTO 310
  276.           if (lgf.gt.LOCHAI) then
  277.             moterr = '(Warning 4) External laws: '//
  278.      &               'Library name too long'
  279.             call erreur(-385)
  280.             if (lgf.gt.125) then
  281.               l = 60
  282.               moterr = ' "'//entr(1:1+l)//'[...]'//entr(lgf-l:lgf)//'"'
  283.             else
  284.               moterr = ' "'//entr(1:lgf)//'"'
  285.             end if
  286.             call erreur(-385)
  287.             moterr = '=> Library not used'
  288.             call erreur(-385)
  289.             iret = iret + 1
  290.             goto 310
  291.           end if
  292.           lgf = lgf - nextl
  293.           ficb = ' '
  294.           ficb(1:lgf) = entr(1:lgf)
  295.           CALL LEXTFN(ficb,ios)
  296.           IF (ios.GT.0) then
  297.       if (logdbg) then
  298.             moterr = '(Warning 5) External laws: '//
  299.      &               'Library already found'
  300.             call erreur(-385)
  301.             if (lgf.gt.120) then
  302.               l = 58
  303.               moterr = ' "'//ficb(1:1+l)//'[...]'//ficb(lgf-l:lgf)//
  304.      &                 sextl(iextl)(1:nextl)//'"'
  305.             else
  306.               moterr = ' "'//ficb(1:lgf)//sextl(iextl)(1:nextl)//'"'
  307.             end if
  308.             call erreur(-385)
  309.             moterr = 'in the following directory'
  310.             call erreur(-385)
  311.             if (lgd.gt.125) then
  312.               l = 60
  313.               moterr = ' "'//dirb(1:1+l)//'[...]'//dirb(lgd-l:lgd)//'"'
  314.             else
  315.               moterr = ' "'//dirb(1:lgd)//'"'
  316.             end if
  317.             call erreur(-385)
  318.             moterr = 'already found in the previous directory'
  319.             call erreur(-385)
  320.             i_z = sloext.idrloi(ios)
  321.             l_z = LONG(sdiext.dirloi(i_z))
  322.             if (l_z.gt.125) then
  323.               l = 60
  324.               moterr = ' "'//sdiext.dirloi(i_z)(1:1+l)//'[...]'//
  325.      &                 sdiext.dirloi(i_z)(l_z-l:l_z)//'"'
  326.             else
  327.               moterr = ' "'//sdiext.dirloi(i_z)(1:l_z)//'"'
  328.             end if
  329.             call erreur(-385)
  330.             moterr = '=> Library not added'
  331.             call erreur(-385)
  332.       end if
  333.             goto 310
  334.           END IF
  335.  
  336.           nloext = nloext + 1
  337.           IF (nloext.GT.nbloi) THEN
  338.             nbloi = nbloi + 256
  339.             SEGADJ,sloext
  340.           END IF
  341.           sloext.ficloi(nloext) = ' '
  342.           sloext.ficloi(nloext)(1:lgf) = ficb(1:lgf)
  343.           sloext.idrloi(nloext) = ndiext
  344.       if (logdbg) then
  345.         write(ioimp,*) 'Ajout bibliotheque',nloext
  346.         CALL LEXTPR(nloext)
  347.       end if
  348.  
  349. *DEV* 3.3.3 - Analyse de la bibliotheque :
  350. *DEV* 3.3.3.1 - Ouverture de la bibliotheque
  351. *DEV          CALL DLOPEN(dirb(1:lgd)//ficb(1:lgf)//sextl(iextl)(1:nextl)//CHAR(0),...)
  352. *DEV          IF (...) THEN
  353. *DEV            nloext = nloext - 1
  354. *DEV            GOTO 3120
  355. *DEV          END IF
  356. *DEV* 3.3.3.2 - Boucle sur le contenu de la bibiotheque
  357. *DEV 3110     CONTINUE
  358. *DEV*     on recupere le i-eme fonction dans la bibliotheque
  359. *DEV            nomb = ' '
  360. *DEV            lgn = LOCHAI
  361. *DEV            CALL LEXTNN(nomb,ios)
  362. *DEV            IF (ios.GT.0) then
  363. *DEV              moterr = nomb
  364. *DEV              CALL ERREUR(-302)
  365. *DEV              nloext = nloext - 1
  366. *DEV              goto 3110
  367. *DEV            END IF
  368. *DEV            nfcext = nfcext + 1
  369. *DEV            IF (nfcext.GT.nbfct) THEN
  370. *DEV              nbfct = nbfct + 256
  371. *DEV              SEGADJ,sfcext
  372. *DEV            END IF
  373. *DEV            sfcext.nomloi(nfcext) = ' '
  374. *DEV            sfcext.nomloi(nfcext)(1:lgn) = nomb(1:lgn)
  375. *DEV            sfcext.idfloi(nfcext) = nloext
  376. *DEV            sfcext.iptloi(nfcext) = 0
  377. *DEV          GOTO 3110
  378. *DEV* 3.3.3.3 - Fermeture de la bibiotheque
  379. *DEV 3120     CONTINUE
  380. *DEV* LA FERMETURE
  381.  
  382.         GOTO 310
  383. * 3.3 - Fin de la boucle sur le contenu du repertoire
  384.  
  385.  320    CONTINUE 
  386.         CALL fclosedir
  387. * Si pas de bibliotheque dans le repertoire, on le retire :
  388.         IF (nloext .LE. nlopre) then
  389.           ndiext = ndiext - 1
  390.       if (logdbg) then
  391.           moterr = '(Warning 6) External laws: '//
  392.      &             'No new librairies found in the directory'
  393.           call erreur(-385)
  394.           if (lgd.gt.125) then
  395.             l = 60
  396.             moterr = ' "'//dirb(1:1+l)//'[...]'//dirb(lgd-l:lgd)//'"'
  397.           else
  398.             moterr = ' "'//dirb(1:lgd)//'"'
  399.           end if
  400.           call erreur(-385)
  401.           moterr = '=> Directory not used'
  402.           call erreur(-385)
  403.       end if
  404.         END IF
  405.  
  406. * Il faut sauter le separateur
  407.  31     CONTINUE
  408.         idrep = ifrep + 2
  409. * Fin de la chaine rep atteinte ?
  410.         IF (idrep.GE.lgrep) GOTO 4
  411.       GOTO 30
  412. * 3 - Fin de la boucle sur les repertoires
  413.  
  414. * 4 - Fin du traitement initial des repertoires de bibliotheques de loi
  415.  4    CONTINUE
  416.       if ( (ndiext.eq.0 .and. nloext.ne.0) .or.
  417.      &     (ndiext.ne.0 .and. nloext.eq.0) ) then
  418.         moterr = '(Fatal Error) External laws: '// 
  419.      &           'ndiext & nloext not consistent'
  420.         call erreur(-385)
  421.         call erreur(5)
  422.       end if
  423.       nbdir = ndiext
  424.       SEGADJ,sdiext
  425.       SEGACT,sdiext*NOMOD
  426.       nbloi = nloext
  427.       SEGADJ,sloext
  428.       SEGACT,sloext*NOMOD
  429. *DEV      nbfct = nfcext
  430. *DEV      SEGADJ,sfcext
  431. *DEV      SEGACT,sfcext*NOMOD
  432. *DEV      CALL SAVSEG(sdiext)
  433. *DEV      CALL SAVSEG(sloext)
  434. *DEV      CALL SAVSEG(sdiext)
  435.  
  436.       if (logdbg) CALL LEXTPR(0)
  437.  
  438.       RETURN
  439.  
  440. *----------------------------------------------------------------------*
  441. *  conversion repertoire numero :
  442.       ENTRY LEXTDN(repl,iret)
  443.  
  444.       iret = 0
  445.       lgd = LONG(repl)
  446.       if (logdbg) write(ioimp,*) 'LEXTDN ='//repl(1:lgd)//'=',lgd
  447.       if (lgd.LE.0 .OR. lgd.GT.LOCHAI) RETURN
  448. **      SEGACT,sdiext*NOMOD
  449.       DO i = 1, ndiext
  450.         l_z = LONG(sdiext.dirloi(i))
  451.         IF (l_z .EQ. lgd) THEN
  452.           IF (sdiext.dirloi(i)(1:lgd).EQ.repl(1:lgd)) THEN
  453.             iret = i
  454.       if (logdbg) write(ioimp,*) 'LEXTDN = repl trouve en',iret
  455.             RETURN
  456.           END IF
  457.         END IF
  458.       END DO
  459.       if (logdbg) write(ioimp,*) 'LEXTDN = repl non trouve',iret
  460.       RETURN
  461.  
  462. *----------------------------------------------------------------------*
  463. *  conversion fichier numero :
  464.       ENTRY LEXTFN(ficl,iret)
  465.  
  466.       iret = 0
  467.       lgf = LONG(ficl)
  468.       if (logdbg) write(ioimp,*) 'LEXTFN ='//ficl(1:lgf)//'=',lgf
  469.       if (lgf.LE.0 .OR. lgf.GT.LOCHAI) RETURN
  470. **      SEGACT,sloext*NOMOD
  471.       DO i = 1, nloext
  472.         l_z = LONG(sloext.ficloi(i))
  473.         IF (l_z.EQ.lgf) THEN
  474.           IF (sloext.ficloi(i)(1:lgf).EQ.ficl(1:lgf)) THEN
  475.             iret = i
  476.       if (logdbg) write(ioimp,*) 'LEXTFN = ficl trouve en',iret
  477.             RETURN
  478.           END IF
  479.         END IF
  480.       END DO
  481.       if (logdbg) write(ioimp,*) 'LEXTFN = ficl non trouve',iret
  482.       RETURN
  483.  
  484. *----------------------------------------------------------------------*
  485. *  conversion nom numero
  486.       ENTRY LEXTNN(noml,iret)
  487.  
  488.       iret = 0
  489.       lgn = LONG(noml)
  490.       if (lgn.LE.0) RETURN
  491. *dbg      write(ioimp,*) 'LEXTNN ='//noml(1:lgn)//'='
  492. *DEV***      SEGACT,sfcext*NOMOD
  493. *DEV*      DO i = 1, nfcext
  494. *DEV*        l_z = LONG(sfcext.nomloi(i))
  495. *DEV*        IF (l_z.EQ.lgn) THEN
  496. *DEV*          IF (sfcext.nomloi(i)(1:lgn).EQ.noml(1:lgn)) THEN
  497. *DEV*            iret = i
  498. *DEV*            RETURN
  499. *DEV*          END IF
  500. *DEV*        END IF
  501. *DEV*      END DO
  502.       RETURN
  503.  
  504. *----------------------------------------------------------------------*
  505. * Recherche de la bibliotheque et ouverture de la loi demandee
  506.       ENTRY LEXTOP(ficl,noml,npar,iloi,iptr)
  507.  
  508.       iloi = 0
  509.       iptr = -3
  510.  
  511. *  Recherche "fichier" dans une chaine "(chemin_repertoire/)fichier(.ext)" :
  512.       lgf = LONG(ficl)
  513.       if      (lgf.LE.0) then
  514.         moterr = 'LEXTOP(0.1) - Null size String !'
  515.         call erreur(-385)
  516.         call erreur(21)
  517.         return
  518.       else if (lgf.gt.LOCHAI) then
  519.         moterr = 'LEXTOP(0.2) - String too long - Very strange !'
  520.         call erreur(-385)
  521.         call erreur(5)
  522.         return
  523.       end if
  524. * Recherche d'une extension si elle est fournie
  525.       DO i = 1, NBLIB
  526.         j = LONG(sextl(i))
  527.         IF (lgf.GT.j) THEN
  528. %IF WIN32,WIN64
  529.           CALL CHCASS(ficl(lgf-j+1:lgf),0,ficb(1:j))
  530. %ELSE
  531.           ficb(1:j) = ficl(lgf-j+1:lgf)
  532. %ENDIF
  533.           IF (ficb(1:j).EQ.sextl(i)(1:j)) THEN
  534.             lgf = lgf - j
  535.             GOTO 10
  536.           END IF
  537.         END IF
  538.       END DO
  539.  10   CONTINUE
  540.       ficb = ' '
  541.       ficb(1:lgf) = ficl(1:lgf)
  542. * Recherche d'un chemin (en tete) si donne
  543.       ind = 0
  544.       DO i = 1, NBLIB
  545.         j = INDEX(ficb(1:lgf),sepa2(i)(1:1),.TRUE.)
  546.         ind = MAX(ind,j)
  547.         j = INDEX(ficb(1:lgf),sepa2(i)(2:2),.TRUE.)
  548.         ind = MAX(ind,j)
  549.       END DO
  550. * Nom de la bibliotheque trouve
  551.       ficb = ' '
  552.       ficb = ficl(ind+1:lgf)
  553.       lgf  = LONG(ficb)
  554.       if (lgf.LE.0) then
  555.         moterr = 'LEXTOP(1.2) - Null size String !'
  556.         call erreur(-385)
  557.         call erreur(21)
  558.         return
  559.       end if
  560.       ideb = 1
  561.       ifin = lgf
  562.       CALL LEXTFN(ficb(ideb:ifin),ios)
  563.       IF (ios.LE.0) THEN
  564. %IF WIN32,WIN64
  565.         CALL CHCASS(ficb(1:3),0,dirb(1:3))
  566. %ELSE
  567.         dirb(1:3) = ficb(1:3)
  568. %ENDIF
  569.         IF (dirb(1:3).EQ.'lib') THEN
  570.           ideb = 1+3
  571.           CALL LEXTFN(ficb(ideb:ifin),ios)
  572.         ELSE
  573.           if (lgf+3.gt.LOCHAI) then
  574.             moterr = 'External law (6): Library name too long'
  575.             call erreur(-385)
  576.             if (lgf.gt.122) then
  577.               l = 58
  578.               moterr = ' "lib'//ficb(1:1+l)//'[...]'//
  579.      &                 ficb(lgf-l:lgf)//'"'
  580.             else
  581.               moterr = ' "lib'//ficb(1:lgf)//'"'
  582.             end if
  583.             call erreur(-385)
  584.             call erreur(21)
  585.             return
  586.           end if
  587.           CALL LEXTFN('lib'//ficb(ideb:ifin),ios)
  588.         END IF
  589.       END IF
  590.       IF (ios.LE.0) THEN
  591.         moterr = 'External law: Library "(lib)'//ficb(ideb:ifin)//
  592.      &           '" not found!'
  593.         call erreur(-385)
  594.         call erreur(21)
  595.         RETURN
  596.       ENDIF
  597. * Librairie trouvee
  598.       ficl = sloext.ficloi(ios)(1:lgf)
  599.       iloi = ios
  600.       if (logdbg) call lextpr(ios)
  601.  
  602.       lgn  = LONG(noml)
  603.       if      (lgn.LE.0) then
  604.         moterr = 'LEXTOP(3.1) - Null size String !'
  605.         call erreur(-385)
  606.         call erreur(5)
  607.         return
  608.       else if (lgn.gt.LOCHAI) then
  609.         moterr = 'LEXTOP(3.2) - String too long - Very strange !'
  610.         call erreur(-385)
  611.         call erreur(5)
  612.         return
  613.       end if
  614.  
  615. **      SEGACT,sloext*NOMOD
  616.       idi  = sloext.idrloi(ios)
  617.       lgd  = LONG(sdiext.dirloi(idi))
  618.       lgf  = LONG(sloext.ficloi(ios))
  619.       lge  = lgd + lgf + nextl
  620.       entr = ' '
  621.       entr(1:lgd)         = sdiext.dirloi(idi)(1:lgd)
  622.       entr(lgd+1:lgd+lgf) = sloext.ficloi(ios)(1:lgf)
  623.       entr(lgd+lgf+1:lge) = sextl(iextl)(1:nextl)
  624.       ip     = npar
  625.       lmeptr = 0
  626.       CALL PTRLOI(entr(1:lge)//CHAR(0),lge, noml(1:lgn)//CHAR(0),lgn,
  627.      &            ip, lmeptr)
  628.       IF (lmeptr.LE.0) THEN
  629.         MOTERR = ' '
  630.         i_z = MIN(32,lgn)
  631.         MOTERR(1 :i_z) = noml(1:i_z)
  632.         i_z = MIN(32,lgf)
  633.         MOTERR(32+1:32+i_z) = entr(lgd+1:lgd+i_z)
  634.         i_z = MIN(64,lgd)
  635.         MOTERR(64+1:64+i_z) = entr(1:i_z)
  636.         CALL ERREUR(1113)
  637.       END IF
  638.       iptr = lmeptr
  639.  
  640.       RETURN
  641.  
  642. *----------------------------------------------------------------------*
  643. *  Affichage d'une ou de toutes les lois trouvees :
  644.       ENTRY LEXTPR(iret)
  645.  
  646. * iret = 0 : affichage d'un recapitulatif complet
  647. * iret > 0 : affichage de la bibliotheque de numero iret
  648.       IF (ndiext.LE.0) RETURN
  649.       IF (nloext.LE.0) RETURN
  650.       IF (iret.LT.0 .OR. iret.GT.nloext) RETURN
  651.  
  652. * Travail sur les formats d'affichage
  653.       entr ='(A,I ) (A,I ,A) (A,I ) (A,I ,A)'
  654. **           1   56 8   1  1 1   22 2   2  3
  655. **                      2  5 7   12 4   8  1
  656.       id = INT(LOG10(REAL(ndiext))) + 1
  657.       if (id.lt.1 .or. id.gt.6) then
  658.         moterr = '(Error) Too many directories'
  659.         call erreur(-385)
  660.         call erreur(5)
  661.         return
  662.       end if
  663.       il = INT(LOG10(REAL(nloext))) + 1
  664.       if (il.lt.1 .or. il.gt.6) then
  665.         moterr = '(Error) Too many libairies'
  666.         call erreur(-385)
  667.         call erreur(5)
  668.         return
  669.       end if
  670.       write(entr( 5: 5),FMT='(I1)') id
  671.       write(entr(12:12),FMT='(I1)') id
  672.       write(entr(21:21),FMT='(I1)') il
  673.       write(entr(28:28),FMT='(I1)') il
  674.  
  675. * Bornes de la boucle d'affichage des bibliotheques
  676.       IF (iret.EQ.0) THEN
  677.         ideb = 1
  678.         ifin = nloext
  679.       ELSE
  680.         ideb = iret
  681.         ifin = iret
  682.       END IF
  683.  
  684. * Affichage de l'entete selon la demande :
  685.       IF (iret.EQ.0) THEN
  686.         write(ioimp,*)
  687.         write(ioimp,*) 'External Laws Summary:'
  688.         write(ioimp,*) '----------------------'
  689.       if (logdbg) then
  690.         write(ioimp,fmt=entr(1:6))
  691.      &              ' Number of directories found: ',ndiext
  692.         write(ioimp,*) '----------------------'
  693.         DO i = 1, ndiext
  694.           dirb = sdiext.dirloi(i)
  695.           lgd  = LONG(dirb)
  696.           write(ioimp,fmt=entr(8:15))
  697.      &                ' Dir.#',i,' "'//dirb(1:lgd)//'"'
  698.         END DO
  699.         write(ioimp,*) '----------------------'
  700.       end if
  701.         write(ioimp,fmt=entr(17:22))
  702.      &              ' Number of libraries ('//sextl(iextl)(1:nextl)//
  703.      &              ') found: ',nloext
  704.         write(ioimp,*) '----------------------'
  705.       ELSE
  706.       END IF
  707.  
  708.       if (logdbg) then
  709.       DO i = ideb,ifin
  710.         idi = sloext.idrloi(i)
  711.         lgd = LONG(sdiext.dirloi(idi))
  712.         lgf = LONG(sloext.ficloi(i))
  713.  
  714.         write(ioimp,FMT=entr(17:22)) ' External Law Library #',i
  715.         write(ioimp,*) ' - Name "'//sloext.ficloi(i)(1:lgf)//'"'
  716.         write(ioimp,*) ' - Dir. "'//sdiext.dirloi(idi)(1:lgd)//'"'
  717.       END DO
  718.       end if
  719.  
  720.       IF (iret.EQ.0) THEN
  721.         write(ioimp,*)
  722.         write(ioimp,*) '***********************************************'
  723.      &               //'************************'
  724.         write(ioimp,*)
  725.       ELSE
  726.       END IF
  727.       write(ioimp,*)
  728.  
  729.       RETURN
  730.  
  731. *----------------------------------------------------------------------*
  732.       END
  733.  
  734.  
  735.  

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