! mozi-koodo: EUC
! 06/9/6版
! CalculiXのcgxで描いた応力図は、カラー21段階のグラデーションで
! 描かれているが、二つ以上の応力図を比較する際に、最大-最小の狭い
! 方の応力図のグラデーションを最大-最小の広い方の応力図の
! グラデーションに合わせて描き直す。
! まだ、21段階のグラデーションをグレースケール化した図も出力する。
!
! 入力ファイルはアスキーppm化し、cgxinp.ppm というファイル名にする。
! 出力はカラーが cgxout.ppm 白黒が cgxout.pgm
!
        program ppmzeng
       implicit real*8 (a-h, o-z)
       dimension irgb3(3900000),ir(1300000),ig(1300000),ib(1300000)
       character p3*2,mozi*44
       print*,'色スケールの最大値、最小値を+10から-10までの整数で入力'
       print*,'元図のグレースケールがほしいなら 10,-10 と入力'
       read*,maxs,mins
       open(8,file='cgxinp.ppm')
          read(8,'(a2)') p3
           write(*,*) 'マジックナンバー：',p3
          read(8,*) mozi
          read(8,*) m,n
          write(*,*) '幅：',m
          write(*,*) '高さ：',n
           mn=m*n
          read(8,*) max
          write(*,*) '最大値：',max
          do i=1,mn
           read(8,*) irgb3((i-1)*3+1)
           read(8,*) irgb3((i-1)*3+2)
           read(8,*) irgb3((i-1)*3+3)
          end do
!
!  以上がデータ入力
!
        do i=1,mn
          ir(i)=irgb3((i-1)*3+1)
          ig(i)=irgb3((i-1)*3+2)
          ib(i)=irgb3((i-1)*3+3)
       end do
!
!
       open(7,file='cgxout.pgm')
       write(7,*) 'P2'
       write(7,*) m,n
       write(7,*) max
       do i=1,mn
       if( (ir(i)<50).and.(ig(i)<50).and.(ib(i)<50) ) then
               write(7,*) 0
       else
        if( (ir(i)>200).and.(ig(i)>200).and.(ib(i)>200) ) then
               write(7,*) 255
        else
         call iro(ir(i),ig(i),ib(i),igs)
         igs=int( (maxs-mins)/20.*igs+(maxs+mins)/2. )
         write(7,*) int(12.75*igs+127.5) 
        end if
       end if
       end do
       close(7)
!
!
       open(7,file='cgxout.ppm')
       write(7,*) 'P3'
       write(7,*) m,n
       write(7,*) max
       do i=1,mn
       if( (ir(i)<50).and.(ig(i)<50).and.(ib(i)<50) ) then
               write(7,*) 0,0,0
       else
        if( (ir(i)>200).and.(ig(i)>200).and.(ib(i)>200) ) then
               write(7,*) 255,255,255
        else
         call iro(ir(i),ig(i),ib(i),igs)
         igs=int( (maxs-mins)/20.*igs+(maxs+mins)/2. )
         call iroiro(igs)
        end if
       end if
       end do
       close(7)
!
!
!
       open(7,file='cgxout2.ppm')
       write(7,*) 'P3'
       write(7,*) m,n
       write(7,*) max
       do i=1,mn
       if( (ir(i)<50).and.(ig(i)<50).and.(ib(i)<50) ) then
               write(7,*) 0,0,0
       else
        if( (ir(i)>200).and.(ig(i)>200).and.(ib(i)>200) ) then
               write(7,*) 255,255,255
        else
         call iro(ir(i),ig(i),ib(i),igs)
         igs=int( (maxs-mins)/20.*igs+(maxs+mins)/2. )
         call iroiro2(igs)
        end if
       end if
       end do
       close(7)
!
          end
!
!
          subroutine iro(lr,lg,lb,lgs)
          implicit real*8(a-h, o-z)
