summaryrefslogtreecommitdiff
path: root/Dragon/src/PSP.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/PSP.f')
-rw-r--r--Dragon/src/PSP.f292
1 files changed, 292 insertions, 0 deletions
diff --git a/Dragon/src/PSP.f b/Dragon/src/PSP.f
new file mode 100644
index 0000000..ef3475c
--- /dev/null
+++ b/Dragon/src/PSP.f
@@ -0,0 +1,292 @@
+*DECK PSP
+ SUBROUTINE PSP(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* POSTSCRIPT plot utility module.
+*
+*Copyright:
+* Copyright (C) 1999 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. Marleau
+*
+*Parameters: input
+* NENTRY number of data structures transfered to this module.
+* HENTRY name of the data structures.
+* IENTRY data structure type where:
+* =1 for LCM memory object;
+* =2 for XSM file;
+* =3 for sequential binary file;
+* =4 for sequential ASCII file.
+* JENTRY access permission for the data structure where:
+* =0 for a data structure in creation mode;
+* =1 for a data structure in modifications mode;
+* =2 for a data structure in read-only mode.
+* KENTRY data structure pointer.
+*
+*Comments:
+* Input requirements
+* NENTRY >= 2
+* IEN = 1 : structure is a sequential ascii file
+* containing the output POSTSCRIPT. this can be A
+* new file or a file to update.
+* IENTRY(ien) = 4, JENTRY(ien) <= 1
+* FOR PSP BY Mixture or region
+* IEN > 1 : structure is a valid dragon geometry
+* for excelt stored in a linked list or XSM file.
+* this structure must be in read-only mode
+* IENTRY(ien)<= 2, JENTRY(ien) = 2
+* FOR PSP BY Flux
+* IEN = 2 : structure is a valid dragon geometry
+* for excelt stored in a linked list or XSM file.
+* this structure must be in read-only mode
+* IENTRY(ien)<= 2, JENTRY(ien) = 2
+* IEN = 3 : structure is a valid flux structure
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+ IMPLICIT NONE
+ INTEGER IOUT,NSTATE,ILCMUP,ILCMDN
+ CHARACTER NAMSBR*6
+ PARAMETER (IOUT=6,NSTATE=40,ILCMUP=1,ILCMDN=2,
+ > NAMSBR='PSP ')
+*----
+* ROUTINE PARAMTERS
+*----
+ INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
+ TYPE(C_PTR) KENTRY(NENTRY)
+ CHARACTER HENTRY(NENTRY)*12
+*----
+* LOCAL VARIABLES
+*----
+ INTEGER ISTATE(NSTATE),IPRINT,IEN,
+ > IENGT,IENFL,ISPSP,ITYPE,ICOLR,
+ > NPAGE,ITRK,NGROUP,NUNKNO,IGR,NGT
+ CHARACTER HSIGN*12,NAMGT*12,NAMLEG*24
+ REAL XYPOS(2)
+ CHARACTER NAMTR2*12,NAMGEO*12
+ TYPE(C_PTR) IPTRK2,IPFL,IPGT
+ INTEGER IMODT2,IMEDT2,ICLST2,IPRIN2
+ LOGICAL LASS,LDRASS
+ INTEGER IMODE,NMODE
+ TYPE(C_PTR) JPFL,KPFL
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: ICOND
+ REAL, ALLOCATABLE, DIMENSION(:) :: FLUX,TFLX
+*----
+ NAMTR2='PSPGEOIPTRK2'
+ IMODT2=0
+ IMEDT2=1
+ IPRIN2=0
+ ICLST2=2
+*----
+* INPUT PARAMETER VALIDATION
+*----
+ XYPOS(1)=0.5
+ XYPOS(2)=0.5
+ IF(NENTRY .LT. 2 ) CALL XABORT(NAMSBR//
+ > ': AT LEAST TWO DATA STRUCTURES REQUIRED')
+ ISPSP=FILUNIT(KENTRY(1))
+ IF(IENTRY(1) .NE. 4 ) CALL XABORT(NAMSBR//
+ > ': POSTSCRIPT DATA STRUCTURE NOT AN ASCII FILE')
+ IF(JENTRY(1) .NE. 0 .AND.
+ > JENTRY(1) .NE. 1 ) CALL XABORT(NAMSBR//
+ > ': POSTSCRIPT DATA STRUCTURE NOT IN CREATE OR MODIFY MODE')
+*----
+* Find if one of the structures is a flux
+* and get number of groups if required
+*----
+ NGROUP=1
+ IENFL=0
+ DO IEN=1,NENTRY
+ IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2 ) THEN
+ IF(JENTRY(IEN) .GT. 0 ) THEN
+ IPFL=KENTRY(IEN)
+ CALL LCMGTC(IPFL,'SIGNATURE',12,HSIGN)
+ IF(HSIGN .EQ. 'L_FLUX ') THEN
+ IENFL=IEN
+ ISTATE(:NSTATE)=0
+ CALL LCMGET(IPFL,'STATE-VECTOR',ISTATE)
+ NGROUP=ISTATE(1)
+ NUNKNO=ISTATE(2)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+*----
+* READ PSP OPTIONS
+* IPRINT : EDIT LEVEL
+* = 0 NO EDIT
+* = 1 NORMAL EDIT (DEFAULT)
+* > 1 EDIT FOR DEBUG
+*----
+ ALLOCATE(ICOND(NGROUP))
+ CALL PSPGET(IPRINT,ITYPE,ICOLR,NGROUP,NGT,ICOND)
+*----
+* OPEN POSTSCRIPT OUTPUT FILE
+* 1) IF THE FIRST DATA STRUCTURE IS IN UPDATE
+* TEST IF IT IS A POSTSCRIPT FILE CREATED BY DRAGON
+* AND PREPARE FILE FOR OUTPUT
+*----
+ CALL PSPFIL(ISPSP,JENTRY(1),HENTRY(1),NPAGE)
+*----
+* SCAN OVER DATA STRUCTURES AND PROCESS STRUCTURE ONE AFTER THE OTHER
+*----
+ IF(ITYPE .EQ. 0 .OR. ITYPE .EQ. 1 .OR. ITYPE .EQ. 4) THEN
+ NUNKNO=1
+ IF(ITYPE .EQ. 0) THEN
+ NAMLEG='Region'
+ ELSE IF(ITYPE .EQ. 1) THEN
+ NAMLEG='Mixture'
+ ELSE IF(ITYPE .EQ. 4) THEN
+ NAMLEG='HMIX'
+ ENDIF
+ ALLOCATE(FLUX(NUNKNO))
+ FLUX=0.0
+ DO 100 IENGT=2,NENTRY
+*----
+* READ SIGNATURE OF NEXT DATA STRUCTURE AND TEST IF
+* PSP CAN BE USED TO PROCESS THIS DATA STRUCTURE
+*----
+ IF(IENTRY(IENGT) .NE. 1 .AND.
+ > IENTRY(IENGT) .NE. 2 ) CALL XABORT(NAMSBR//
+ > ': NEXT DATA STRUCTURE NOT A LINKED LIST OR XSM FILE')
+ IF(JENTRY(IENGT) .NE. 2 ) CALL XABORT(NAMSBR//
+ > ': NEXT DATA STRUCTURE NOT IN READ-ONLY MODE')
+ IPGT=KENTRY(IENGT)
+ NAMGT=HENTRY(IENGT)
+ CALL LCMGTC(IPGT,'SIGNATURE',12,HSIGN)
+ ITRK=1
+*----
+* TEST IF GEOMETRY OR EXCELL TRACK DATA STRUCTURE
+*----
+ IF(HSIGN .EQ. 'L_GEOM ') THEN
+ ITRK=0
+ NAMGEO=HENTRY(IENGT)
+ ELSE IF(HSIGN .EQ. 'L_TRACK ') THEN
+ CALL LCMGTC(IPGT,'TRACK-TYPE',12,HSIGN)
+ IF(HSIGN .NE. 'EXCELL') ITRK=-1
+ ELSE
+ GO TO 115
+ ENDIF
+*----
+* FOR GEOMETRY OPTION CALL AXGGEO
+* TO GENERATE TEMPORARY TRACKING STRUCTURE
+*----
+ IF(ITRK .EQ. 0) THEN
+ LASS=LDRASS(IPGT,IPRINT)
+ CALL LCMOP(IPTRK2,NAMTR2,IMODT2,IMEDT2,IPRIN2)
+ CALL AXGGEO(IPGT ,IPTRK2,IPRINT,NAMGEO)
+ IPGT=IPTRK2
+ ENDIF
+*----
+* CALL PSPTRK TO GENERATE POSTSCRIPT
+*----
+ CALL PSPTRK(IPRINT,ISPSP ,ITYPE ,ICOLR ,IPGT ,NAMGT ,
+ > NAMLEG,NUNKNO,FLUX )
+ IF(ITRK .EQ. 0) THEN
+ CALL LCMCL(IPTRK2,ICLST2)
+ ENDIF
+ CALL PSCUTP(ISPSP)
+ IF(IENGT .NE. NENTRY) THEN
+ NPAGE=NPAGE+1
+ CALL PSPAGE(ISPSP,NPAGE,XYPOS)
+ ENDIF
+ 115 CONTINUE
+ 100 CONTINUE
+ DEALLOCATE(FLUX)
+ ELSE IF(ITYPE .EQ. 2 .OR. ITYPE .EQ. 3 .OR.
+ > ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN
+*----
+* TEST SECOND DATA STRUCTURE
+*----
+ IENGT=2
+ IF(IENTRY(IENGT) .NE. 1 .AND.
+ > IENTRY(IENGT) .NE. 2 ) CALL XABORT(NAMSBR//
+ > ': SECOND DATA STRUCTURE NOT A LINKED LIST OR XSM FILE')
+ IF(JENTRY(IENGT) .NE. 2 ) CALL XABORT(NAMSBR//
+ > ': SECOND DATA STRUCTURE NOT IN READ-ONLY MODE')
+ IPGT=KENTRY(IENGT)
+ NAMGT=HENTRY(IENGT)
+ CALL LCMGTC(IPGT,'SIGNATURE',12,HSIGN)
+ ITRK=1
+*----
+* TEST IF GEOMETRY OR EXCELL TRACK DATA STRUCTURE
+*----
+ IF(HSIGN .EQ. 'L_GEOM ') THEN
+ ITRK=0
+ NAMGEO=HENTRY(IENGT)
+ ELSE IF(HSIGN .EQ. 'L_TRACK ') THEN
+ CALL LCMGTC(IPGT,'TRACK-TYPE',12,HSIGN)
+ IF(HSIGN .NE. 'EXCELL') ITRK=-1
+ ENDIF
+*----
+* TEST IF FLUX DATA STRUCTURE EXISTS
+*----
+ IF(IENFL .EQ. 0) CALL XABORT(NAMSBR//
+ > ': No flux data structure available')
+ ALLOCATE(FLUX(NUNKNO),TFLX(NUNKNO))
+ IF(ITYPE .EQ. 5 .OR. ITYPE .EQ. 6) THEN
+ NMODE=ISTATE(4)
+ JPFL=LCMGID(IPFL,'MODE')
+ ELSE
+ NMODE=1
+ JPFL=IPFL
+ ENDIF
+ DO IMODE=1,NMODE
+ IF(ITYPE .EQ. 5 .OR. ITYPE .EQ. 6) THEN
+ KPFL=LCMGIL(JPFL,IMODE)
+ ELSE
+ KPFL=JPFL
+ ENDIF
+ DO IGR=1,NGT
+*----
+* Compute condensed flux
+*----
+ CALL PSPFCD(KPFL,NGROUP,NUNKNO,IGR,ICOND,FLUX,TFLX)
+*----
+* FOR GEOMETRY OPTION CALL AXGGEO
+* TO GENERATE TEMPORARY TRACKING STRUCTURE
+*----
+ IF(NGT .EQ. 1) THEN
+ WRITE(NAMLEG,'(A21)') 'Flux: fully condensed'
+ ELSE IF(NGT .EQ. NGROUP) THEN
+ WRITE(NAMLEG,'(A18,I5)') 'Flux: tran. group ',IGR
+ ELSE
+ WRITE(NAMLEG,'(A18,I5)') 'Flux: cond. group ',IGR
+ ENDIF
+ IF(ITRK .EQ. 0) THEN
+ CALL LCMOP(IPTRK2,NAMTR2,IMODT2,IMEDT2,IPRIN2)
+ CALL AXGGEO(IPGT ,IPTRK2,IPRINT,NAMGEO)
+ IPGT=IPTRK2
+ ENDIF
+*----
+* CALL PSPTRK TO GENERATE POSTSCRIPT
+*----
+ CALL PSPTRK(IPRINT,ISPSP ,ITYPE ,ICOLR ,IPGT ,NAMGT ,
+ > NAMLEG,NUNKNO,FLUX )
+ IF(ITRK .EQ. 0) THEN
+ CALL LCMCL(IPTRK2,ICLST2)
+ ENDIF
+ CALL PSCUTP(ISPSP)
+ IF(IGR .NE. NGT) THEN
+ NPAGE=NPAGE+1
+ CALL PSPAGE(ISPSP,NPAGE,XYPOS)
+ ENDIF
+ ENDDO
+ ENDDO
+ DEALLOCATE(TFLX,FLUX)
+ ENDIF
+ WRITE(ISPSP,'(1X)')
+ DEALLOCATE(ICOND)
+ RETURN
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:18:11 +0000