diff options
| author | stainer_t <thomas.stainer@oecd-nea.org> | 2025-09-08 13:48:49 +0200 |
|---|---|---|
| committer | stainer_t <thomas.stainer@oecd-nea.org> | 2025-09-08 13:48:49 +0200 |
| commit | 7dfcc480ba1e19bd3232349fc733caef94034292 (patch) | |
| tree | 03ee104eb8846d5cc1a981d267687a729185d3f3 /Utilib/src/PSFILL.f | |
Initial commit from Polytechnique Montreal
Diffstat (limited to 'Utilib/src/PSFILL.f')
| -rw-r--r-- | Utilib/src/PSFILL.f | 78 |
1 files changed, 78 insertions, 0 deletions
diff --git a/Utilib/src/PSFILL.f b/Utilib/src/PSFILL.f new file mode 100644 index 0000000..60eed97 --- /dev/null +++ b/Utilib/src/PSFILL.f @@ -0,0 +1,78 @@ +*DECK PSFILL + SUBROUTINE PSFILL(ISPSP,IFILL,GRYCOL,KFS,KFR) +C +C--------------------------- PSFILL --------------------------------- +C +C 1- PROGRAMME STATISTICS: +C NAME : PSFILL +C USE : SET GRAY LEVEL OR COLOR AND FILL PATERN +C +C 2- ROUTINE PARAMETERS: +C INPUT/OUTPUT +C ISPSP : PSP FILE UNIT I +C IFILL : FILL TYPE I +C = 0 SET TO COLOR(4) +C = 1 SET TO GRAY LEVEL +C = 2 SET RGB COLLOR PATTERN +C = 3 SET GRYCOL COLLOR PATTERN +C = 4 SET HSB COLLOR PATTERN +C GRYCOL : GRAY LEVEL OF COLOR INTENSITY R(4) +C KFS : FLAG TO SAVE DRAWING BEFORE FILLING I +C = 0 : NO SAVE +C = 1 : SAVE +C KFR : FLAG TO RESTORE DRAWING BEFORE FILLING I +C = 0 : NO RESTORE +C = 1 : RESTORE +C +C--------------------------- PSFILL -------------------------------- +C + IMPLICIT NONE + INTEGER ISPSP,IFILL + REAL GRYCOL(4) + INTEGER KFS,KFR +C---- +C LOCAL VARIABLES +C---- + CHARACTER NAMSBR*6 + PARAMETER (NAMSBR='PSFILL') + REAL COLOR(4) + CHARACTER CMDSTR*132 +C---- +C TAKE COLOR LEVEL BETWEEN 0.0 AND 1.0 +C---- + IF(KFR .EQ. 1) THEN + CMDSTR='grestore' + CALL PSCPUT(ISPSP,CMDSTR) + ENDIF + IF(KFS .EQ. 1) THEN + CMDSTR='gsave' + CALL PSCPUT(ISPSP,CMDSTR) + ENDIF + COLOR(1)=MIN(1.0,ABS(GRYCOL(1))) + COLOR(2)=MIN(1.0,ABS(GRYCOL(2))) + COLOR(3)=MIN(1.0,ABS(GRYCOL(3))) + COLOR(4)=MIN(1.0,ABS(GRYCOL(4))) + COLOR(1)=MAX(0.0,COLOR(1)) + COLOR(2)=MAX(0.0,COLOR(2)) + COLOR(3)=MAX(0.0,COLOR(3)) + COLOR(4)=MAX(0.0,COLOR(4)) + CMDSTR=' ' + IF(IFILL .EQ.4) THEN + WRITE(CMDSTR,'(3(F7.3,1X),A6)') + > COLOR(1),COLOR(2),COLOR(3),'FSchsb' + ELSE IF(IFILL.EQ.3) THEN + WRITE(CMDSTR,'(4(F7.3,1X),A6)') + > COLOR(1),COLOR(2),COLOR(3),COLOR(4),'FScmyk' + ELSE IF(IFILL.EQ.2) THEN + WRITE(CMDSTR,'(3(F7.3,1X),A6)') + > COLOR(1),COLOR(2),COLOR(3),'FScrgb' + ELSE IF(IFILL.EQ.1) THEN + WRITE(CMDSTR,'(1(F7.3,1X),A6)') + > COLOR(1),'FSgray' + ELSE + WRITE(CMDSTR,'(1(F7.3,1X),A6)') + > 0.0,'FSgray' + ENDIF + CALL PSCPUT(ISPSP,CMDSTR) + RETURN + END |