!         call hantei(lr,lg,lb,lgs,255,255,255,10)
          call hantei(lr,lg,lb,lgs,191,  0,  0,10)
          call hantei(lr,lg,lb,lgs,223, 64,  0, 9)
          call hantei(lr,lg,lb,lgs,255,128,  0, 8)
          call hantei(lr,lg,lb,lgs,255,191,  0, 7)
          call hantei(lr,lg,lb,lgs,255,255,  0, 6)
          call hantei(lr,lg,lb,lgs,212,234,  0, 5)
          call hantei(lr,lg,lb,lgs,170,212,  0, 4)
          call hantei(lr,lg,lb,lgs,127,191,  0, 3)
          call hantei(lr,lg,lb,lgs, 85,170,  0, 2)
          call hantei(lr,lg,lb,lgs, 43,149,  0, 1)
          call hantei(lr,lg,lb,lgs,  0,128,  0, 0)
          call hantei(lr,lg,lb,lgs,  0,159, 26,-1)
          call hantei(lr,lg,lb,lgs,  0,191, 51,-2)
          call hantei(lr,lg,lb,lgs,  0,223, 77,-3)
          call hantei(lr,lg,lb,lgs,  0,255,102,-4)
          call hantei(lr,lg,lb,lgs,  0,191,128,-5)
          call hantei(lr,lg,lb,lgs,  0,128,153,-6)
          call hantei(lr,lg,lb,lgs,  0, 64,178,-7)
          call hantei(lr,lg,lb,lgs,  0,  0,204,-8)
          call hantei(lr,lg,lb,lgs, 64,  0,229,-9)
          call hantei(lr,lg,lb,lgs,128,  0,255,-10)
!         call hantei(lr,lg,lb,lgs,  0,  0,  0,-10)
          return
          end
!
!
          subroutine hantei(jr,jg,jb,jgs,kr,kg,kb,kgs)
          implicit real*8(a-h, o-z)
          if( (kr-20<jr).and.(jr<kr+20) .and.
     &        (kg-20<jg).and.(jg<kg+20) .and.
     &        (kb-20<jb).and.(jb<kb+20)   )  jgs=kgs
          return
          end
!
!
          subroutine iroiro(lgs)
          implicit real*8(a-h, o-z)
          if(lgs==10) write(7,*) 191,  0,  0
          if(lgs== 9) write(7,*) 223, 64,  0
          if(lgs== 8) write(7,*) 255,128,  0
          if(lgs== 7) write(7,*) 255,191,  0
          if(lgs== 6) write(7,*) 255,255,  0
          if(lgs== 5) write(7,*) 212,234,  0
          if(lgs== 4) write(7,*) 170,212,  0
          if(lgs== 3) write(7,*) 127,191,  0
          if(lgs== 2) write(7,*)  85,170,  0
          if(lgs== 1) write(7,*)  43,149,  0
          if(lgs== 0) write(7,*)   0,128,  0
          if(lgs==-1) write(7,*)   0,159, 26
          if(lgs==-2) write(7,*)   0,191, 51
          if(lgs==-3) write(7,*)   0,223, 77
          if(lgs==-4) write(7,*)   0,255,102
          if(lgs==-5) write(7,*)   0,191,128
          if(lgs==-6) write(7,*)   0,128,153
          if(lgs==-7) write(7,*)   0, 64,178
          if(lgs==-8) write(7,*)   0,  0,204
          if(lgs==-9) write(7,*)  64,  0,229
          if(lgs==-10) write(7,*) 128,  0,255
          return
          end
!
!
!
          subroutine iroiro2(lgs)
          implicit real*8(a-h, o-z)
          if(lgs==10) write(7,*) 255,255,255
          if(lgs== 9) write(7,*) 255,255,219
          if(lgs== 8) write(7,*) 255,255,182
          if(lgs== 7) write(7,*) 255,255,146
          if(lgs== 6) write(7,*) 255,255,109
          if(lgs== 5) write(7,*) 255,255, 72
          if(lgs== 4) write(7,*) 255,255, 36
          if(lgs== 3) write(7,*) 219,255,  0
          if(lgs== 2) write(7,*) 182,255,  0
          if(lgs== 1) write(7,*) 146,255,  0
          if(lgs== 0) write(7,*) 109,255,  0
          if(lgs==-1) write(7,*)  72,255,  0
          if(lgs==-2) write(7,*)  32,255,  0
          if(lgs==-3) write(7,*)   0,255,  0
          if(lgs==-4) write(7,*)   0,219,  0
          if(lgs==-5) write(7,*)   0,182,  0
          if(lgs==-6) write(7,*)   0,146,  0
          if(lgs==-7) write(7,*)   0,109,  0
          if(lgs==-8) write(7,*)   0, 72,  0
          if(lgs==-9) write(7,*)   0, 36,  0
          if(lgs==-10) write(7,*)   0,  0,  0
          return
          end
!
!
