! !----------------------------------------------------------------------- ! !Purpose: ! Generate a Postscript representation of the surfacic geometry. ! !Copyright: ! Copyright (C) 2001 Ecole Polytechnique de Montreal. ! This library is free software; you can redistribute it and/or ! modify it under the terms of the GNU Lesser General Public ! License as published by the Free Software Foundation; either ! version 2.1 of the License, or (at your option) any later version. ! !Author(s): ! G. Civario (CS-SI) ! !Comments: ! Ce fichier est derive de la bibliotheque PSPLOT de Kevin E. Kohler, ! developpee au Nova Southeastern University Oceanographic Center en Floride. ! Le code inital a simplement ete encapsule dans un module, pour eviter les ! eventuels conflics de noms, et ampute de toutes les routines non utilisees ! ici. ! Quelques modifications mineures ont par ailleurs ete faites, pour permettre ! la production d'un fichier eps, et assurer le centrage de la figure. ! !----------------------------------------------------------------------- ! module derivedPSPLOT !!implicit none logical,save :: g_psp_isEpsFile !true if file is eps real ,save :: g_psp_bBoxXmin,g_psp_bBoxYmin,g_psp_bBoxXmax,g_psp_bBoxYmax contains subroutine line(fx,fy,tx,ty) implicit none double precision,intent(in) :: fx,fy,tx,ty call PLOT(real(fx),real(fy),3) call PLOT(real(tx),real(ty),2) end subroutine line subroutine arc(xc,yc,rad,ang1,ang2) double precision,intent(in) :: xc,yc,rad,ang1,ang2 double precision conver,radi,xci,yci character*132 cmdstr common/plt1/cmdstr common/cnvcom/conver radi=rad*conver xci=xc*conver yci=yc*conver cmdstr=' ' write(cmdstr,'(1p,e14.6,'' '',e14.6,'' '',e14.6,'' '',2e14.6,'' arcit'')')& & xci,yci,radi,ang1,ang2 call filler end subroutine arc subroutine filler !nfild is the last position filled in the compressed aaa buffer array !work is a work array used to load array aaa character*132 cmdstr,cmdc(132)*1 common/plt1/cmdstr common/outcom/iunit logical ispace !equivalence (cmdstr,cmdc(1)) ibslash=92 lc=0 lcc=lenstr(cmdstr,132) ispace=.false. !itot is running total of left/right parentheses in text string !if itot=0 then we are not in text mode, i.e. left=right itot=0 icclst=-999 do l=1,lcc icc=ichar(cmdstr(l:l)) if(icc.eq.32.and.ispace.and.itot.eq.0) cycle !Don't place 2 or more ! spaces together if ! not in text mode if(icc.ge.32.and.icc.le.127) then lc=lc+1 cmdc(lc)=cmdstr(l:l) endif if(icc.eq.32) then ispace=.true. else ispace=.false. endif if(icc.eq.40.and.icclst.ne.ibslash)itot=itot+1 if(icc.eq.41.and.icclst.ne.ibslash)itot=itot-1 icclst=icc end do !Write cmdstr to output file write(iunit,'(132a1)')(cmdc(ii),ii=1,lc) return end subroutine filler subroutine psinit(fileNbr,portrait) !initializes plot for hp plotter integer fileNbr double precision conver logical first,portrait,prtrt character*132 cmdstr,curfnt character*80 fileout character tim*10,dat*8,zn*5 integer*4 val(8) character*1 timer(8),dater(9) equivalence(timer(1),tim),(dater(1),dat) common/conre1/ioffp,spval common/plt1/cmdstr common/cnvcom/conver common/plt2/fac common/io/fileout,inew common/kkplot/szrat common/chpcom/ientry,prtrt common/fntcom/curfnt,ifntsz,nfont common/outcom/iunit common/pagcom/npage !data ioffp,spval/0,0.0/ ioffp=0 spval=0.0 !Set conversion factor (conver=72. for inches, conver=72./25.4 for mm, etc.) !conver conver=72.d0 npage=1 prtrt=portrait first=.true. pi=4.*abs(atan(1.)) !Use default name unless newdev has already been called (inew=999). if(inew.eq.0) then fileout='psplot.ps' inew=1 else if(inew.eq.999)then inew=1 endif !output file opened iunit=fileNbr cmdstr='%!PS-Adobe-3.0' if (g_psp_isEpsFile) cmdstr='%!PS-Adobe-3.0 EPSF-3.0' call filler cmdstr= '%%Title: '//fileout(1:lenstr(fileout,80)) call filler call date_and_time(dat,tim,zn,val) if(timer(1).eq.' ')timer(1)='0' if(dater(1).eq.' ')dater(1)='0' cmdstr= '%%CreationDate: '//DAT//' '//TIM call filler cmdstr= '%%Creator: PSPLOT PostScript Plotting Package' call filler if (g_psp_isEpsFile) then cmdstr='%%BoundingBox: 0 0 595 842' call filler end if cmdstr= '%%Pages: (atend)' call filler cmdstr='%%EndComments' call filler cmdstr='%Library Creator: Kevin E. Kohler ' call filler cmdstr='%%BeginProlog' call filler cmdstr='/inch {72 mul} bind def' call filler cmdstr='/Ah {moveto lineto lineto stroke} def' call filler cmdstr='/Ar {moveto 2 copy lineto 4 -2 roll' call filler cmdstr=' moveto lineto lineto stroke } def' call filler cmdstr='/arcit {S /A2 exch def /A1 exch def /Rad exch def' call filler cmdstr=' /Yc exch def /Xc exch def' call filler cmdstr=' Xc Rad A1 cos mul add Yc Rad A1 sin mul add' call filler cmdstr=' moveto newpath' call filler cmdstr=' Xc Yc Rad A1 A2 arc stroke} def' call filler cmdstr='/C {/Rad exch def /Yc exch def /Xc exch def' call filler cmdstr=' Xc Yc Rad 0 360 arc closepath' !closepath needed to !avoid notch call filler !with fat line width cmdstr=' } def' call filler cmdstr='/c0sf {closepath 0 setgray fill} def' call filler cmdstr='/cf {closepath fill} def' call filler cmdstr='/Cs {closepath stroke} def' call filler cmdstr='/Cln {newpath 3 1 roll' call filler cmdstr=' moveto {lineto} repeat clip newpath' call filler cmdstr=' } def' call filler cmdstr='/Cs {closepath stroke} def' call filler cmdstr='/Fb {newpath moveto ' call filler cmdstr=' Dx 0 rlineto 0 Dy rlineto Dx neg 0 rlineto closepath' call filler cmdstr=' fill } def' call filler cmdstr='/Fbn { newpath 3 1 roll moveto {lineto} repeat' call filler cmdstr=' closepath fill } def' call filler cmdstr='/Fbnc { newpath 3 1 roll moveto' call filler cmdstr=' {lineto} repeat closepath fill } def' call filler cmdstr='/L /lineto load def' call filler cmdstr='/Lend {/Strlen exch stringwidth pop def} def' call filler !Define stringlength slightly increased for integrand placement cmdstr='/Lendi {/Strlen exch stringwidth pop 1.5 mul def} def' call filler !Define stringlength slightly increased for summation placement cmdstr='/Lends {/Strlen exch stringwidth pop 1.1 mul def} def' call filler cmdstr='/Lenssd {/Strlenss exch stringwidth pop 3 mul 4 div def} def' call filler cmdstr='/LSM {2 copy lineto stroke moveto} def' call filler cmdstr='/lsm {Xp Yp lineto stroke mover} def' call filler cmdstr='/M /moveto load def' call filler cmdstr='/mover {Xp Yp moveto} def' call filler cmdstr='/Np {newpath} def' call filler cmdstr='/S /stroke load def' call filler cmdstr='/Sc {setrgbcolor} def' call filler cmdstr='/Sg {setgray} def' call filler cmdstr='/Setf {Curfnt exch scalefont setfont} def' call filler cmdstr='/SM {stroke moveto} def' call filler cmdstr='/sm {stroke mover} def' call filler write(cmdstr,'(''/Slw {'',f7.4,'' mul setlinewidth} def'')') conver call filler cmdstr='/Slw0 {.24 setlinewidth} bind def' !Minimum line width 300 dpi call filler !Add this for fun cmdstr= '%Line Breaking Procedure' call filler cmdstr='/TurnLineFL' call filler cmdstr=' { /T exch def /spacewidth space stringwidth pop def' call filler cmdstr=' /currentw 0 def /wordspace_count 0 def' call filler cmdstr=' /restart 0 def /remainder T def' call filler cmdstr=' {remainder space search' call filler cmdstr=' {/nextword exch def pop' call filler cmdstr=' /remainder exch def' call filler cmdstr=' /nextwordwidth nextword stringwidth pop def' call filler cmdstr=' currentw nextwordwidth add lw gt' call filler cmdstr=' {T restart wordspace_count restart sub' call filler cmdstr=' getinterval showline' call filler cmdstr=' /restart wordspace_count def' call filler cmdstr=' /currentw nextwordwidth spacewidth add def' call filler cmdstr=' }' call filler cmdstr=' {/currentw currentw nextwordwidth add' call filler cmdstr=' spacewidth add def' call filler cmdstr=' } ' call filler cmdstr=' ifelse' call filler cmdstr=' /wordspace_count wordspace_count' call filler cmdstr=' nextword length add 1 add def' call filler cmdstr=' }' call filler cmdstr=' {pop exit}' call filler cmdstr=' ifelse' call filler cmdstr=' } loop' call filler cmdstr=' /lrem remainder stringwidth pop def' call filler cmdstr=' currentw lrem add lw gt' call filler cmdstr=' {T restart wordspace_count restart sub ' call filler cmdstr=' getinterval showline remainder showline}' call filler cmdstr=' {/lastchar T length def' call filler cmdstr=' T restart lastchar restart sub getinterval ' call filler cmdstr=' lm y moveto show}' call filler cmdstr=' ifelse' call filler cmdstr=' } def' call filler cmdstr=' /parms {/y exch def /lm exch def /rm exch def' call filler cmdstr=' /leading exch def /pointsize exch def' call filler cmdstr=' /lw rm lm sub def' call filler cmdstr=' findfont pointsize scalefont setfont ' call filler cmdstr=' /showline {lm y moveto show' call filler cmdstr=' /y y leading sub def} def' call filler cmdstr=' lm y moveto } def' call filler cmdstr='/Xposd {/Xpos exch def} def' call filler cmdstr='/Xposjd {/Xpos exch Xpos exch Strlen mul sub def} def' call filler cmdstr='/xydef {/Xp Xpos def /Yp Ypos def} def' call filler cmdstr='%/Xypd {/Yp exch def /Xp exch def} def' call filler cmdstr='/Xypos0d {/Xpos0 Xpres def /Ypos0 Ypres def} def' call filler cmdstr='/Xyprset {dup /Xpres exch cos Strlen mul Xpos add def' call filler cmdstr=' /Ypres exch sin Strlen mul Ypos add def} def' call filler cmdstr='/Xyprset0 {dup /Xpres exch cos Strlen mul Xpos0 add def' call filler cmdstr=' /Ypres exch sin Strlen mul Ypos0 add def} def' call filler cmdstr='/Yposd {/Ypos exch def} def' call filler cmdstr='/Yposjd {/Ypos exch Ypos exch Strlen mul sub def} def' call filler cmdstr='/space ( ) def' call filler cmdstr='%%EndProlog' call filler cmdstr='%%Page: 1 1' call filler !Szrat is the ratio of width to height of characters. Determined empirically. szrat=.6 !Set initial font to helvetica, 12 point ifntsz=12 call setfnt(20) !Set factor to 1 for initialization, reset later if chopit called fac=1. call factor(fac) fact=min(595./(g_psp_bBoxXmax-g_psp_bBoxXmin), & 842./(g_psp_bBoxYmax-g_psp_bBoxYmin))/72. write(cmdstr,'(2f8.3,a)') fact,fact,' scale' call filler write(cmdstr,'(1p,2e14.6,a)') -g_psp_bBoxXmin*72., & -g_psp_bBoxYmin*72., & ' translate' call filler !Set initial lineweight to 0 call setlw(0.) !Set initial grayscale to 0 call setgry(0.) !Set initial rgb colors to black(0) call setcolr(0.,0.,0.) xsh=0. ysh=0. call plot(xsh,ysh,-3) end subroutine psinit subroutine setcolr(red,green,blue) !this routines sets the current color !red, green blue are the saturation ratios between 0 and 1 character*132 cmdstr common/plt1/cmdstr common/colrcom/cred,cgreen,cblue,cgry r=red r=amin1(1.,r) r=amax1(0.,r) g=green g=amin1(1.,g) g=amax1(0.,g) b=blue b=amin1(1.,b) b=amax1(0.,b) cmdstr=' ' write(cmdstr,'(3F7.3,'' Sc'')')r,g,b call filler cred=r cgreen=g cblue=b end subroutine setcolr subroutine setfnt(numfnt) !This routines changes the typeface of the current font character*132 cmdstr,scrc character*132 curfnt common/fntcom/curfnt,ifntsz,nfont character*40 fntnam(35) common/plt1/cmdstr data fntnam/'AvantGarde-Book','AvantGarde-BookOblique',& &'AvantGarde-Demi','AvantGarde-DemiOblique','Bookman-Demi',& &'Bookman-DemiItalic','Bookman-Light','Bookman-LightItalic',& &'Courier-Bold','Courier-BoldOblique','Courier-Oblique', 'Courier',& &'Helvetica-Bold','Helvetica-BoldOblique', 'Helvetica-Narrow-Bold',& &'Helvetica-Narrow-BoldOblique', 'Helvetica-Narrow-Oblique',& &'Helvetica-Narrow', 'Helvetica-Oblique','Helvetica',& &'NewCenturySchlbk-Bold','NewCenturySchlbk-BoldItalic',& &'NewCenturySchlbk-Italic','NewCenturySchlbk-Roman',& &'Palatino-Bold','Palatino-BoldItalic','Palatino-Italic',& &'Palatino-Roman','Symbol','Times-Bold','Times-BoldItalic',& &'Times-Italic','Times-Roman','ZapfChancery-MediumItalic',& &'ZapfDingbats'/ nfont=numfnt if(numfnt.lt.1.or.numfnt.gt.35) then write(6,*) 'Invalid font number encountered in **setfnt**' write(6,*) 'Using Helvetica default' nfont=20 endif scrc=fntnam(nfont) cmdstr='/Curfnt /'//scrc(1:lenstr(scrc,132))//' findfont def' call filler write(cmdstr,'(i3,'' Setf'')')ifntsz call filler end subroutine setfnt subroutine setgry(gry) !This routines sets the current gray level !Gry is set to be between 0 and 1 character*132 cmdstr common/plt1/cmdstr common/colrcom/cred,cgreen,cblue,cgry g=gry g=amin1(1.,g) g=amax1(0.,g) cmdstr=' ' write(cmdstr,'(F7.3,'' Sg'')')g call filler cgry=g end subroutine setgry subroutine setlw(rlwi) !this routines sets the current linewidth !rlwi is linewidth in inches character*132 cmdstr common/plt1/cmdstr common/lcom/curwid if(abs(rlwi).lt.1.e-5) then !0 cmdstr='Slw0' else cmdstr=' ' write(cmdstr,'(F7.3,'' Slw'')')rlwi endif call filler curwid=rlwi end subroutine setlw subroutine factor(facc) common/plt2/fac character*132 cmdstr common/plt1/cmdstr !Unscale previous scaling recipx=1./fac recipy=1./fac write(cmdstr,'(2f7.3,a)')recipx,recipy,' scale' call filler fac=facc write(cmdstr(:14),'(2f7.3)')fac,fac call filler end subroutine factor subroutine plot(xcall,ycall,ip) double precision conver character*132 cmdstr character*80 scr common/plt1/cmdstr common/cnvcom/conver common/outcom/iunit common/pagcom/npage ipp=iabs(ip) if(ip.eq.999) then !Terminate plot session. cmdstr='stroke showpage' call filler cmdstr='%%Trailer' call filler write(scr,'(i6)')npage call blkstp(scr,80,scr,nch) cmdstr='%%Pages: '//scr(1:nch) call filler cmdstr='%%EOF' call filler return endif !Moving pen if(ipp.eq.3) then !Stroke to paint previous path, then moveto write(cmdstr,'(1p,2e14.6,'' SM'')')xcall*conver,ycall*conver else !Lineto write(cmdstr,'(1p,2e14.6,'' LSM'')')xcall*conver,ycall*conver endif call filler !Reset origin if ip.lt.0 if(ip.lt.0) then write(cmdstr,'(1p,2e14.6,'' translate'')')xcall*conver,ycall*conver call filler ipen=ipp endif end subroutine plot subroutine plotnd call plot(0.,0.,999) end subroutine plotnd subroutine circle(xc,yc,rad,fill) double precision,intent(in) :: xc,yc,rad logical,intent(in) :: fill double precision conver,xci,yci,radi character*132 cmdstr,scrc common/plt1/cmdstr common/cnvcom/conver xci=xc*conver yci=yc*conver radi=rad*conver scrc=' ' write(scrc,'(1p,e14.6,'' '',e14.6,'' '',e14.6,'' C'')') xci,yci,radi if(fill) then cmdstr='Np '//scrc(1:lenstr(scrc,132))//' fill' else cmdstr='Np '//scrc(1:lenstr(scrc,132))//' stroke' endif call filler end subroutine circle function lenstr(string,ls) !This routine finds actual length of string by eliminating trailing blanks character*(*) string do i=ls,1,-1 is=i if(string(i:i).ne.char(32)) goto 10 enddo is=0 10 lenstr=is end function lenstr subroutine blkstp(ch,ndim,a,leng) !character*1 ch(ndim),a(ndim) character(len=*) ch,a !Strip out blanks only (leave in esc, etc.) i=1 leng=0 10 continue if(ichar(ch(i:i)).ne.32)then leng=leng+1 a(leng:leng)=ch(i:i) endif if(i.eq.ndim) then !Blankfill remainder of output array do l=leng+1,ndim a(l:l)=' ' enddo return endif i=i+1 goto 10 end subroutine blkstp subroutine keknum(xp,yp,size,fpn,ang,ndec,mjus) !Just assume that user really wants kekflt. call kekflt(xp,yp,size,fpn,ang,ndec,mjus) end subroutine keknum subroutine kekflt(xp,yp,size,fpn,ang,ndec,mjus) dimension ichrnum(20) fnum=fpn !Get number in character form call numsym(fnum,ndec,ichrnum,ndigit,.false.) call keksym(xp,yp,size,ichrnum,ang,ndigit,mjus) end subroutine kekflt subroutine keksym(xp,yp,size,ltitle1,ang,nchar1,mjus) double precision conver character*132 cmdstr character*132 curfnt,scrc common/fntcom/curfnt,ifntsz,nfont character*80 titlec,titleb character*1 bslash dimension ltitle(20),ltitle1(20) equivalence(ititle,ltitle(1)) common/plt1/cmdstr common/cnvcom/conver common/kkplot/szrat !Stroke previous paths before this write cmdstr='S' call filler bslash=char(92) pi=4*abs(atan(1.)) if(nchar1.eq.-999) then !octal code do n=1,20 ltitle(n)=ltitle1(n) enddo nchar=1 else nchar=nchar1 write(titlec,'(20a4)')ltitle1 if(iabs(nchar).lt.80)titlec(nchar+1:80)=' ' read(titlec,'(20a4)')ltitle endif !Choose proper font height, using current font mchar=iabs(nchar) !Set character size iht=max(1,int(size*conver/.6)) !.6 FACTOR IS EMPIRICAL if(iht.ne.ifntsz) then cmdstr=' ' write(cmdstr,'(I3,'' Setf'')')iht call filler ifntsz=iht endif if(nchar1.eq.-999) then !Octal code write(titlec,'(A1,I10)')bslash,ititle call blkstp(titlec,80,titlec,numc) else write(titlec,'(20a4)')ltitle !Check if titlec contains ( or ) or \. These characters must be treated !specially by preceding them with a "\". Do this to ( and ) even though !they might be balanced, i.e. () within a string, which can be treated !normally. titleb=titlec numc=0 do m=1,mchar if(titleb(m:m).eq.'('.or.titleb(m:m).eq.')' .or. & & titleb(m:m).eq.bslash) then numc=numc+1 titlec(numc:numc)=bslash endif numc=numc+1 titlec(numc:numc)=titleb(m:m) enddo endif mchar=numc xpos=xp ypos=yp if(nchar.lt.0) then njus=0 else njus=mjus endif rsize=size !Character space height is 2.0 x char height !Character space width is 1.5 x char width !Actual string length is (nc-1)*1.5*char width + char width strlen=(rsize*szrat)*1.5*(mchar-1.)+rsize*szrat if(xpos.eq.999.) then cmdstr='/Xpos Xpres def' njus=0 else cmdstr=' ' write(cmdstr,'(1p,e14.6,'' Xposd'')')xp*conver endif call filler if(ypos.eq.999.) then cmdstr='/Ypos Ypres def' njus=0 else cmdstr=' ' write(cmdstr,'(1p,e14.6,'' Yposd'')')yp*conver endif call filler if(njus.ne.0.and.njus.ne.1.and.njus.ne.2) then print 110, njus 110 format(1x,'incorrect justification code ',i5,'found in ',& &'KEKSYM, zero used') njus=0 endif !Strlen has already been "factored" by the choice of font height !Since it will eventually be factored again, we must divide by !factor now. cmdstr='('//titlec(1:mchar)//') Lend' arg=ang*4.*abs(atan(1.))/180. xarg=cos(arg)*njus/2. yarg=sin(arg)*njus/2. if(xarg.ne.0.) then scrc=' ' write(scrc,'(f7.3,'' Xposjd'')')xarg cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) endif if(yarg.ne.0.) then scrc=' ' write(scrc,'(f7.3,'' Yposjd'')')yarg cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) endif if (nchar.eq.-1) then !centered symbol high=rsize wide=high*szrat xpos=xpos+high/2.*sin(arg)-wide/2.*cos(arg) ypos=ypos-high/2.*cos(arg)-wide/2.*sin(arg) xarg=high/2.*sin(arg)-wide/2.*cos(arg) yarg=-high/2.*cos(arg)-wide/2.*sin(arg) if(xarg.ne.0.) then scrc=' ' write(scrc, '(''/Xpos Xpos'',1p,e14.6,'' add def'')')xarg*conver cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) endif if(yarg.ne.0.) then scrc=' ' write(scrc,'(''/Ypos Ypos'',1p,e14.6,'' add def'')')yarg*conver cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) endif endif call filler !Move pen to proper coordinates scrc='xydef mover' cmdstr=scrc(1:lenstr(scrc,132)) !Set angle if(ang.ne.0.) then scrc=' ' write(scrc,'(F7.1,'' rotate'')') ang cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) endif scrc='('//titlec(1:mchar)//') show' cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) !Reset angle if(ang.ne.0.) then scrc=' ' write(scrc,'(F7.1,'' rotate'')') -ang cmdstr=cmdstr(1:lenstr(cmdstr,132))//' '// scrc(1:lenstr(scrc,132)) endif call filler !Start next char at .5 char width away argdeg=arg*180./pi cmdstr=' ' write(cmdstr,'(f6.1,'' Xyprset'')')argdeg call filler end subroutine keksym subroutine numsym(fpn,ndec,itext,nchar,eform) !eform: true for exponential format !false for floating pt format logical eform dimension itext(20) character*10 ifrmt character*80 a a=' ' !Check if ndec is valid if(ndec.gt.15) then print 100, ndec 100 format(1x,'In call to numsym, ndec gt 15 ',i20,' program',' abandoned') stop else if(eform.and.ndec.lt.0) then print 110, ndec 110 format(1x,'in numsym, exponential format specified with ','ndec= '& &,i3,' program abandoned') stop endif if(eform) then write(ifrmt,'(''(1pe16.'',i2,'')'')')ndec else if(ndec.lt.0) then ifrmt='(f16.1)' else write(ifrmt,'(''(f16.'',i2,'')'')')ndec endif write(a,ifrmt)fpn !Strip off all blanks in a call blkstp(a,80,a,nchar) ipos=index(a,'.') if(eform) then if(ndec.eq.0) then !Delete characters between '.' and 'E' ie=index(a,'E') do n=ie,nchar nind=ipos+n-ie+1 a(nind:nind)=a(n:n) enddo nchar=nchar-(ie-ipos-1) endif else if(ndec.lt.0) then nchar=ipos-1 else if(ndec.eq.0) then nchar=ipos endif read(a,'(20a4)')itext end subroutine numsym end module derivedPSPLOT