Quelle  kreis8.cob

       identification division.
       program-id. kreis8.
      * von Rüdiger Nicolovius
      * zu den platonischen und archimedischen Polyedern
      * Programm KRESI8.F
       author. "JD".
       date-written. 16.2.2009.
       date-compiled.
       data division.
       working-storage section.
      * implicit
        77 i     pic S9(4) comp.
        77 aaa   pic S9(4)V9(4) comp-2.
        77 bbb   pic S9(4)V9(4) comp-2.
        77 ccc   pic S9(4)V9(4) comp-2.
        77 ddd   pic S9(4)V9(4) comp-2.
        77 rrr   pic S9(4)V9(4) comp-2.
        77 f1    pic S9(4)V9(4) comp-2.
        77 f2    pic S9(4)V9(4) comp-2.
        77 f3    pic S9(4)V9(4) comp-2.
      *
        77 pp1    pic S9(4)V9(4) comp-2 occurs 3.
        77 pp2    pic S9(4)V9(4) comp-2 occurs 3.
        77 pp3    pic S9(4)V9(4) comp-2 occurs 3.
        77 ppm    pic S9(4)V9(4) comp-2 occurs 3.
      *
        77 nullf   pic S9(4)V9(4) comp-2 value 0.0E0.
        77 eins    pic S9(4)V9(4) comp-2 value 1.0E0.
        77 zwei    pic S9(4)V9(4) comp-2 value 2.0E0.
        77 eps     pic S9(4)V9(4) comp-2 value 1.0E-15.
       linkage section.
        77 p1    pic S9(4)V9(4) comp-2 occurs 3.
        77 p2    pic S9(4)V9(4) comp-2 occurs 3.
        77 p3    pic S9(4)V9(4) comp-2 occurs 3.
        77 pm    pic S9(4)V9(4) comp-2 occurs 3.
        77 rad   pic S9(4)V9(4) comp-2 occurs 3.
      *
        77 idim  pic S9(4) comp.
        77 iflag pic S9(4) comp.
       procedure division using idim p1 p2 p3 pm rad iflag.
          move 0 to iflag
          move p1(1) to pp1(1)
          move p2(1) to pp3(1)
          move p3(1) to pp3(1)
          move p1(2) to pp1(2)
          move p2(2) to pp2(2)
          move p3(2) to pp3(2)        
          if idim < 2 or idim > 3 then
            move 1 to iflag
            stop run
          end-if  
          if idim = 2 then
            move nullf to pp1(3)
            move nullf to pp2(3)
            move nullf to pp3(3)        
          else
            move p1(3) to pp1(3)
            move p2(3) to pp2(3)
            move p3(3) to pp3(3)        
          end-if
          move nullf to aaa bbb ccc.
      *  
          move 1 to i
        loop10.
          if i>3 goto continue10.
          compute aaa=aaa+(pp2(i)-pp1(i))**2.
          compute bbb=bbb+(pp3(i)-pp1(i))*(pp2(i)-pp1(i)).
          compute ccc=ccc+(pp3(i)-pp1(i))**2.
          add 1 to i.
          goto loop10.
        continue10.
          compute ddd=aaa*ccc- bbb*2.
          if function abs(ddd) <= eps*(aaa*+2+ccc**2) then
            move 2 to iflag
            stop run
          end-if
          compute ddd=zwei*ddd
          compute f1=bbb*(aaa+ccc-zwei*bbb)/ddd
          compute f2=ccc*(aaa-bbb)/ddd
          compute f3=aaa*(ccc-bbb)/ddd
          move nullf to rrr.
          move 1 to i
        loop20.
          if i>3 goto continue20.
          compute ppm(i)=f1*pp1(i)+f2*pp2(i)+f3*pp3(i).
          compute rrr=rrr+(ppm(i)-pp1(i))**2
          add 1 to i.
          goto loop20.
        continue20.
          move ppm(1) to pm(1)
          move ppm(2)to pm(2).
          if idim = 3  move ppm(3) to pm(3).
          move function sqrt(rrr) to rad.        
        end program kreis8.