Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! io_ppm.f90 is part of AstroBEAR. 00008 ! 00009 ! AstroBEAR is free software: you can redistribute it and/or modify 00010 ! it under the terms of the GNU General Public License as published by 00011 ! the Free Software Foundation, either version 3 of the License, or 00012 ! (at your option) any later version. 00013 ! 00014 ! AstroBEAR is distributed in the hope that it will be useful, 00015 ! but WITHOUT ANY WARRANTY; without even the implied warranty of 00016 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00017 ! GNU General Public License for more details. 00018 ! 00019 ! You should have received a copy of the GNU General Public License 00020 ! along with AstroBEAR. If not, see <http://www.gnu.org/licenses/>. 00021 ! 00022 !######################################################################### 00025 00029 00032 MODULE IOPPM 00033 USE GlobalDeclarations 00034 IMPLICIT NONE 00035 00036 CONTAINS 00037 00038 SUBROUTINE WritePPM(Filename, colormap, data, cmin, cmax) 00039 CHARACTER(LEN=*) :: Filename 00040 CHARACTER(LEN=210) :: system_cmd 00041 REAL(KIND=qPREC), DIMENSION(:,:) :: data 00042 REAL(KIND=qPREC) :: cmin, cmax 00043 INTEGER, DIMENSION(:,:) :: colormap 00044 INTEGER :: i,j 00045 OPEN(UNIT=PPM_DATA_HANDLE, FILE=TRIM(FileName), status="unknown") 00046 write(PPM_DATA_HANDLE,'(A,3I6)') 'P3 ',shape(data), 255 00047 DO j=size(data,2),1,-1 00048 DO i=1,size(data,1) 00049 write(PPM_DATA_HANDLE,'(3I5)') RGBInterp(data(i,j),cmin, cmax,colormap) 00050 END DO 00051 END DO 00052 CLOSE(PPM_DATA_HANDLE) 00053 ! j=len(trim(FileName)) 00054 ! write(system_cmd,'(A8,A,A1,A,A12,A)') 'convert ',TRIM(FileName), ' ', FileName(1:j-4), '.jpeg && rm ', TRIM(FILENAME) 00055 ! write(*,*) system_cmd 00056 ! CALL SYSTEM(system_cmd) 00057 00058 END SUBROUTINE WritePPM 00059 00060 FUNCTION RGBInterp(x,cmin,cmax,colormap) 00061 REAL(KIND=qPREC) :: x,dx,f,cmin,cmax 00062 INTEGER :: i2,i1 00063 INTEGER, DIMENSION(:,:) :: colormap 00064 INTEGER, DIMENSION(3) :: RGBInterp 00065 dx=(cmax-cmin)/real(size(colormap,1)-1) 00066 i2=min(size(colormap,1),max(ceiling((x-cmin)/dx)+1,2)) 00067 i1=i2-1 00068 f=(x-cmin)/dx+1-i1 00069 RGBInterp=NINT(colormap(i1,:)*(1d0-f)+f*colormap(i2,:)) 00070 RGBInterp=max((/0,0,0/),min((/255,255,255/),RGBInterp)) 00071 00072 ! IF (x /= 0d0) THEN 00073 ! write(*,*) dx, cmin, cmax, RGBInterp 00074 ! STOP 00075 ! END IF 00076 END FUNCTION RGBInterp 00077 00078 END MODULE IOPPM 00079 00080